freepascal.compiler/fv/app.pas

{ $Id$}
{********[ SOURCE FILE OF GRAPHICAL FREE VISION ]**********}
{                                                          }
{   System independent GRAPHICAL clone of APP.PAS          }
{                                                          }
{   Interface Copyright (c) 1992 Borland International     }
{                                                          }
{   Copyright (c) 1996, 1997, 1998, 1999 by Leon de Boer   }
{   [email protected]  - primary e-mail addr           }
{   [email protected] - backup e-mail addr            }
{                                                          }
{****************[ THIS CODE IS FREEWARE ]*****************}
{                                                          }
{     This sourcecode is released for the purpose to       }
{   promote the pascal language on all platforms. You may  }
{   redistribute it and/or modify with the following       }
{   DISCLAIMER.                                            }
{                                                          }
{     This SOURCE CODE is distributed "AS IS" WITHOUT      }
{   WARRANTIES AS TO PERFORMANCE OF MERCHANTABILITY OR     }
{   ANY OTHER WARRANTIES WHETHER EXPRESSED OR IMPLIED.     }
{                                                          }
{*****************[ SUPPORTED PLATFORMS ]******************}
{     16 and 32 Bit compilers                              }
{        DOS      - Turbo Pascal 7.0 +      (16 Bit)       }
{        DPMI     - Turbo Pascal 7.0 +      (16 Bit)       }
{                 - FPC 0.9912+ (GO32V2)    (32 Bit)       }
{        WINDOWS  - Turbo Pascal 7.0 +      (16 Bit)       }
{                 - Delphi 1.0+             (16 Bit)       }
{        WIN95/NT - Delphi 2.0+             (32 Bit)       }
{                 - Virtual Pascal 2.0+     (32 Bit)       }
{                 - FPC 0.9912+             (32 Bit)       }
{        OS2      - Virtual Pascal 1.0+     (32 Bit)       }
{                                                          }
{******************[ REVISION HISTORY ]********************}
{  Version  Date        Fix                                }
{  -------  ---------   ---------------------------------  }
{  1.00     12 Dec 96   First multi platform release       }
{  1.10     12 Sep 97   FPK pascal 0.92 conversion added.  }
{  1.20     29 Aug 97   Platform.inc sort added.           }
{  1.30     05 May 98   Virtual pascal 2.0 code added.     }
{  1.40     22 Oct 99   Object registration added.         }
{  1.50     22 Oct 99   Complete recheck preformed         }
{  1.51     03 Nov 99   FPC Windows support added          }
{  1.60     26 Nov 99   Graphics stuff moved to GFVGraph   }
{**********************************************************}

UNIT App;

{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
                                  INTERFACE
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}

{====Include file to sort compiler platform out =====================}
{$I Platform.inc}
{====================================================================}

{==== Compiler directives ===========================================}

{$IFNDEF PPC_FPC}{ FPC doesn't support these switches }
  {$F-} { Near calls are okay }
  {$A+} { Word Align Data }
  {$B-} { Allow short circuit boolean evaluations }
  {$O+} { This unit may be overlaid }
  {$G+} { 286 Code optimization - if you're on an 8088 get a real computer }
  {$P-} { Normal string variables }
  {$N-} { No 80x87 code generation }
  {$E+} { Emulation is on }
{$ENDIF}

{$X+} { Extended syntax is ok }
{$R-} { Disable range checking }
{$S-} { Disable Stack Checking }
{$I-} { Disable IO Checking }
{$Q-} { Disable Overflow Checking }
{$V-} { Turn off strict VAR strings }
{====================================================================}

USES
   {$IFDEF OS_WINDOWS}                                { WIN/NT CODE }
     {$IFNDEF PPC_SPEED}                              { NON SPEED COMPILER }
       {$IFDEF PPC_FPC}                               { FPC WINDOWS COMPILER }
       Windows,                                       { Standard units }
       {$ELSE}                                        { OTHER COMPILERS }
       WinTypes,WinProcs,                             { Standard units }
       {$ENDIF}
       {$IFNDEF PPC_DELPHI}                           { NON DELPHI1 COMPILER }
         {$IFDEF BIT_16} Win31, {$ENDIF}              { 16 BIT WIN 3.1 UNIT }
       {$ENDIF}
     {$ELSE}                                          { SPEEDSOFT COMPILER }
       WinBase, WinDef,                               { Standard units }
     {$ENDIF}
     {$IFDEF PPC_DELPHI}                              { DELPHI COMPILERS }
       Messages,                                      { Standard unit }
     {$ENDIF}
   {$ENDIF}

   {$IFDEF OS_OS2}                                    { OS2 CODE }
     Os2Def, Os2Base, OS2PmApi,                       { Standard units }
   {$ENDIF}

   GFVGraph,                                          { GFV standard unit }
   Common, Memory,                                    { GFV standard units }
   Objects, Drivers, Views, Menus, HistList, Dialogs; { GFV standard units }

{***************************************************************************}
{                              PUBLIC CONSTANTS                             }
{***************************************************************************}

{---------------------------------------------------------------------------}
{                  STANDARD APPLICATION COMMAND CONSTANTS                   }
{---------------------------------------------------------------------------}
CONST
   cmNew       = 30;                                  { Open new file }
   cmOpen      = 31;                                  { Open a file }
   cmSave      = 32;                                  { Save current }
   cmSaveAs    = 33;                                  { Save current as }
   cmSaveAll   = 34;                                  { Save all files }
   cmChangeDir = 35;                                  { Change directories }
   cmDosShell  = 36;                                  { Dos shell }
   cmCloseAll  = 37;                                  { Close all windows }

{---------------------------------------------------------------------------}
{                       TApplication PALETTE ENTRIES                        }
{---------------------------------------------------------------------------}
CONST
   apColor      = 0;                                  { Coloured app }
   apBlackWhite = 1;                                  { B&W application }
   apMonochrome = 2;                                  { Monochrome app }

{---------------------------------------------------------------------------}
{                           TBackGround PALETTES                            }
{---------------------------------------------------------------------------}
CONST
   CBackground = #1;                                  { Background colour }

{---------------------------------------------------------------------------}
{                           TApplication PALETTES                           }
{---------------------------------------------------------------------------}
CONST
  { Turbo Vision 1.0 Color Palettes }

   CColor =
         #$81#$70#$78#$74#$20#$28#$24#$17#$1F#$1A#$31#$31#$1E#$71#$1F +
     #$37#$3F#$3A#$13#$13#$3E#$21#$3F#$70#$7F#$7A#$13#$13#$70#$7F#$7E +
     #$70#$7F#$7A#$13#$13#$70#$70#$7F#$7E#$20#$2B#$2F#$78#$2E#$70#$30 +
     #$3F#$3E#$1F#$2F#$1A#$20#$72#$31#$31#$30#$2F#$3E#$31#$13#$38#$00;

   CBlackWhite =
         #$70#$70#$78#$7F#$07#$07#$0F#$07#$0F#$07#$70#$70#$07#$70#$0F +
     #$07#$0F#$07#$70#$70#$07#$70#$0F#$70#$7F#$7F#$70#$07#$70#$07#$0F +
     #$70#$7F#$7F#$70#$07#$70#$70#$7F#$7F#$07#$0F#$0F#$78#$0F#$78#$07 +
     #$0F#$0F#$0F#$70#$0F#$07#$70#$70#$70#$07#$70#$0F#$07#$07#$78#$00;

   CMonochrome =
         #$70#$07#$07#$0F#$70#$70#$70#$07#$0F#$07#$70#$70#$07#$70#$00 +
     #$07#$0F#$07#$70#$70#$07#$70#$00#$70#$70#$70#$07#$07#$70#$07#$00 +
     #$70#$70#$70#$07#$07#$70#$70#$70#$0F#$07#$07#$0F#$70#$0F#$70#$07 +
     #$0F#$0F#$07#$70#$07#$07#$70#$07#$07#$07#$70#$0F#$07#$07#$70#$00;

   { Turbo Vision 2.0 Color Palettes }

   CAppColor =
         {$IFDEF OS_WINDOWS}#$81+{$ELSE}#$71+{$ENDIF}
         #$70#$78#$74#$20#$28#$24#$17#$1F#$1A#$31#$31#$1E#$71#$1F +
     #$37#$3F#$3A#$13#$13#$3E#$21#$3F#$70#$7F#$7A#$13#$13#$70#$7F#$7E +
     #$70#$7F#$7A#$13#$13#$70#$70#$7F#$7E#$20#$2B#$2F#$78#$2E#$70#$30 +
     #$3F#$3E#$1F#$2F#$1A#$20#$72#$31#$31#$30#$2F#$3E#$31#$13#$38#$00 +
     #$17#$1F#$1A#$71#$71#$1E#$17#$1F#$1E#$20#$2B#$2F#$78#$2E#$10#$30 +
     #$3F#$3E#$70#$2F#$7A#$20#$12#$31#$31#$30#$2F#$3E#$31#$13#$38#$00 +
     #$37#$3F#$3A#$13#$13#$3E#$30#$3F#$3E#$20#$2B#$2F#$78#$2E#$30#$70 +
     #$7F#$7E#$1F#$2F#$1A#$20#$32#$31#$71#$70#$2F#$7E#$71#$13#$38#$00;

   CAppBlackWhite =
         #$70#$70#$78#$7F#$07#$07#$0F#$07#$0F#$07#$70#$70#$07#$70#$0F +
     #$07#$0F#$07#$70#$70#$07#$70#$0F#$70#$7F#$7F#$70#$07#$70#$07#$0F +
     #$70#$7F#$7F#$70#$07#$70#$70#$7F#$7F#$07#$0F#$0F#$78#$0F#$78#$07 +
     #$0F#$0F#$0F#$70#$0F#$07#$70#$70#$70#$07#$70#$0F#$07#$07#$78#$00 +
     #$07#$0F#$0F#$07#$70#$07#$07#$0F#$0F#$70#$78#$7F#$08#$7F#$08#$70 +
     #$7F#$7F#$7F#$0F#$70#$70#$07#$70#$70#$70#$07#$7F#$70#$07#$78#$00 +
     #$70#$7F#$7F#$70#$07#$70#$70#$7F#$7F#$07#$0F#$0F#$78#$0F#$78#$07 +
     #$0F#$0F#$0F#$70#$0F#$07#$70#$70#$70#$07#$70#$0F#$07#$07#$78#$00;

   CAppMonochrome =
         #$70#$07#$07#$0F#$70#$70#$70#$07#$0F#$07#$70#$70#$07#$70#$00 +
     #$07#$0F#$07#$70#$70#$07#$70#$00#$70#$70#$70#$07#$07#$70#$07#$00 +
     #$70#$70#$70#$07#$07#$70#$70#$70#$0F#$07#$07#$0F#$70#$0F#$70#$07 +
     #$0F#$0F#$07#$70#$07#$07#$70#$07#$07#$07#$70#$0F#$07#$07#$70#$00 +
     #$70#$70#$70#$07#$07#$70#$70#$70#$0F#$07#$07#$0F#$70#$0F#$70#$07 +
     #$0F#$0F#$07#$70#$07#$07#$70#$07#$07#$07#$70#$0F#$07#$07#$70#$00 +
     #$70#$70#$70#$07#$07#$70#$70#$70#$0F#$07#$07#$0F#$70#$0F#$70#$07 +
     #$0F#$0F#$07#$70#$07#$07#$70#$07#$07#$07#$70#$0F#$07#$07#$70#$00;

{---------------------------------------------------------------------------}
{                     STANDRARD HELP CONTEXT CONSTANTS                      }
{---------------------------------------------------------------------------}
CONST
{ Note: range $FF00 - $FFFF of help contexts are reserved by Borland }
   hcNew       = $FF01;                               { New file help }
   hcOpen      = $FF02;                               { Open file help }
   hcSave      = $FF03;                               { Save file help }
   hcSaveAs    = $FF04;                               { Save file as help }
   hcSaveAll   = $FF05;                               { Save all files help }
   hcChangeDir = $FF06;                               { Change dir help }
   hcDosShell  = $FF07;                               { Dos shell help }
   hcExit      = $FF08;                               { Exit program help }

   hcUndo      = $FF10;                               { Clipboard undo help }
   hcCut       = $FF11;                               { Clipboard cut help }
   hcCopy      = $FF12;                               { Clipboard copy help }
   hcPaste     = $FF13;                               { Clipboard paste help }
   hcClear     = $FF14;                               { Clipboard clear help }

   hcTile      = $FF20;                               { Desktop tile help }
   hcCascade   = $FF21;                               { Desktop cascade help }
   hcCloseAll  = $FF22;                               { Desktop close all }
   hcResize    = $FF23;                               { Window resize help }
   hcZoom      = $FF24;                               { Window zoom help }
   hcNext      = $FF25;                               { Window next help }
   hcPrev      = $FF26;                               { Window previous help }
   hcClose     = $FF27;                               { Window close help }

{***************************************************************************}
{                        PUBLIC OBJECT DEFINITIONS                          }
{***************************************************************************}

{---------------------------------------------------------------------------}
{                  TBackGround OBJECT - BACKGROUND OBJECT                   }
{---------------------------------------------------------------------------}
TYPE
   TBackGround = OBJECT (TView)
         Pattern: Char;                               { Background pattern }
      CONSTRUCTOR Init (Var Bounds: TRect; APattern: Char);
      CONSTRUCTOR Load (Var S: TStream);
      FUNCTION GetPalette: PPalette; Virtual;
      PROCEDURE DrawBackGround; Virtual;
      PROCEDURE Store (Var S: TStream);
   END;
   PBackGround = ^TBackGround;

{---------------------------------------------------------------------------}
{                     TDeskTop OBJECT - DESKTOP OBJECT                      }
{---------------------------------------------------------------------------}
TYPE
   TDeskTop = OBJECT (TGroup)
         Background      : PBackground;               { Background view }
         TileColumnsFirst: Boolean;                   { Tile direction }
      CONSTRUCTOR Init (Var Bounds: TRect);
      CONSTRUCTOR Load (Var S: TStream);
      PROCEDURE TileError; Virtual;
      PROCEDURE InitBackGround; Virtual;
      PROCEDURE Tile (Var R: TRect);
      PROCEDURE Store (Var S: TStream);
      PROCEDURE Cascade (Var R: TRect);
      PROCEDURE HandleEvent (Var Event: TEvent); Virtual;
   END;
   PDeskTop = ^TDeskTop;

{---------------------------------------------------------------------------}
{                  TProgram OBJECT - PROGRAM ANCESTOR OBJECT                }
{---------------------------------------------------------------------------}
TYPE
   TProgram = OBJECT (TGroup)
      CONSTRUCTOR Init;
      DESTRUCTOR Done; Virtual;
      FUNCTION GetPalette: PPalette; Virtual;
      FUNCTION CanMoveFocus: Boolean;
      FUNCTION ValidView (P: PView): PView;
      FUNCTION InsertWindow (P: PWindow): PWindow;
      FUNCTION ExecuteDialog (P: PDialog; Data: Pointer): Word;
      PROCEDURE Run; Virtual;
      PROCEDURE Idle; Virtual;
      PROCEDURE InitScreen; Virtual;
      PROCEDURE InitDeskTop; Virtual;
      PROCEDURE OutOfMemory; Virtual;
      PROCEDURE InitMenuBar; Virtual;
      PROCEDURE InitStatusLine; Virtual;
      PROCEDURE SetScreenMode (Mode: Word);
      PROCEDURE PutEvent (Var Event: TEvent); Virtual;
      PROCEDURE GetEvent (Var Event: TEvent); Virtual;
      PROCEDURE HandleEvent (Var Event: TEvent); Virtual;
      {$IFNDEF OS_DOS}                                { WIN/NT/OS2 CODE }
      FUNCTION GetClassName: String; Virtual;
      FUNCTION GetClassText: String; Virtual;
      FUNCTION GetClassAttr: LongInt; Virtual;
      FUNCTION GetMsgHandler: Pointer; Virtual;
      {$ENDIF}
   END;
   PProgram = ^TProgram;

{---------------------------------------------------------------------------}
{                  TApplication OBJECT - APPLICATION OBJECT                 }
{---------------------------------------------------------------------------}
TYPE
   TApplication = OBJECT (TProgram)
      CONSTRUCTOR Init;
      DESTRUCTOR Done; Virtual;
      PROCEDURE Tile;
      PROCEDURE Cascade;
      PROCEDURE DosShell;
      PROCEDURE GetTileRect (Var R: TRect); Virtual;
      PROCEDURE HandleEvent (Var Event: TEvent); Virtual;
   END;
   PApplication = ^TApplication;                      { Application ptr }

{***************************************************************************}
{                            INTERFACE ROUTINES                             }
{***************************************************************************}

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                STANDARD MENU AND STATUS LINES ROUTINES                    }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

{-StdStatusKeys------------------------------------------------------
Returns a pointer to a linked list of commonly used status line keys.
The default status line for TApplication uses StdStatusKeys as its
complete list of status keys.
22Oct99 LdB
---------------------------------------------------------------------}
FUNCTION StdStatusKeys (Next: PStatusItem): PStatusItem;

{-StdFileMenuItems---------------------------------------------------
Returns a pointer to a list of menu items for a standard File menu.
The standard File menu items are New, Open, Save, Save As, Save All,
Change Dir, OS Shell, and Exit.
22Oct99 LdB
---------------------------------------------------------------------}
FUNCTION StdFileMenuItems (Next: PMenuItem): PMenuItem;

{-StdEditMenuItems---------------------------------------------------
Returns a pointer to a list of menu items for a standard Edit menu.
The standard Edit menu items are Undo, Cut, Copy, Paste, and Clear.
22Oct99 LdB
---------------------------------------------------------------------}
FUNCTION StdEditMenuItems (Next: PMenuItem): PMenuItem;

{-StdWindowMenuItems-------------------------------------------------
Returns a pointer to a list of menu items for a standard Window menu.
The standard Window menu items are Tile, Cascade, Close All,
Size/Move, Zoom, Next, Previous, and Close.
22Oct99 LdB
---------------------------------------------------------------------}
FUNCTION StdWindowMenuItems (Next: PMenuItem): PMenuItem;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                           OBJECT REGISTER ROUTINES                        }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{-RegisterApp--------------------------------------------------------
Calls RegisterType for each of the object types defined in this unit.
22oct99 LdB
---------------------------------------------------------------------}
PROCEDURE RegisterApp;

{***************************************************************************}
{                           OBJECT REGISTRATION                             }
{***************************************************************************}

{---------------------------------------------------------------------------}
{                      TBackGround STREAM REGISTRATION                      }
{---------------------------------------------------------------------------}
CONST
  RBackGround: TStreamRec = (
     ObjType: 30;                                     { Register id = 30 }
     {$IFDEF BP_VMTLink}                              { BP style VMT link }
     VmtLink: Ofs(TypeOf(TBackGround)^);
     {$ELSE}                                          { Alt style VMT link }
     VmtLink: TypeOf(TBackGround);
     {$ENDIF}
     Load:    @TBackGround.Load;                      { Object load method }
     Store:   @TBackGround.Store                      { Object store method }
  );

{---------------------------------------------------------------------------}
{                       TDeskTop STREAM REGISTRATION                        }
{---------------------------------------------------------------------------}
CONST
  RDeskTop: TStreamRec = (
     ObjType: 31;                                     { Register id = 31 }
     {$IFDEF BP_VMTLink}                              { BP style VMT link }
     VmtLink: Ofs(TypeOf(TDeskTop)^);
     {$ELSE}                                          { Alt style VMT link }
     VmtLink: TypeOf(TDeskTop);
     {$ENDIF}
     Load:    @TDeskTop.Load;                         { Object load method }
     Store:   @TDeskTop.Store                         { Object store method }
  );

{***************************************************************************}
{                        INITIALIZED PUBLIC VARIABLES                       }
{***************************************************************************}

{---------------------------------------------------------------------------}
{                       INITIALIZED PUBLIC VARIABLES                        }
{---------------------------------------------------------------------------}
CONST
   AppPalette: Integer = apColor;                     { Application colour }
   Desktop: PDeskTop = Nil;                           { Desktop object }
   MenuBar: PMenuView = Nil;                          { Application menu }
   StatusLine: PStatusLine = Nil;                     { App status line }
   Application : PApplication = Nil;                  { Application object }

{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
                                IMPLEMENTATION
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}

{$ifdef Use_API}
  uses
    Video,Mouse;
{$endif Use_API}

{***************************************************************************}
{                        PRIVATE DEFINED CONSTANTS                          }
{***************************************************************************}

{***************************************************************************}
{                      PRIVATE INITIALIZED VARIABLES                        }
{***************************************************************************}

{---------------------------------------------------------------------------}
{                      INITIALIZED PRIVATE VARIABLES                        }
{---------------------------------------------------------------------------}
CONST Pending: TEvent = (What: evNothing);            { Pending event }

{***************************************************************************}
{                        PRIVATE INTERNAL ROUTINES                          }
{***************************************************************************}
{$IFDEF OS_WINDOWS}
{---------------------------------------------------------------------------}
{  AppMsgHandler -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 13May98 LdB     }
{---------------------------------------------------------------------------}
FUNCTION TvAppMsgHandler (Wnd: hWnd; iMessage, wParam: Sw_Word;
lParam: LongInt): LongInt; {$IFDEF BIT_16} EXPORT; {$ELSE} STDCALL; {$ENDIF}
VAR Event: TEvent; P: PView; Mm: ^TMinMaxInfo;
BEGIN
   {$IFDEF BIT_16}                                    { 16 BIT CODE }
   PtrRec(P).Seg := GetProp(Wnd, ViewSeg);            { Fetch seg property }
   PtrRec(P).Ofs := GetProp(Wnd, ViewOfs);            { Fetch ofs property }
   {$ENDIF}
   {$IFDEF BIT_32}                                    { 32 BIT CODE }
   LongInt(P) := GetProp(Wnd, ViewPtr);               { Fetch view property }
   {$ENDIF}
   TvAppMsgHandler := 0;                              { Preset zero return }
   Event.What := evNothing;                           { Preset no event }
   Case iMessage Of
     WM_Destroy:;                                     { Destroy window }
     WM_Close: Begin
       Event.What := evCommand;                       { Command event }
       Event.Command := cmQuit;                       { Quit command }
       Event.InfoPtr := Nil;                          { Clear info ptr }
     End;
     WM_GetMinMaxInfo: Begin                          { Get minmax info }
       TvAppMsgHandler := DefWindowProc(Wnd,
         iMessage, wParam, lParam);                   { Default handler }
       Mm := Pointer(lParam);                         { Create pointer }
       Mm^.ptMaxSize.X := SysScreenWidth;             { Max x size }
       Mm^.ptMaxSize.Y := SysScreenHeight;            { Max y size }
       Mm^.ptMinTrackSize.X := MinWinSize.X *
         SysFontWidth;                                { Drag min x size }
       Mm^.ptMinTrackSize.Y := MinWinSize.Y *
         SysFontHeight;                               { Drag min y size }
       Mm^.ptMaxTrackSize.X := SysScreenWidth;        { Drag max x size }
       Mm^.ptMaxTrackSize.Y := SysScreenHeight;       { Drag max y size }
     End;
     Else Begin                                       { Unhandled message }
       TvAppMsgHandler := DefWindowProc(Wnd,
         iMessage, wParam, lParam);                   { Default handler }
       Exit;                                          { Now exit }
     End;
   End;
   If (Event.What <> evNothing) Then                  { Check any FV event }
     PutEventInQueue(Event);                          { Put event in queue }
END;
{$ENDIF}
{$IFDEF OS_OS2}                                       { OS2 CODE }
FUNCTION TvAppMsgHandler(Wnd: HWnd; Msg: ULong; Mp1, Mp2: MParam): MResult; CDECL;
VAR Event: TEvent; P: PView;
BEGIN
   Event.What := evNothing;                           { Preset no event }
   TvAppMsgHandler := 0;                              { Preset zero return }
   Case Msg Of
     WM_Destroy:;                                     { Destroy window }
     WM_Close: Begin
       Event.What := evCommand;                       { Command event }
       Event.Command := cmQuit;                       { Quit command }
       Event.InfoPtr := Nil;                          { Clear info ptr }
     End;
     Else Begin                                       { Unhandled message }
       TvAppMsgHandler := WinDefWindowProc(Wnd,
         Msg, Mp1, Mp2);                              { Call std handler }
       Exit;                                          { Now exit }
     End;
   End;
   If (Event.What <> evNothing) Then                  { Check any FV event }
     PutEventInQueue(Event);                          { Put event in queue }
END;
{$ENDIF}

{---------------------------------------------------------------------------}
{  Tileable -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB          }
{---------------------------------------------------------------------------}
FUNCTION Tileable (P: PView): Boolean;
BEGIN
   Tileable := (P^.Options AND ofTileable <> 0) AND   { View is tileable }
     (P^.State AND sfVisible <> 0);                   { View is visible }
END;

{---------------------------------------------------------------------------}
{  ISqr -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB              }
{---------------------------------------------------------------------------}
FUNCTION ISqr (X: Sw_Integer): Sw_Integer;
VAR I: Sw_Integer;
BEGIN
   I := 0;                                            { Set value to zero }
   Repeat
     Inc(I);                                          { Inc value }
   Until (I * I > X);                                 { Repeat till Sqr > X }
   ISqr := I - 1;                                     { Return result }
END;

{---------------------------------------------------------------------------}
{  MostEqualDivisors -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB }
{---------------------------------------------------------------------------}
PROCEDURE MostEqualDivisors (N: Integer; Var X, Y: Integer; FavorY: Boolean);
VAR I: Integer;
BEGIN
   I := ISqr(N);                                      { Int square of N }
   If ((N MOD I) <> 0) Then                           { Initial guess }
     If ((N MOD (I+1)) = 0) Then Inc(I);              { Add one row/column }
   If (I < (N DIV I)) Then I := N DIV I;              { In first page }
   If FavorY Then Begin                               { Horz preferred }
     X := N DIV I;                                    { Calc x position }
     Y := I;                                          { Set y position  }
   End Else Begin                                     { Vert preferred }
     Y := N DIV I;                                    { Calc y position }
     X := I;                                          { Set x position }
   End;
END;

{***************************************************************************}
{                               OBJECT METHODS                              }
{***************************************************************************}

{--TBackGround--------------------------------------------------------------}
{  Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB              }
{---------------------------------------------------------------------------}
CONSTRUCTOR TBackGround.Init (Var Bounds: TRect; APattern: Char);
BEGIN
   Inherited Init(Bounds);                            { Call ancestor }
   GrowMode := gfGrowHiX + gfGrowHiY;                 { Set grow modes }
   Pattern := APattern;                               { Hold pattern }
END;

{--TBackGround--------------------------------------------------------------}
{  Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB              }
{---------------------------------------------------------------------------}
CONSTRUCTOR TBackGround.Load (Var S: TStream);
BEGIN
   Inherited Load(S);                                 { Call ancestor }
   S.Read(Pattern, SizeOf(Pattern));                  { Read pattern data }
END;

{--TBackGround--------------------------------------------------------------}
{  GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB        }
{---------------------------------------------------------------------------}
FUNCTION TBackGround.GetPalette: PPalette;
{$IFDEF PPC_DELPHI3}                                  { DELPHI3+ COMPILER }
CONST P: String = CBackGround;                        { Possible huge string }
{$ELSE}                                               { OTHER COMPILERS }
CONST P: String[Length(CBackGround)] = CbackGround;   { Always normal string }
{$ENDIF}
BEGIN
   GetPalette := @P;                                  { Return palette }
END;

{--TBackGround--------------------------------------------------------------}
{  DrawBackground -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB    }
{---------------------------------------------------------------------------}
PROCEDURE TBackground.DrawBackground;
VAR B: TDrawBuffer;
BEGIN
   MoveChar(B, Pattern, GetColor($01), Size.X);       { Fill draw buffer }
   WriteLine(0, 0, Size.X, Size.Y, B);                { Draw to area }
END;

{--TBackGround--------------------------------------------------------------}
{  Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB             }
{---------------------------------------------------------------------------}
PROCEDURE TBackGround.Store (Var S: TStream);
BEGIN
   TView.Store(S);                                    { TView store called }
   S.Write(Pattern, SizeOf(Pattern));                 { Write pattern data }
END;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                          TDesktop OBJECT METHODS                          }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

{--TDesktop-----------------------------------------------------------------}
{  Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB              }
{---------------------------------------------------------------------------}
CONSTRUCTOR TDesktop.Init (Var Bounds: Objects.TRect);
BEGIN
   Inherited Init(Bounds);                            { Call ancestor }
   GrowMode := gfGrowHiX + gfGrowHiY;                 { Set growmode }
   InitBackground;                                    { Create background }
   If (Background <> Nil) Then Insert(Background);    { Insert background }
END;

{--TDesktop-----------------------------------------------------------------}
{  Load -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB              }
{---------------------------------------------------------------------------}
CONSTRUCTOR TDesktop.Load (Var S: TStream);
BEGIN
   Inherited Load(S);                                 { Call ancestor }
   GetSubViewPtr(S, Background);                      { Load background }
   S.Read(TileColumnsFirst, SizeOf(TileColumnsFirst));{ Read data }
END;

{--TDesktop-----------------------------------------------------------------}
{  TileError -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB         }
{---------------------------------------------------------------------------}
PROCEDURE TDeskTop.TileError;
BEGIN                                                 { Abstract method }
END;

{--TDesktop-----------------------------------------------------------------}
{  InitBackGround -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB    }
{---------------------------------------------------------------------------}
PROCEDURE TDesktop.InitBackground;
{$IFNDEF OS_WINDOWS} CONST Ch: Char = #176; {$ELSE} CONST Ch: Char = #167; {$ENDIF}
VAR R: TRect;
BEGIN
   GetExtent(R);                                      { Get desktop extents }
   BackGround := New(PBackground, Init(R, Ch));       { Insert a background }
END;

{--TDesktop-----------------------------------------------------------------}
{  Tile -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB              }
{---------------------------------------------------------------------------}
PROCEDURE TDeskTop.Tile (Var R: TRect);
VAR NumCols, NumRows, NumTileable, LeftOver, TileNum: Integer;

   FUNCTION DividerLoc (Lo, Hi, Num, Pos: Integer): Integer;
   BEGIN
     DividerLoc := LongInt( LongInt(Hi - Lo) * Pos)
       DIV Num + Lo;                                  { Calc position }
   END;

   PROCEDURE DoCountTileable (P: PView); FAR;
   BEGIN
     If Tileable(P) Then Inc(NumTileable);            { Count tileable views }
   END;

   PROCEDURE CalcTileRect (Pos: Integer; Var NR: TRect);
   VAR X, Y, D: Integer;
   BEGIN
     D := (NumCols - LeftOver) * NumRows;             { Calc d value }
     If (Pos<D) Then Begin
       X := Pos DIV NumRows; Y := Pos MOD NumRows;    { Calc positions }
     End Else Begin
       X := (Pos - D) div (NumRows + 1) +
         (NumCols - LeftOver);                        { Calc x position }
       Y := (Pos - D) mod (NumRows + 1);              { Calc y position }
     End;
     NR.A.X := DividerLoc(R.A.X, R.B.X, NumCols, X);  { Top left x position }
     NR.B.X := DividerLoc(R.A.X, R.B.X, NumCols, X+1);{ Right x position }
     If (Pos >= D) Then Begin
       NR.A.Y := DividerLoc(R.A.Y, R.B.Y,NumRows+1,Y);{ Top y position }
       NR.B.Y := DividerLoc(R.A.Y, R.B.Y, NumRows+1,
        Y+1);                                         { Bottom y position }
     End Else Begin
       NR.A.Y := DividerLoc(R.A.Y, R.B.Y,NumRows,Y);  { Top y position }
       NR.B.Y := DividerLoc(R.A.Y, R.B.Y, NumRows,
        Y+1);                                         { Bottom y position }
     End;
   END;

   PROCEDURE DoTile(P: PView); FAR;
   VAR PState: Word; R: TRect;
   BEGIN
     If Tileable(P) Then Begin
       CalcTileRect(TileNum, R);                      { Calc tileable area }
       PState := P^.State;                            { Hold view state }
       P^.State := P^.State AND NOT sfVisible;        { Temp not visible }
       P^.Locate(R);                                  { Locate view }
       P^.State := PState;                            { Restore view state }
       Dec(TileNum);                                  { One less to tile }
     End;
   END;

BEGIN
   NumTileable := 0;                                  { Zero tileable count }
   ForEach(@DoCountTileable);                         { Count tileable views }
   If (NumTileable>0) Then Begin
     MostEqualDivisors(NumTileable, NumCols, NumRows,
     NOT TileColumnsFirst);                           { Do pre calcs }
     If ((R.B.X - R.A.X) DIV NumCols = 0) OR
     ((R.B.Y - R.A.Y) DIV NumRows = 0) Then TileError { Can't tile }
     Else Begin
       LeftOver := NumTileable MOD NumCols;           { Left over count }
       TileNum := NumTileable-1;                      { Tileable views }
       ForEach(@DoTile);                              { Tile each view }
       DrawView;                                      { Now redraw }
     End;
   End;
END;

{--TDesktop-----------------------------------------------------------------}
{  Store -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB             }
{---------------------------------------------------------------------------}
PROCEDURE TDesktop.Store (Var S: TStream);
BEGIN
   TGroup.Store(S);                                   { Call group store }
   PutSubViewPtr(S, Background);                      { Store background }
   S.Write(TileColumnsFirst,SizeOf(TileColumnsFirst));{ Write data }
END;

{--TDesktop-----------------------------------------------------------------}
{  Cascade -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB           }
{---------------------------------------------------------------------------}
PROCEDURE TDeskTop.Cascade (Var R: TRect);
VAR CascadeNum: Integer; LastView: PView; Min, Max: TPoint;

   PROCEDURE DoCount (P: PView); FAR;
   BEGIN
     If Tileable(P) Then Begin
       Inc(CascadeNum); LastView := P;                { Count cascadable }
     End;
   END;

   PROCEDURE DoCascade (P: PView); FAR;
   VAR PState: Word; NR: TRect;
   BEGIN
     If Tileable(P) AND (CascadeNum >= 0) Then Begin  { View cascadable }
       NR.Copy(R);                                    { Copy rect area }
       Inc(NR.A.X, CascadeNum);                       { Inc x position }
       Inc(NR.A.Y, CascadeNum);                       { Inc y position }
       PState := P^.State;                            { Hold view state }
       P^.State := P^.State AND NOT sfVisible;        { Temp stop draw }
       P^.Locate(NR);                                 { Locate the view }
       P^.State := PState;                            { Now allow draws }
       Dec(CascadeNum);                               { Dec count }
     End;
   END;

BEGIN
   CascadeNum := 0;                                   { Zero cascade count }
   ForEach(@DoCount);                                 { Count cascadable }
   If (CascadeNum>0) Then Begin
     LastView^.SizeLimits(Min, Max);                  { Check size limits }
     If (Min.X > R.B.X - R.A.X - CascadeNum) OR
     (Min.Y > R.B.Y - R.A.Y - CascadeNum) Then
     TileError Else Begin                             { Check for error }
       Dec(CascadeNum);                               { One less view }
       ForEach(@DoCascade);                           { Cascade view }
       DrawView;                                      { Redraw now }
     End;
   End;
END;

{--TDesktop-----------------------------------------------------------------}
{  HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 11May98 LdB       }
{---------------------------------------------------------------------------}
PROCEDURE TDesktop.HandleEvent (Var Event: TEvent);
BEGIN
   Inherited HandleEvent(Event);                      { Call ancestor }
   If (Event.What = evCommand) Then Begin
     Case Event.Command of                            { Command event }
       cmNext: FocusNext(False);                      { Focus next view }
       cmPrev: If (BackGround <> Nil) Then Begin
         If Valid(cmReleasedFocus) Then
          Current^.PutInFrontOf(Background);          { Focus last view }
       End Else FocusNext(True);                      { Focus prior view }
       Else Exit;
     End;
     ClearEvent(Event);                               { Clear the event }
   End;
END;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                          TProgram OBJECT METHODS                          }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

CONST TvProgramClassName = 'TVPROGRAM'+#0;            { TV program class }

{--TProgram-----------------------------------------------------------------}
{  Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB              }
{---------------------------------------------------------------------------}
CONSTRUCTOR TProgram.Init;
VAR I: Integer; R: TRect; {$IFDEF OS_WINDOWS} ODc: HDc; {$ENDIF}
BEGIN
   Application := @Self;                              { Set application ptr }
   InitScreen;                                        { Initialize screen }
   R.Assign(0, 0, -(GetMaxX(TextModeGFV)+1),
     -(GetMaxY(TextModeGFV)+1));                      { Full screen area }
   Inherited Init(R);                                 { Call ancestor }
   State := sfVisible + sfSelected + sfFocused +
      sfModal + sfExposed;                            { Deafult states }
   Options := 0;                                      { No options set }
   {$IFDEF OS_WINDOWS}                                { WIN/NT CODE }
   ODc := GetDc(GetDeskTopWindow);                    { Get desktop context }
   For I := 0 To 15 Do Begin
     ColBrush[I] := CreateSolidBrush(GetNearestColor(
       ODc, ColRef[I]));                              { Create brushes }
     ColPen[I] := CreatePen(ps_Solid, 1,
       GetNearestColor(ODc, ColRef[I]));              { Create pens }
   End;
   ReleaseDC(GetDeskTopWindow, ODc);                  { Release context }
   CreateWindowNow(sw_ShowNormal);                    { Create app window }
   {$ENDIF}
   {$IFDEF OS_OS2}
   CreateWindowNow(swp_Show);                         { Create app window }
   {$ENDIF}
   {$IFNDEF OS_DOS}                                   { WIN/NT/OS2 CODE }
   AppWindow := HWindow;                              { Set app window handle }
   Size.X := ScreenWidth;                             { Set x size value }
   Size.Y := ScreenHeight;                            { Set y size value }
   RawSize.X := ScreenWidth * SysFontWidth;           { Set rawsize x }
   RawSize.Y := ScreenHeight * SysFontHeight - 1;     { Set rawsize y }
   {$ENDIF}
   InitStatusLine;                                    { Init status line }
   If (StatusLine <> Nil) Then Insert(StatusLine);    { Insert status line }
   InitMenuBar;                                       { Create a bar menu }
   If (MenuBar <> Nil) Then Insert(MenuBar);          { Insert menu bar }
   InitDesktop;                                       { Create desktop }
   If (Desktop <> Nil) Then Insert(Desktop);          { Insert desktop }
END;

{--TProgram-----------------------------------------------------------------}
{  Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB              }
{---------------------------------------------------------------------------}
DESTRUCTOR TProgram.Done;
VAR I: Integer;
BEGIN
   If (Desktop <> Nil) Then Dispose(Desktop, Done);   { Destroy desktop }
   If (MenuBar <> Nil) Then Dispose(MenuBar, Done);   { Destroy menu bar }
   If (StatusLine <> Nil) Then
     Dispose(StatusLine, Done);                       { Destroy status line }
   Application := Nil;                                { Clear application }
   Inherited Done;                                    { Call ancestor }
  {$IFDEF OS_WINDOWS}                                 { WIN/NT CODE }
   For I := 0 To 15 Do DeleteObject(ColBrush[I]);     { Delete brushes }
   For I := 0 To 15 Do DeleteObject(ColPen[I]);       { Delete pens }
  {$ENDIF}
  {$IFNDEF OS_DOS}                                    { WIN/NT/OS2 CODE }
   AppWindow := 0;                                    { Zero app window handle }
  {$ENDIF}
END;

{--TProgram-----------------------------------------------------------------}
{  GetPalette -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB        }
{---------------------------------------------------------------------------}
FUNCTION TProgram.GetPalette: PPalette;
CONST P: Array[apColor..apMonochrome] Of String = (CAppColor, CAppBlackWhite,
  CAppMonochrome);
BEGIN
   GetPalette := @P[AppPalette];                      { Return palette }
END;

{--TProgram-----------------------------------------------------------------}
{  CanMoveFocus -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 23Sep97 LdB      }
{---------------------------------------------------------------------------}
FUNCTION TProgram.CanMoveFocus: Boolean;
BEGIN
   If (Desktop <> Nil) Then                           { Valid desktop view }
     CanMovefocus := DeskTop^.Valid(cmReleasedFocus)  { Check focus move }
     Else CanMoveFocus := True;                       { No desktop who cares! }
END;

{--TProgram-----------------------------------------------------------------}
{  ValidView -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB         }
{---------------------------------------------------------------------------}
FUNCTION TProgram.ValidView (P: PView): PView;
BEGIN
   ValidView := Nil;                                  { Preset failure }
   If (P <> Nil) Then Begin
     If LowMemory Then Begin                          { Check memroy }
       Dispose(P, Done);                              { Dispose view }
       OutOfMemory;                                   { Call out of memory }
       Exit;                                          { Now exit }
     End;
     If NOT P^.Valid(cmValid) Then Begin              { Check view valid }
       Dispose(P, Done);                              { Dipose view }
       Exit;                                          { Now exit }
     End;
     ValidView := P;                                  { Return view }
   End;
END;

{--TProgram-----------------------------------------------------------------}
{  InsertWindow -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB      }
{---------------------------------------------------------------------------}
FUNCTION TProgram.InsertWindow (P: PWindow): PWindow;
BEGIN
   InsertWindow := Nil;                               { Preset failure }
   If (ValidView(P) <> Nil) Then                      { Check view valid }
     If (CanMoveFocus) AND (Desktop <> Nil)           { Can we move focus }
     Then Begin
       Desktop^.Insert(P);                            { Insert window }
       InsertWindow := P;                             { Return view ptr }
     End Else Dispose(P, Done);                       { Dispose view }
END;

{--TProgram-----------------------------------------------------------------}
{  ExecuteDialog -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB     }
{---------------------------------------------------------------------------}
FUNCTION TProgram.ExecuteDialog (P: PDialog; Data: Pointer): Word;
VAR ExecResult: Word;
BEGIN
   ExecuteDialog := cmCancel;                         { Preset cancel }
   If (ValidView(P) <> Nil) Then Begin                { Check view valid }
     If (Data <> Nil) Then P^.SetData(Data^);         { Set data }
     If (P <> Nil) Then P^.SelectDefaultView;         { Select default }
     ExecResult := Desktop^.ExecView(P);              { Execute view }
     If (ExecResult <> cmCancel) AND (Data <> Nil)
       Then P^.GetData(Data^);                        { Get data back }
     Dispose(P, Done);                                { Dispose of dialog }
     ExecuteDialog := ExecResult;                     { Return result }
   End;
END;

{--TProgram-----------------------------------------------------------------}
{  Run -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB               }
{---------------------------------------------------------------------------}
PROCEDURE TProgram.Run;
BEGIN
   Execute;                                           { Call execute }
END;

{--TProgram-----------------------------------------------------------------}
{  Idle -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Oct99 LdB              }
{---------------------------------------------------------------------------}
PROCEDURE TProgram.Idle;
BEGIN
   If (StatusLine <> Nil) Then StatusLine^.Update;    { Update statusline }
   If CommandSetChanged Then Begin                    { Check command change }
     Message(@Self, evBroadcast, cmCommandSetChanged,
       Nil);                                          { Send message }
     CommandSetChanged := False;                      { Clear flag }
   End;
END;

{--TProgram-----------------------------------------------------------------}
{  InitScreen -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB        }
{---------------------------------------------------------------------------}
PROCEDURE TProgram.InitScreen;
BEGIN
{$ifndef Use_API}
   If (Lo(ScreenMode) <> smMono) Then Begin           { Coloured mode }
     If (ScreenMode AND smFont8x8 <> 0) Then
       ShadowSize.X := 1 Else                         { Single bit shadow }
       ShadowSize.X := 2;                             { Double size }
     ShadowSize.Y := 1; ShowMarkers := False;         { Set variables }
     If (Lo(ScreenMode) = smBW80) Then
       AppPalette := apBlackWhite Else                { B & W palette }
       AppPalette := apColor;                         { Coloured palette }
   End Else Begin
     ShadowSize.X := 0;                               { No x shadow size }
     ShadowSize.Y := 0;                               { No y shadow size }
     ShowMarkers := True;                             { Show markers }
     AppPalette := apMonochrome;                      { Mono palette }
   End;
{$else Use_API}
  { the orginal code can't be used here because of the limited
    video unit capabilities, the mono modus can't be handled
  }
  if (ScreenMode.Col div ScreenMode.Row<2) then
    ShadowSize.X := 1
  else
    ShadowSize.X := 2;

  ShadowSize.Y := 1;
  ShowMarkers := False;
  if ScreenMode.color then
    AppPalette := apColor
  else
    AppPalette := apBlackWhite;
  Buffer := Views.PVideoBuf(VideoBuf);
{$endif Use_API}
END;

{--TProgram-----------------------------------------------------------------}
{  InitDeskTop -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB       }
{---------------------------------------------------------------------------}
PROCEDURE TProgram.InitDesktop;
VAR R: TRect;
BEGIN
   GetExtent(R);                                      { Get view extent }
   If (MenuBar <> Nil) Then Inc(R.A.Y);               { Adjust top down }
   If (StatusLine <> Nil) Then Dec(R.B.Y);            { Adjust bottom up }
   DeskTop := New(PDesktop, Init(R));                 { Create desktop }
END;

{--TProgram-----------------------------------------------------------------}
{  OutOfMemory -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08May98 LdB       }
{---------------------------------------------------------------------------}
PROCEDURE TProgram.OutOfMemory;
BEGIN                                                 { Abstract method }
END;

{--TProgram-----------------------------------------------------------------}
{  InitMenuBar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB       }
{---------------------------------------------------------------------------}
PROCEDURE TProgram.InitMenuBar;
VAR R: TRect;
BEGIN
   GetExtent(R);                                      { Get view extents }
   R.B.Y := R.A.Y + 1;                                { One line high  }
   MenuBar := New(PMenuBar, Init(R, Nil));            { Create menu bar }
END;

{--TProgram-----------------------------------------------------------------}
{  InitStatusLine -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB    }
{---------------------------------------------------------------------------}
PROCEDURE TProgram.InitStatusLine;
VAR R: TRect;
BEGIN
   GetExtent(R);                                      { Get view extents }
   R.A.Y := R.B.Y - 1;                                { One line high }
   New(StatusLine, Init(R,
     NewStatusDef(0, $FFFF,
       NewStatusKey('~Alt-X~ Exit', kbAltX, cmQuit,
       StdStatusKeys(Nil)), Nil)));                   { Default status line }
END;

{--TProgram-----------------------------------------------------------------}
{  SetScreenMode -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Oct99 LdB     }
{---------------------------------------------------------------------------}
PROCEDURE TProgram.SetScreenMode (Mode: Word);
BEGIN                                                 { Compatability only }
END;

{--TProgram-----------------------------------------------------------------}
{  PutEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB          }
{---------------------------------------------------------------------------}
PROCEDURE TProgram.PutEvent (Var Event: TEvent);
BEGIN
   Pending := Event;                                  { Set pending event }
END;

{--TProgram-----------------------------------------------------------------}
{  GetEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 10May98 LdB          }
{---------------------------------------------------------------------------}
PROCEDURE TProgram.GetEvent (Var Event: TEvent);
BEGIN
   Event.What := evNothing;
   If (Event.What = evNothing) Then Begin
     If (Pending.What <> evNothing) Then Begin        { Pending event }
       Event := Pending;                              { Load pending event }
       Pending.What := evNothing;                     { Clear pending event }
     End Else Begin
       NextQueuedEvent(Event);                        { Next queued event }
       If (Event.What = evNothing) Then Begin
         GetKeyEvent(Event);                          { Fetch key event }
         If (Event.What = evNothing) Then Begin       { No mouse event }
           Drivers.GetMouseEvent(Event);                      { Load mouse event }
           If (Event.What = evNothing) Then Idle;     { Idle if no event }
         End;
       End;
     End;
   End;
END;

{--TProgram-----------------------------------------------------------------}
{  HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 12Sep97 LdB       }
{---------------------------------------------------------------------------}
PROCEDURE TProgram.HandleEvent (Var Event: TEvent);
VAR C: Char;
BEGIN
   If (Event.What = evKeyDown) Then Begin             { Key press event }
     C := GetAltChar(Event.KeyCode);                  { Get alt char code }
     If (C >= '1') AND (C <= '9') Then
       If (Message(Desktop, evBroadCast, cmSelectWindowNum,
         Pointer(Byte(C) - $30)) <> Nil)              { Select window }
         Then ClearEvent(Event);                      { Clear event }
   End;
   Inherited HandleEvent(Event);                      { Call ancestor }
   If (Event.What = evCommand) AND                    { Command event }
   (Event.Command = cmQuit) Then Begin                { Quit command }
      EndModal(cmQuit);                               { Endmodal operation }
      ClearEvent(Event);                              { Clear event }
   End;
END;

{$IFNDEF OS_DOS}
{***************************************************************************}
{                  TProgram OBJECT WIN/NT/OS2 ONLY METHODS                  }
{***************************************************************************}

{--TProgram-----------------------------------------------------------------}
{  GetClassText -> Platforms WIN/NT/OS2 - Checked 18Mar98 LdB               }
{---------------------------------------------------------------------------}
FUNCTION TProgram.GetClassText: String;
VAR S: String; {$IFDEF OS_OS2} I: Integer; {$ENDIF}
BEGIN
   {$IFDEF OS_WINDOWS}                                { WIN/NT CODE }
     {$IFDEF PPC_DELPHI3}                             { DELPHI3+ CODE }
     SetLength(S, 255);                               { Make string not empty }
     SetLength(S, GetModuleFilename( 0, PChar(S),
       Length(S) ) );                                 { Fetch module name }
     {$ELSE}                                          { OTHER COMPILERS }
     S[0] := Chr(GetModuleFileName(HInstance, @S[1],
       255));                                         { Fetch module name }
     {$ENDIF}
   {$ENDIF}
   {$IFDEF OS_OS2}                                    { OS2 CODE }
   WinQuerySessionTitle(Anchor, 0, @S[1], 255);       { Fetch session name }
   I := 1;                                            { Start on first }
   While (S[I] <> #0) AND (I<255) Do Inc(I);          { Find pchar end }
   S[0] := Chr(I);                                    { Set string length }
   {$ENDIF}
   GetClassText := S;                                 { Return the string }
END;

{--TProgram-----------------------------------------------------------------}
{  GetClassName -> Platforms WIN/NT/OS2 - Updated 13May98 LdB               }
{---------------------------------------------------------------------------}
FUNCTION TProgram.GetClassName: String;
BEGIN
   GetClassName := TvProgramClassName;                { Program class name }
END;

{--TProgram-----------------------------------------------------------------}
{  GetClassAttr -> Platforms WIN/NT/OS2 - Checked 17Mar98 LdB               }
{---------------------------------------------------------------------------}
FUNCTION TProgram.GetClassAttr: LongInt;
VAr Li: LongInt;
BEGIN
   {$IFDEF OS_WINDOWS}                                { WIN/NT CODE }
   Li := Inherited GetClassAttr;                      { Call ancestor }
   Li := Li AND NOT ws_Child;                         { Not child view }
   GetClassAttr := Li OR ws_OverlappedWindow;         { Overlapping window }
   {$ENDIF}
   {$IFDEF OS_OS2}                                    { OS2 CODE }
   GetClassAttr := fcf_TitleBar OR fcf_SysMenu OR
     fcf_SizeBorder OR fcf_MinMax OR fcf_TaskList OR
     fcf_NoByteAlign;                                 { Window defaults }
   {$ENDIF}
END;

{--TProgram-----------------------------------------------------------------}
{  GetMsghandler -> Platforms WIN/NT/OS2 - Updated 13May98 LdB              }
{---------------------------------------------------------------------------}
FUNCTION TProgram.GetMsgHandler: Pointer;
BEGIN
   GetMsgHandler := @TvAppMsgHandler;                 { Application handler }
END;

{$ENDIF}

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                        TApplication OBJECT METHODS                        }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

{--TApplication-------------------------------------------------------------}
{  Init -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB              }
{---------------------------------------------------------------------------}
CONSTRUCTOR TApplication.Init;
BEGIN
   InitMemory;                                        { Start memory up }
   InitVideo;                                         { Start video up }
   InitEvents;                                        { Start event drive }
   InitSysError;                                      { Start system error }
   InitHistory;                                       { Start history up }
   Inherited Init;                                    { Call ancestor }
END;

{--TApplication-------------------------------------------------------------}
{  Done -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB              }
{---------------------------------------------------------------------------}
DESTRUCTOR TApplication.Done;
BEGIN
   Inherited Done;                                    { Call ancestor }
   DoneHistory;                                       { Close history }
   DoneSysError;                                      { Close system error }
   DoneEvents;                                        { Close event drive }
   DoneVideo;                                         { Close video }
   DoneMemory;                                        { Close memory }
END;

{--TApplication-------------------------------------------------------------}
{  Tile -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB              }
{---------------------------------------------------------------------------}
PROCEDURE TApplication.Tile;
VAR R: TRect;
BEGIN
   GetTileRect(R);                                    { Tileable area }
   If (Desktop <> Nil) Then Desktop^.Tile(R);         { Tile desktop }
END;

{--TApplication-------------------------------------------------------------}
{  Cascade -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB           }
{---------------------------------------------------------------------------}
PROCEDURE TApplication.Cascade;
VAR R: TRect;
BEGIN
   GetTileRect(R);                                    { Cascade area }
   If (Desktop <> Nil) Then Desktop^.Cascade(R);      { Cascade desktop }
END;

{--TApplication-------------------------------------------------------------}
{  DosShell -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 25Oct99 LdB          }
{---------------------------------------------------------------------------}
PROCEDURE TApplication.DosShell;
BEGIN                                                 { Compatability only }
END;

{--TApplication-------------------------------------------------------------}
{  GetTileRect -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB       }
{---------------------------------------------------------------------------}
PROCEDURE TApplication.GetTileRect (Var R: TRect);
BEGIN
   If (DeskTop <> Nil) Then Desktop^.GetExtent(R)     { Desktop extents }
     Else GetExtent(R);                               { Our extents }
END;

{--TApplication-------------------------------------------------------------}
{  HandleEvent -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB       }
{---------------------------------------------------------------------------}
PROCEDURE TApplication.HandleEvent (Var Event: TEvent);
BEGIN
   Inherited HandleEvent(Event);                      { Call ancestor }
   If (Event.What = evCommand) Then Begin
     Case Event.Command Of
       cmTile: Tile;                                  { Tile request }
       cmCascade: Cascade;                            { Cascade request }
       cmDosShell: DosShell;                          { DOS shell request }
       Else Exit;                                     { Unhandled exit }
     End;
     ClearEvent(Event);                               { Clear the event }
   End;
END;

{***************************************************************************}
{                            INTERFACE ROUTINES                             }
{***************************************************************************}

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                STANDARD MENU AND STATUS LINES ROUTINES                    }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

{---------------------------------------------------------------------------}
{  StdStatusKeys -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB     }
{---------------------------------------------------------------------------}
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;

{---------------------------------------------------------------------------}
{  StdFileMenuItems -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB  }
{---------------------------------------------------------------------------}
FUNCTION StdFileMenuItems (Next: PMenuItem): PMenuItem;
BEGIN
   StdFileMenuItems :=
     NewItem('~N~ew', '', kbNoKey, cmNew, hcNew,
     NewItem('~O~pen...', 'F3', kbF3, cmOpen, hcOpen,
     NewItem('~S~ave', 'F2', kbF2, cmSave, hcSave,
     NewItem('S~a~ve as...', '', kbNoKey, cmSaveAs, hcSaveAs,
     NewItem('Save a~l~l', '', kbNoKey, cmSaveAll, hcSaveAll,
     NewLine(
     NewItem('~C~hange dir...', '', kbNoKey, cmChangeDir, hcChangeDir,
     NewItem('OS shell', '', kbNoKey, cmDosShell, hcDosShell,
     NewItem('E~x~it', 'Alt+X', kbAltX, cmQuit, hcExit,
     Next)))))))));
END;

{---------------------------------------------------------------------------}
{  StdEditMenuItems -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB  }
{---------------------------------------------------------------------------}
FUNCTION StdEditMenuItems (Next: PMenuItem): PMenuItem;
BEGIN
   StdEditMenuItems :=
     NewItem('~U~ndo', '', kbAltBack, cmUndo, hcUndo,
     NewLine(
     NewItem('Cu~t~', 'Shift+Del', kbShiftDel, cmCut, hcCut,
     NewItem('~C~opy', 'Ctrl+Ins', kbCtrlIns, cmCopy, hcCopy,
     NewItem('~P~aste', 'Shift+Ins', kbShiftIns, cmPaste, hcPaste,
     NewItem('C~l~ear', 'Ctrl+Del', kbCtrlDel, cmClear, hcClear,
     Next))))));
END;

{---------------------------------------------------------------------------}
{ StdWindowMenuItems -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB }
{---------------------------------------------------------------------------}
FUNCTION StdWindowMenuItems (Next: PMenuItem): PMenuItem;
BEGIN
   StdWindowMenuItems :=
     NewItem('~T~ile', '', kbNoKey, cmTile, hcTile,
     NewItem('C~a~scade', '', kbNoKey, cmCascade, hcCascade,
     NewItem('Cl~o~se all', '', kbNoKey, cmCloseAll, hcCloseAll,
     NewLine(
     NewItem('~S~ize/Move','Ctrl+F5', kbCtrlF5, cmResize, hcResize,
     NewItem('~Z~oom', 'F5', kbF5, cmZoom, hcZoom,
     NewItem('~N~ext', 'F6', kbF6, cmNext, hcNext,
     NewItem('~P~revious', 'Shift+F6', kbShiftF6, cmPrev, hcPrev,
     NewItem('~C~lose', 'Alt+F3', kbAltF3, cmClose, hcClose,
     Next)))))))));
END;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                           OBJECT REGISTER ROUTINES                        }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

{---------------------------------------------------------------------------}
{  RegisterApp -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 22Oct99 LdB       }
{---------------------------------------------------------------------------}
PROCEDURE RegisterApp;
BEGIN
   RegisterType(RBackground);                         { Register background }
   RegisterType(RDesktop);                            { Register desktop }
END;

END.
{
 $Log$
 Revision 1.4  2001-04-10 21:57:55  pierre
  + first adds for Use_API define

 Revision 1.3  2001/04/10 21:29:54  pierre
  * import of Leon de Boer's files

 Revision 1.2  2000/08/24 11:43:13  marco
  * Added CVS log and ID entries.


}