
{*******************************************************}
{                                                       }
{       Graphics Vision Unit                            }
{                                                       }
{	Portions copyright (c) 1992 Borland Intl.       }
{       Copyright (c) 1994 Stefan Milius                }
{	Copyright (c) 1997 Matthias Koeppe              }
{                                                       }
{*******************************************************}

unit GVApp;

{$ifndef FPK}
{$A+,B-,D+,F+,G+,O+,R-,S-,X+,I-}
{$endif}

interface

{$ifdef FPK}
uses Dos, Objects, Drivers, Memory, Views, BGI, GvFPK, Extgraph,
     GvViews, GvMenus, GvTexts, KeyNames, GvMouse;
type PDialog = PWindow;
{$define AsyncMouse} 
{$define MouseView}
{$else}
{$ifdef Windows}
uses WinDos, Dos, {$ifdef VER80} Messages, {$endif}
  WinTypes, Objects, Drivers, WinGr, Memory, Views, GvViews,
  GvDialog, GvMenus, Strings;
{$else}
uses Dos, Objects, Drivers, Memory, Views, GVViews, GVDialog, GVMenus
  {$ifdef MouseView}, GvMouse{$endif};
{$define AsyncMouse} { No synchronous call-backs from the mouse handler }
{$endif Windows}
{$endif FPK}

const

{ TApplication palette }

  CColor = #03#00#07#12#15#07#12#15#00#15#07#15#01#00#15#01#00#15#07#00#15#08+  {  22 }
	   #15#00#07#08#07#00#15#15#07#07#07#15#01#00#15#01#00#15#07#00#15#08+  {  44 }
	   #15#00#07#08#07#00#15#07#01#03#07#15#01#00#15#01#00#15#07#00#15#08+  {  66 }
	   #15#00#07#08#07#07#00#00#07#07#07#15#01#00#15#01#00#15#07#00#15#08+  {  88 }
	   #15#00#07#08#07#00#00#15#04#04#07#07#00#09#07#00#14#15#06#12#12#12+  { 110 }
	   #08#00#09#00#07#15#00#15#14#14#07#07#07#08#15#15#07#02#00#00#15#07+  { 132 }
	   #00#15#00#00#15#15#00#15#07#00#07#06#08#07#15#01#00#15#01#00#15#07+  { 154 }
	   #00#15#08#15#00#07#08#07#15#15#01#00#02;				{ 167 }

{ Application idle command }

  cmIdle  = 41;

{ Standard application commands }

  cmNew       = 30;
  cmOpen      = 31;
  cmSave      = 32;
  cmSaveAs    = 33;
  cmSaveAll   = 34;
  cmChangeDir = 35;
  cmDosShell  = 36;
  cmCloseAll  = 37;

{ Standard application help contexts }

  hcNew          = hc + cmNew;
  hcOpen         = hc + cmOpen;
  hcSave         = hc + cmSave;
  hcSaveAs       = hc + cmSaveAs;
  hcSaveAll      = hc + cmSaveAll;
  hcChangeDir    = hc + cmChangeDir;
  hcDosShell     = hc + cmDosShell;
  hcExit         = hc + cmQuit;

  hcUndo         = hc + cmUndo;
  hcCut          = hc + cmCut;
  hcCopy         = hc + cmCopy;
  hcPaste        = hc + cmPaste;
  hcClear        = hc + cmClear;

  hcTile         = hc + cmTile;
  hcCascade      = hc + cmCascade;
  hcCloseAll     = hc + cmCloseAll;
  hcResize       = hc + cmResize;
  hcZoom         = hc + cmZoom;
  hcNext         = hc + cmNext;
  hcPrev         = hc + cmPrev;
  hcClose        = hc + cmClose;

type

{ TDeskTop object }

  PDeskTop = ^TDeskTop;
  TDeskTop = object(TGGroup)
    Background: PBackground;
    TileColumnsFirst: Boolean;
    constructor Init(var Bounds: TRect);
    constructor Load(var S: TStream);
    procedure Cascade(var R: TRect);
    procedure HandleEvent(var Event: TEvent); virtual;
    procedure InitBackground; virtual;
    procedure Store(var S: TStream);
    procedure Tile(var R: TRect);
    procedure TileError; virtual;
  end;

{ TMainGroup object }

{$ifdef Windows}
type
  PMainGroup = ^TMainGroup;
  TMainGroup = object(TGGroup)
    Title: PString;
    constructor Init(var Bounds: TRect; ATitle: string);
    function CreateRootWindow: Integer; virtual;
    procedure HandleEvent(var Event: TEvent); virtual;
    procedure SetTitle(ATitle: string); virtual;
    procedure SizeLimits(var Min, Max: TPoint); virtual;
    procedure UpdateWinTitle; virtual;
  end;

const
  MinMainSize: TPoint = (X: 200; Y: 100);
{$endif Windows}

{ TProgram object }

  { Palette layout }
  {      1 = TBackground }
  {  2-  9 = TMenuView/TStatusLine }
  { 10- 31 = TWindow (White) }
  { 32- 53 = TWindow (Gray) }
  { 54- 75 = TWindow (Cyan) }
  { 76-139 = TDialog }
  {140-144 = misc }
  {145-165 = THelpWindow }

    {  94 = StaticText and StaticSign }
    {  95 = Label normal text }
    {  96 = Label selected text }
    {  97 = Label normal shortcut }
    {  98 = Label selected shortcut }
    {  99 = Label normal background }
    { 100 = Label selected background }
    { 101 = Icon normal background }
    { 102 = Icon selected background }
    { 103 = Button background }
    { 104 = Button normal text }
    { 105 = Button default text }
    { 106 = Button selected text }
    { 107 = Button disabled text }
    { 108 = Button normal shortcut }
    { 109 = Button default shortcut }
    { 110 = Button selected shortcut }
    { 111 = Button border }
    { 112 = Button lines }
    { 113 = Regler frame selected }
    { 114 = Regler frame normal }
    { 115 = Regler frame disabled }
    { 116 = Regler background }
    { 117 = Cluster normal text }
    { 118 = Cluster selected text }
    { 119 = Cluster normal shortcut }
    { 120 = Cluster selected shortcut }
    { 121 = Cluster normal background }
    { 122 = Cluster selected background }
    { 123 = Cluster disabled background }
    { 124 = Cluster disabled text }
    { 125 = InputLine passive }
    { 126 = InputLine active }
    { 127 = InputLine selected }
    { 128 = InputLine arrows }
    { 129 = InputLine frame }
    { 130 = InputLine text }
    { 131 = InputLine cursor }
    { 132 = Arrowfield background }
    { 133 = Arrowfield icon }
    { 134 = ListViewer background }
    { 135 = ListViewer frame }
    { 136 = ListViewer normal text }
    { 137 = ListViewer selected text }
    { 138 = ListViewer normal background }
    { 139 = ListViewer selected background }
    { 140 = InfoPane text }
    { 141 = InfoPane background }
    { 142 = Clock text }
    { 143 = Clock background }
    { 144 = Eye color }

type
  PProgram = ^TProgram;
  TProgram = object(TGGroup)
  {$ifdef Windows}
    Ctl3DModule: THandle;
  {$endif Windows}
  {$ifdef MouseView}
    Mouse: PGView;
  {$endif MouseView}
    constructor Init;
    destructor Done; virtual;
    function CanMoveFocus: Boolean;
    procedure DoneEvents; virtual;
    procedure DoneFonts; virtual;
    procedure DoneTexts; virtual;
    procedure EnableCtl3D;
    function ExecuteDialog(P: PDialog; Data: Pointer): Word;
    procedure GetEvent(var Event: TEvent); virtual;
    function GetPalette: PPalette; virtual;
    procedure HandleEvent(var Event: TEvent); virtual;
    procedure Idle; virtual;
    procedure InitDesktop; virtual;
    procedure InitEvents; virtual;
    procedure InitFonts; virtual;
    procedure InitMain; virtual;
    procedure InitMenuBar; virtual;
    procedure InitScreen; virtual;
    procedure InitStatusLine; virtual;
    procedure InitTexts; virtual;
    function InsertWindow(P: PWindow): PWindow;
    function LanguageResource: string; virtual;
    procedure OutOfMemory; virtual;
    procedure PutEvent(var Event: TEvent); virtual;
    procedure Run; virtual;
    procedure SetScreenMode(Mode: Word);
    procedure Timer(var Event: TEvent); virtual;
    function ValidView(P: PGView): PGView;
  end;

{ TApplication object }

  PApplication = ^TApplication;
  TApplication = object(TProgram)
    constructor Init;
    destructor Done; virtual;
    procedure Cascade;
    procedure DosShell;
    procedure GetTileRect(var R: TRect); virtual;
    procedure HandleEvent(var Event: TEvent); virtual;
    procedure Tile;
    procedure WriteShellMsg; virtual;
  end;

{ Standard menus and status lines }

function StdStatusKeys(Next: PStatusItem): PStatusItem;
function StdDraggingStatusDef(Next: PStatusDef): PStatusDef;

function StdFileMenuItems(Next: PMenuItem): PMenuItem;
function StdEditMenuItems(Next: PMenuItem): PMenuItem;
function StdWindowMenuItems(Next: PMenuItem): PMenuItem;

{ GVApp registration procedure }

procedure RegisterGVApp;

const

{ Public variables }

  Main: PGGroup = nil;
  Application: PProgram = nil;
  Desktop: PDesktop = nil;
  MenuBar: PMenuView = nil;
  StatusLine: PStatusLine = nil;

{ Stream registration records }

const
  RDeskTop: TStreamRec = (
    ObjType: 146;
    VmtLink: Ofs(TypeOf(TDeskTop)^);
    Load: @TDeskTop.Load;
    Store: @TDeskTop.Store);

implementation

{$ifdef FPK}
uses HistList;
{$else}
{$ifdef Windows}
uses WinProcs, VgaMem, ExtGraph, HistList, GvTexts, KeyNames;
{$else}
Uses GVDriver, MyMouse, MyFonts, Gr, Extgraph, VGAMem, HistList, GVTexts,
  KeyNames;
{$endif}
{$endif}

const

{ Private variables }

  Pending: TEvent = (What: evNothing);

{$ifdef Windows}
procedure DoPaint(View: pointer; var PS: TPaintStruct); {$ifndef FPK}far;{$endif}
begin
  If View <> nil
  then PGView(View)^.DrawVisible;
end;

procedure DoSystemMessage(View: pointer; var Event: TEvent); {$ifndef FPK}far;{$endif}
begin
  If View <> nil
  then PGView(View)^.HandleEvent(Event);
end;

procedure DoGetMCursor(n: Integer); {$ifndef FPK}far;{$endif}
const
  sysCursor: array[mcStd..mcLargeCross] of PChar
    = (IDC_ARROW, IDC_CROSS, IDC_WAIT, IDC_CROSS);
  gvCursor: array[mcInput..mcResizeHori] of PChar
    = (IDC_IBEAM, IDC_SIZE, IDC_SIZENWSE, IDC_SIZENESW,
       IDC_SIZENS, IDC_SIZEWE);
begin
  If n in [Low(sysCursor)..High(sysCursor)]
  then CursorHandle := LoadCursor(0, sysCursor[n]) else
  if n in [Low(gvCursor)..High(gvCursor)]
  then CursorHandle := LoadCursor(0, gvCursor[n]);
end;

{$else}

procedure DoChMCursor; {$ifndef FPK}far;{$endif}
Begin
  If MCurrent=mcNoCursor then Begin
    NewNum:=MCurStandard;
    If Application<>nil then Application^.ChMCursor;
  End
  Else NewNum:=MCurrent;
End;

{$endif}

{***************************** TDesktop object ******************************}

constructor TDeskTop.Init(var Bounds: TRect);
begin
  TGGroup.Init(Bounds);
  GrowMode := gfGrowHiX + gfGrowHiY;
  TileColumnsFirst := true;
  InitBackground;
  If Background <> nil then Insert (Background);
end;

constructor TDesktop.Load(var S: TStream);
Begin
  TGGroup.Load (S);
  GetSubViewPtr (S,Background);
  S.Read(TileColumnsFirst, SizeOf(TileColumnsFirst));
End;

function Tileable (P: PGView): Boolean;
begin
  Tileable := (P^.Options and ofTileable <> 0) and
    (P^.State and sfVisible <> 0);
end;

procedure TDeskTop.Cascade(var R: TRect);
var
  CascadeNum: Integer;
  LastView: PGView;
  Min, Max: TPoint;

 procedure DoCount(P: PGView); {$ifndef FPK}far;{$endif}
 begin
   if Tileable(P) then
   begin
     Inc(CascadeNum);
     LastView := P;
   end;
 end;

 procedure DoCascade(P: PGView); {$ifndef FPK}far;{$endif}
 var
   NR: TRect;
 begin
   if Tileable(P) and (CascadeNum >= 0) then
   begin
     NR.Copy(R);
     Inc(NR.A.X, CascadeNum*20); Inc(NR.A.Y, CascadeNum*20);
     P^.Locate(NR);
     Dec(CascadeNum);
   end;
 end;

begin
  CascadeNum := 0;
  ForEachInMethod(@DoCount, @Self);
  if CascadeNum > 0 then
  begin
    LastView^.SizeLimits(Min, Max);
    if (Min.X > R.B.X - R.A.X - (CascadeNum-1)*20) or
       (Min.Y > R.B.Y - R.A.Y - (CascadeNum-1)*20) then TileError
    else
    begin
      Dec(CascadeNum);
      Lock;
      ForEachInMethod(@DoCascade, @Self);
      Unlock;
    end;
  end;
end;

procedure TDeskTop.HandleEvent(var Event: TEvent);
begin
  TGGroup.HandleEvent(Event);
  if Event.What = evCommand then
  begin
    case Event.Command of
      cmNext: SelectNext(false);
      cmPrev: SelectNext(true);
    else
      Exit;
    end;
    ClearEvent(Event);
  end;
end;

procedure TDeskTop.InitBackground;
var
  R: TRect;
begin
  GetExtent(R);
  Background := New(PBackground, Init(R));
end;

procedure TDesktop.Store(var S: TStream);
Begin
  TGGroup.Store (S);
  PutSubViewPtr (S,BackGround);
  S.Write(TileColumnsFirst, SizeOf(TileColumnsFirst));
End;

{$ifdef FPK}
function ISqr(X: Integer): Integer;
begin
  ISqr := Trunc(Sqrt(Real(X)))
end;
{$else}
function ISqr(X: Integer): Integer; assembler;
asm
	MOV	CX,X
	MOV	BX,0
@@1:    INC     BX
	MOV	AX,BX
	IMUL	AX
	CMP	AX,CX
	JLE	@@1
	MOV	AX,BX
	DEC     AX
end;
{$endif}

procedure MostEqualDivisors(N: Integer; var X, Y: Integer; FavorY: Boolean);
var
  I: Integer;
begin
  I := ISqr(N);
  if ((N mod I) <> 0) then
    if (N mod (I+1)) = 0 then Inc(I);
  if I < (N div I) then I := N div I;
  if FavorY then
  begin
    X := N div I;
    Y := I;
  end
  else
  begin
    Y := N div I;
    X := I;
  end;
end;

procedure TDeskTop.Tile(var R: TRect);
var
  NumCols, NumRows, NumTileable, LeftOver, TileNum: Integer;

 procedure DoCountTileable(P: PGView); {$ifndef FPK}far;{$endif}
 begin
   if Tileable(P) then Inc(NumTileable);
 end;

 function DividerLoc(Lo, Hi, Num, Pos: Integer): Integer;
 begin
   DividerLoc := LongDiv(LongMul(Hi - Lo, Pos), Num) + Lo;
 end;

 procedure CalcTileRect(Pos: Integer; var NR: TRect);
 var
   X,Y,D: Integer;
 begin
   D := (NumCols - LeftOver) * NumRows;
   if Pos < D then
   begin
     X := Pos div NumRows;
     Y := Pos mod NumRows;
   end else
   begin
     X := (Pos - D) div (NumRows + 1) + (NumCols - LeftOver);
     Y := (Pos - D) mod (NumRows + 1);
   end;
   NR.A.X := DividerLoc(R.A.X, R.B.X, NumCols, X);
   NR.B.X := DividerLoc(R.A.X, R.B.X, NumCols, X+1);
   if Pos >= D then
   begin
     NR.A.Y := DividerLoc(R.A.Y, R.B.Y, NumRows+1, Y);
     NR.B.Y := DividerLoc(R.A.Y, R.B.Y, NumRows+1, Y+1);
   end else
   begin
     NR.A.Y := DividerLoc(R.A.Y, R.B.Y, NumRows, Y);
     NR.B.Y := DividerLoc(R.A.Y, R.B.Y, NumRows, Y+1);
   end;
 end;

 procedure DoTile(P: PGView); {$ifndef FPK}far;{$endif}
 var
   R: TRect;
 begin
   if Tileable(P) then
   begin
     CalcTileRect(TileNum, R);
     P^.Locate(R);
     Dec(TileNum);
   end;
 end;

begin
  NumTileable := 0;
  ForEachInMethod(@DoCountTileable, @Self);
  if NumTileable > 0 then
  begin
    MostEqualDivisors(NumTileable, NumCols, NumRows, not TileColumnsFirst);
    if ((R.B.X - R.A.X) div NumCols = 0) or
       ((R.B.Y - R.A.Y) div NumRows = 0) then TileError
    else
    begin
      LeftOver := NumTileable mod NumCols;
      TileNum := NumTileable-1;
      Lock;
      ForEachInMethod(@DoTile, @Self);
      Unlock;
    end;
  end;
end;

procedure TDesktop.TileError;
begin
end;

{*************************** TMainGroup object ******************************}

{$ifdef Windows}

constructor TMainGroup.Init(var Bounds: TRect; ATitle: string);
begin
  inherited Init(Bounds);
  Title := NewStr(ATitle)
end;

function TMainGroup.CreateRootWindow: Integer;
begin
  Wnd := CreateWindow(WindowClass, nil, ws_OverlappedWindow or ws_ClipSiblings or ws_ClipChildren,
    0, 0, 100, 100, 0, 0, hInstance, @Self);
  SetTimer(Wnd, 1, 50, nil);
  CreateRootWindow := sw_Show
end;

procedure TMainGroup.HandleEvent(var Event: TEvent);
begin
  if Event.What = evSystem then
    case PMSG(Event.InfoPtr)^.message of
      wm_Close:
	Begin
	  Event.What := evCommand;
	  Event.Command := cmQuit;
	  PutEvent(Event);
	  ClearEvent(Event);
	End;
    end;
  inherited HandleEvent(Event)
end;

procedure TMainGroup.SetTitle(ATitle: string);
begin
  If Title <> nil then DisposeStr(Title);
  Title := NewStr(ATitle);
  if Wnd <> 0 then UpdateWinTitle;
end;

procedure TMainGroup.SizeLimits(var Min, Max: TPoint);
begin
  TGView.SizeLimits(Min, Max);
  Min := MinMainSize;
End;

procedure TMainGroup.UpdateWinTitle;
var
  S: array[0..255] of Char;
begin
  If Title = nil
  then S[0] := #0
  else StrPCopy(S, Title^);
  SetWindowText(Wnd, S);
end;

{$endif Windows}

{***************************** TProgram object ******************************}

constructor TProgram.Init;
var
  R: TRect;
begin
  Application := @Self;
  ApplicationGroup := @Self;
  InitScreen;
  R.Assign(0, 0, SizeX, SizeY);
  inherited Init(R);
  State := sfVisible + sfSelected + sfFocused + sfExposed + sfModal;
  {$ifdef Windows}
  Options := Options or ofRooting;
  {$endif Windows}
  InitFonts;
  InitMain;
end;

destructor TProgram.Done;
begin
  DoneFonts;
  inherited Done;
  MenuBar := nil;
  StatusLine := nil;
  Desktop := nil;
  Application := nil;
  Main := nil;
  {$ifdef Windows}
  if Ctl3DModule <> 0
  then FreeLibrary(Ctl3DModule);
  {$endif Windows}
end;

function TProgram.CanMoveFocus: Boolean;
Begin
  CanMoveFocus := Desktop^.Valid(cmReleasedFocus);
End;

procedure TProgram.DoneEvents;
Begin
  {$ifndef FPK}
  {$ifndef Windows}
  GVDriver.DoneEvents;
  {$endif}
  {$endif}
End;

procedure TProgram.DoneFonts;
begin
  {$ifndef FPK}
  {$ifdef Windows}
  WinGr.DoneFonts
  {$else}
  GVDriver.DoneFonts
  {$endif}
  {$endif}
end;

procedure TProgram.DoneTexts;
Begin
  FreeTexts
End;

{$ifdef Windows}
procedure TProgram.EnableCtl3D;
var
  ctl3dRegister,
  ctl3dAutoSubClass: function(h: THandle): BOOL;
begin
  GvDialog.Use3DFrame := true;
  { If we are running Win4.0 or greater, then ctl3d is unnecessary. }
  if (WinProcs.GetVersion and $FF >= 3)
     and ((WinProcs.GetVersion shr 8) and $FF >= 95)
  then Exit;
  { Load the Ctl3d DLL and register our instance }
  Ctl3DModule := LoadLibrary('CTL3D.DLL');
  @ctl3dRegister := GetProcAddress(Ctl3DModule, 'Ctl3dRegister');
  if @ctl3dRegister <> nil
  then begin
    ctl3dRegister(hInstance);
    @ctl3dAutoSubclass := GetProcAddress(Ctl3DModule, 'Ctl3dAutoSubclass');
    {if @ctl3dAutoSubclass <> nil then ctl3dAutoSubclass(hInstance);}
  end
  else begin
    FreeLibrary(Ctl3DModule);
    Ctl3DModule := 0
  end;
end;
{$else !Windows}
procedure TProgram.EnableCtl3D;
begin
{$ifndef FPK}
  GvDialog.Use3DFrame := true;
{$endif FPK}
end;
{$endif Windows}

function TProgram.ExecuteDialog(P: PDialog; Data: Pointer): Word;
var C: Word;
Begin
  ExecuteDialog := cmCancel;
  If ValidView (P) <> nil then Begin
    If Data <> nil then P^.SetData (Data^);
    C := Desktop^.ExecView (P);
    If (C <> cmCancel) and (Data <> nil) then P^.GetData (Data^);
    Dispose (P, Done);
    ExecuteDialog := C;
  End;
End;

procedure TProgram.GetEvent(var Event: TEvent);

	function ContainsMouse(P: PView): Boolean; {$ifndef FPK}far;{$endif}
	begin
	  ContainsMouse := (P^.State and sfVisible <> 0) and
	    P^.MouseInView(Event.Where);
	end;

begin
  If Pending.What <> evNothing then
  begin
    Event := Pending;
    Pending.What := evNothing;
  end else
  begin
    GetMouseEvent(Event);
    {$ifdef MouseView}
      if (Event.What and evMouse <> 0)
      then begin
	Mouse^.HandleEvent(Event);
	{ FIXME: I shouldnt need to do this: }
	MouseWhere := Event.Where;
      end;
    {$endif MouseView}
    {$ifdef Windows}
    if Event.What <> evNothing
    then begin
      NewNum := -1;
      Application^.ChMCursor;
      If NewNum <> -1
      then SetMCursor(NewNum);
    end;
    {$else !Windows}
    {$ifdef AsyncMouse}
    If MouseInstalled
    then begin
      DoChMCursor;
      If NewNum <> CursorNum
      then begin
{$ifdef FPK}
	CursorNum := NewNum;
{$else}
	DoGetMCursor(NewNum);
	SetCursorPtr(CursorPtr)
{$endif}
      end
    end;
    {$endif AsyncMouse}
    {$endif !Windows}
    if Event.What = evNothing then
    begin
      GetKeyEvent(Event);
      if Event.What = evNothing then begin
	GetTimerEvent (Event);
	If Event.What = evTimer
	then begin
	  Timer(Event);
	  ClearEvent(Event)
	end
	else Idle;
      end;
    end
  end;
  if StatusLine <> nil then
    if (Event.What and evKeyDown <> 0) or
      (Event.What and evMouseDown <> 0) and
      (FirstThatInMethod(@ContainsMouse, @Self) = PGView(StatusLine)) then
      StatusLine^.HandleEvent(Event);
end;

function TProgram.GetPalette: PPalette;
const P: String[Length(CColor)] = CColor;
Begin
  GetPalette := @P;
End;

procedure TProgram.HandleEvent(var Event: TEvent);
begin
  TGGroup.HandleEvent(Event);
  if Event.What = evCommand then
    if Event.Command = cmQuit then
    begin
      EndModal(cmQuit);
      ClearEvent(Event);
    end;
end;

procedure TProgram.Idle;
begin
  If StatusLine <> nil then StatusLine^.Update;
  If CommandSetChanged then Begin
    Message(@Self, evBroadcast, cmCommandSetChanged, nil);
    CommandSetChanged := False;
  End;
  Message(@Self, evBroadCast, cmIdle, nil)
end;

procedure TProgram.InitDesktop;
var R: TRect;
Begin
  Main^.GetExtent (R);
  R.Grow (0,-21);
  Desktop:=New (PDesktop,Init (R));
End;

procedure TProgram.InitEvents;
Begin
  {$ifdef FPK}
  Drivers.InitEvents;
  {$else}
  {$ifdef Windows}
  WinGr.GetMCursor:=DoGetMCursor;
  {$else}
  GVDriver.InitEvents;
  SaveGetMC:=MyMouse.GetMCursor;
  MyMouse.GetMCursor:=DoGetMCursor;
  {$ifndef AsyncMouse}
  ChangeCursor:=DoChMCursor;
  {$endif AsyncMouse}
  {$endif Windows}
  {$endif FPK}
End;

procedure TProgram.InitFonts;
begin
  {$ifdef FPK}
  Bgi.InitFonts;
  {$else}
  {$ifdef Windows}
  WinGr.InitFonts;
  {$else}
  GvDriver.InitFonts
  {$endif}
  {$endif}
end;

procedure TProgram.InitMain;
var
  R: TRect;
begin
  {$ifdef Windows}
  GetExtent(R);
  R.Grow(-50, -50);
  Main := New(PMainGroup, Init(R, ParamStr(0)));
  Main^.SetState(sfRoot, true);
  Application^.Insert(Main);
  {$else !Windows}
  Main := Application;
  {$endif !Windows}
  {$ifdef MouseView}
  R.Assign(-32, -48, 0, 0);
  Mouse := PGView(Application^.Insert(New(PMouse, Init(R))));
  {$endif MouseView}
  InitDesktop;
  InitMenuBar;
  InitStatusLine;
  If Desktop <> nil then Main^.Insert(Desktop);
  If MenuBar <> nil then Main^.Insert(MenuBar);
  If StatusLine <> nil then Main^.Insert(StatusLine);
end;

procedure TProgram.InitMenuBar;
var
  R: TRect;
begin
  Main^.GetExtent(R);
  R.B.Y := R.A.Y + 21;
  MenuBar := New(PMenuBar, Init(R, NewMenu(nil)));
end;

procedure TProgram.InitScreen;
Begin
{$ifdef Windows}
  SizeX := GetSystemMetrics(sm_cxscreen);
  SizeY := GetSystemMetrics(sm_cyscreen);
{$endif Windows}
End;

procedure TProgram.InitStatusLine;
Var R: TRect;
Begin
  Main^.GetExtent(R);
  R.A.Y := R.B.Y - 21;
  StatusLine := New(PStatusLine, Init(R,
    NewStatusDef(0, $FFFF,
      NewStatusKey('~Alt+X~ Exit', kbAltX, cmQuit,
      NewStatusKey('', kbF10, cmMenu, nil)), nil)));
End;

procedure TProgram.InitTexts;
var
  Path: PathStr;
  Dir: DirStr;
  Name: NameStr;
  Ext: ExtStr;
Begin
  Path := LanguageResource;
{$ifdef FPK}
  { FPC resources are not binary compatible -- use different name }
  FSplit(Path, Dir, Name, Ext);
  Ext := '.gvf';
  Path := Dir + Name + Ext;
{$endif}
  FSplit(ParamStr(0), Dir, Name, Ext);
  Path := FSearch(Path, Dir + ';' + GetEnv('PATH'));
  LoadTexts(Path)
End;

function TProgram.InsertWindow(P: PWindow): PWindow;
Begin
  InsertWindow := nil;
  If ValidView(P) <> nil then
    If CanMoveFocus then Begin
      Desktop^.Insert(P);
      InsertWindow := P;
    End
    Else Dispose(P, Done);
End;

function TProgram.LanguageResource: string;
begin
  case Language of
    lfGerman:
      LanguageResource := 'german.gvl';
    else
      LanguageResource := 'english.gvl';
  end;
end;

procedure TProgram.OutOfMemory;
begin
end;

procedure TProgram.PutEvent(var Event: TEvent);
begin
  Pending := Event
end;

procedure TProgram.Run;
begin
  Execute;
end;

procedure TProgram.SetScreenMode(Mode: Word);
var
  R: TRect;
begin
  {$ifndef FPK}
  {$ifndef Windows}
  GvDriver.SetScreenMode(Mode);
  R.Assign(0, 0, SizeX, SizeY);
  ChangeBounds(R)
  {$endif}
  {$endif FPK}
end;

procedure TProgram.Timer(var Event: TEvent);
begin
  HandleEvent(Event)
end;

function TProgram.ValidView(P: PGView): PGView;
begin
  ValidView := nil;
  if P <> nil then
  begin
    if LowMemory then
    begin
      Dispose(P, Done);
      OutOfMemory;
      Exit;
    end;
    if not P^.Valid(cmValid) then
    begin
      Dispose(P, Done);
      Exit;
    end;
    ValidView := P;
  end;
end;

{****************************** TApplication object *************************}

constructor TApplication.Init;
begin
  InitMemory;
  InitEvents;
  InitTexts;
  InitVideo;
  {$ifndef LINUX}
  InitSysError;
  {$endif}
  {$ifndef FPK}
  InitVgaMem;
  {$ifndef Windows}
  InitMyFonts;
  {$endif}
  {$endif}
  InitHistory;
  TProgram.Init;
  {$ifdef Windows}
  Paint := DoPaint;
  SystemMessage := DoSystemMessage;
  {$endif}
end;

destructor TApplication.Done;
begin
  {$ifdef Windows}
  Paint := NoPaint;
  SystemMessage := NoSystemMessage;
  {$endif}
  TProgram.Done;
  DoneHistory;
  {$ifndef FPK}
  {$ifndef Windows}
  DoneMyFonts;
  {$endif}
  DoneVgaMem;
  {$endif}
  {$ifndef LINUX}
  DoneSysError;
  {$endif}
  DoneVideo;
  DoneTexts;
  DoneEvents;
  DoneMemory;
end;

procedure TApplication.Cascade;
var R: TRect;
Begin
  GetTileRect(R);
  If Desktop <> nil then Desktop^.Cascade(R);
End;

procedure TApplication.DosShell;
Begin
  {$ifndef FPK}
  {$ifndef Windows}
  DoneSysError;
  DoneVideo;
  DoneEvents;
  DoneDosMem;
  WriteShellMsg;
  SwapVectors;
  Exec(GetEnv('COMSPEC'), '');
  SwapVectors;
  InitDosMem;
  InitEvents;
  InitVideo;
  InitSysError;
  Redraw;
  {$endif Windows}
  {$endif FPK}
End;

procedure TApplication.GetTileRect(var R: TRect);
Begin
  Desktop^.GetExtent(R);
End;

procedure TApplication.HandleEvent(var Event: TEvent);
Begin
  TProgram.HandleEvent(Event);
  If Event.What = evCommand then Begin
    Case Event.Command of
      cmTile: Tile;
      cmAltTile:
	begin
	  if Desktop <> nil
	  then begin
	    Desktop^.TileColumnsFirst := false;
	    Tile;
	    Desktop^.TileColumnsFirst := true
	  end
	end;
      cmCascade: Cascade;
      cmDosShell: DosShell;
     else Exit;
    End;
    ClearEvent(Event);
  End;
End;

procedure TApplication.Tile;
var R: TRect;
Begin
  GetTileRect(R);
  If Desktop <> nil then Desktop^.Tile(R);
End;

procedure TApplication.WriteShellMsg;
Begin
  PrintStr(GetStr(34));
End;

{******************** Standard menus and status lines ***********************}

function StdStatusKeys(Next: PStatusItem): PStatusItem;
Begin
  StdStatusKeys :=
    NewStatusKey('', kbAltX, cmQuit,
    NewStatusKey('', kbF10, cmMenu,
    NewStatusKey('', kbAltF3, cmClose,
    NewStatusKey('', kbF5, cmZoom,
    NewStatusKey('', kbCtrlF5, cmResize,
    NewStatusKey('', kbF6, cmNext,
    NewStatusKey('', kbShiftF6, cmPrev,
    Next)))))));
End;

function StdDraggingStatusDef(Next: PStatusDef): PStatusDef;
begin
  StdDraggingStatusDef :=
    NewStatusDef(hcDragging, hcDragging,
      NewStatusKey('~' + GetStr(sCursorKeys) + '~ ' + GetStr(142),
        kbNoKey, cmError,
      NewStatusKey('~' + GetStr(sShiftModifier) + GetStr(sComposeKeys)
        + GetStr(sCursorKeys) + '~ ' + GetStr(143),
        kbNoKey, cmError,
      NewStatusKey('~' + GetStr(sEnterKey) + '~ ' + GetStr(144),
        kbNoKey, cmError,
      NewStatusKey('~' + GetStr(sEscapeKey) + '~ ' + GetStr(145),
        kbNoKey, cmError,
      nil)))), Next)
end;

{ A little helper function. The menu item name is taken from the
  string resource. The key name (if any) is created by NewItemKN.
}
function NewItemX(Num: Word; Key: Word;
  Command: Word; Next: PMenuItem): PMenuItem;
begin
  NewItemX := NewItem(GetStr(Num), kn(Key), Key, Command, hc + Command, Next)
end;

function StdFileMenuItems(Next: PMenuItem): PMenuItem;
Begin
  StdFileMenuItems :=
    NewItemX(35, kbNoKey, cmNew,
    NewItemX(36, kbF3, cmOpen,
    NewItemX(37, kbF2, cmSave,
    NewItemX(38, kbNoKey, cmSaveAs,
    NewItemX(39, kbNoKey, cmSaveAll,
    NewLine(
    NewItemX(40, kbNoKey, cmChangeDir,
    NewItemX(41, kbNoKey, cmDosShell,
    NewItemX(42, kbAltX, cmQuit,
    Next)))))))));
End;

function StdEditMenuItems(Next: PMenuItem): PMenuItem;
const
      {$IFDEF Ver60}
      Key = kbCtrlBack;
      {$ELSE}
      Key = kbAltBack;
      {$ENDIF}
Begin
  StdEditMenuItems :=
    NewItemX(43, Key, cmUndo,
    NewLine(
    NewItemX(44, kbShiftDel, cmCut,
    NewItemX(45, kbCtrlIns, cmCopy,
    NewItemX(46, kbShiftIns, cmPaste,
    NewItemX(47, kbCtrlDel, cmClear,
    Next))))));
End;

function StdWindowMenuItems(Next: PMenuItem): PMenuItem;
Begin
  StdWindowMenuItems :=
    NewItemX(51, kbNoKey, cmAltTile,
    NewItemX(52, kbNoKey, cmTile,
    NewItemX(53, kbNoKey, cmCascade,
    NewItemX(54, kbNoKey, cmCloseAll,
    NewLine(
    NewItemX(55, kbCtrlF5, cmResize,
    NewItemX(56, kbF5, cmZoom,
    NewItemX(57, kbF6, cmNext,
    NewItemX(58, kbShiftF6, cmPrev,
    NewItemX(59, kbAltF3, cmClose,
    Next))))))))));
End;

{************************ GVApp registration procedure **********************}

procedure RegisterGVApp;
Begin
  RegisterType (RDesktop);
End;

end.
