home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / vp21beta.zip / ATVSRC.RAR / APP.PAS next >
Pascal/Delphi Source File  |  2000-08-15  |  22KB  |  886 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Turbo Pascal Version 7.0                        }
  5. {       Turbo Vision Unit                               }
  6. {                                                       }
  7. {       Copyright (c) 1992 Borland International        }
  8. {                                                       }
  9. {       Virtual Pascal v2.1                             }
  10. {       Copyright (C) 1996-2000 vpascal.com             }
  11. {                                                       }
  12. {*******************************************************}
  13.  
  14. unit App;
  15.  
  16. {$X+,I-,S-,Cdecl-,Use32+}
  17.  
  18. interface
  19.  
  20. uses Objects, Drivers, Memory, HistList, Views, Menus, Dialogs;
  21.  
  22. const
  23.  
  24. { TApplication palette entries }
  25.  
  26.   apColor      = 0;
  27.   apBlackWhite = 1;
  28.   apMonochrome = 2;
  29.  
  30. { TApplication palettes }
  31.  
  32.   { Turbo Vision 1.0 Color Palettes }
  33.  
  34.   CColor =
  35.         #$71#$70#$78#$74#$20#$28#$24#$17#$1F#$1A#$31#$31#$1E#$71#$1F +
  36.     #$37#$3F#$3A#$13#$13#$3E#$21#$3F#$70#$7F#$7A#$13#$13#$70#$7F#$7E +
  37.     #$70#$7F#$7A#$13#$13#$70#$70#$7F#$7E#$20#$2B#$2F#$78#$2E#$70#$30 +
  38.     #$3F#$3E#$1F#$2F#$1A#$20#$72#$31#$31#$30#$2F#$3E#$31#$13#$38#$00;
  39.  
  40.   CBlackWhite =
  41.         #$70#$70#$78#$7F#$07#$07#$0F#$07#$0F#$07#$70#$70#$07#$70#$0F +
  42.     #$07#$0F#$07#$70#$70#$07#$70#$0F#$70#$7F#$7F#$70#$07#$70#$07#$0F +
  43.     #$70#$7F#$7F#$70#$07#$70#$70#$7F#$7F#$07#$0F#$0F#$78#$0F#$78#$07 +
  44.     #$0F#$0F#$0F#$70#$0F#$07#$70#$70#$70#$07#$70#$0F#$07#$07#$78#$00;
  45.  
  46.   CMonochrome =
  47.         #$70#$07#$07#$0F#$70#$70#$70#$07#$0F#$07#$70#$70#$07#$70#$00 +
  48.     #$07#$0F#$07#$70#$70#$07#$70#$00#$70#$70#$70#$07#$07#$70#$07#$00 +
  49.     #$70#$70#$70#$07#$07#$70#$70#$70#$0F#$07#$07#$0F#$70#$0F#$70#$07 +
  50.     #$0F#$0F#$07#$70#$07#$07#$70#$07#$07#$07#$70#$0F#$07#$07#$70#$00;
  51.  
  52.   { Turbo Vision 2.0 Color Palettes }
  53.  
  54.   CAppColor =
  55.         #$71#$70#$78#$74#$20#$28#$24#$17#$1F#$1A#$31#$31#$1E#$71#$1F +
  56.     #$37#$3F#$3A#$13#$13#$3E#$21#$3F#$70#$7F#$7A#$13#$13#$70#$7F#$7E +
  57.     #$70#$7F#$7A#$13#$13#$70#$70#$7F#$7E#$20#$2B#$2F#$78#$2E#$70#$30 +
  58.     #$3F#$3E#$1F#$2F#$1A#$20#$72#$31#$31#$30#$2F#$3E#$31#$13#$38#$00 +
  59.     #$17#$1F#$1A#$71#$71#$1E#$17#$1F#$1E#$20#$2B#$2F#$78#$2E#$10#$30 +
  60.     #$3F#$3E#$70#$2F#$7A#$20#$12#$31#$31#$30#$2F#$3E#$31#$13#$38#$00 +
  61.     #$37#$3F#$3A#$13#$13#$3E#$30#$3F#$3E#$20#$2B#$2F#$78#$2E#$30#$70 +
  62.     #$7F#$7E#$1F#$2F#$1A#$20#$32#$31#$71#$70#$2F#$7E#$71#$13#$38#$00;
  63.  
  64.   CAppBlackWhite =
  65.         #$70#$70#$78#$7F#$07#$07#$0F#$07#$0F#$07#$70#$70#$07#$70#$0F +
  66.     #$07#$0F#$07#$70#$70#$07#$70#$0F#$70#$7F#$7F#$70#$07#$70#$07#$0F +
  67.     #$70#$7F#$7F#$70#$07#$70#$70#$7F#$7F#$07#$0F#$0F#$78#$0F#$78#$07 +
  68.     #$0F#$0F#$0F#$70#$0F#$07#$70#$70#$70#$07#$70#$0F#$07#$07#$78#$00 +
  69.     #$07#$0F#$0F#$07#$70#$07#$07#$0F#$0F#$70#$78#$7F#$08#$7F#$08#$70 +
  70.     #$7F#$7F#$7F#$0F#$70#$70#$07#$70#$70#$70#$07#$7F#$70#$07#$78#$00 +
  71.     #$70#$7F#$7F#$70#$07#$70#$70#$7F#$7F#$07#$0F#$0F#$78#$0F#$78#$07 +
  72.     #$0F#$0F#$0F#$70#$0F#$07#$70#$70#$70#$07#$70#$0F#$07#$07#$78#$00;
  73.  
  74.   CAppMonochrome =
  75.         #$70#$07#$07#$0F#$70#$70#$70#$07#$0F#$07#$70#$70#$07#$70#$00 +
  76.     #$07#$0F#$07#$70#$70#$07#$70#$00#$70#$70#$70#$07#$07#$70#$07#$00 +
  77.     #$70#$70#$70#$07#$07#$70#$70#$70#$0F#$07#$07#$0F#$70#$0F#$70#$07 +
  78.     #$0F#$0F#$07#$70#$07#$07#$70#$07#$07#$07#$70#$0F#$07#$07#$70#$00 +
  79.     #$70#$70#$70#$07#$07#$70#$70#$70#$0F#$07#$07#$0F#$70#$0F#$70#$07 +
  80.     #$0F#$0F#$07#$70#$07#$07#$70#$07#$07#$07#$70#$0F#$07#$07#$70#$00 +
  81.     #$70#$70#$70#$07#$07#$70#$70#$70#$0F#$07#$07#$0F#$70#$0F#$70#$07 +
  82.     #$0F#$0F#$07#$70#$07#$07#$70#$07#$07#$07#$70#$0F#$07#$07#$70#$00;
  83.  
  84. { TBackground palette }
  85.  
  86.   CBackground = #1;
  87.  
  88. { Standard application commands }
  89.  
  90.   cmNew       = 30;
  91.   cmOpen      = 31;
  92.   cmSave      = 32;
  93.   cmSaveAs    = 33;
  94.   cmSaveAll   = 34;
  95.   cmChangeDir = 35;
  96.   cmDosShell  = 36;
  97.   cmCloseAll  = 37;
  98.  
  99. { Standard application help contexts }
  100.  
  101. { Note: range $FF00 - $FFFF of help contexts are reserved by Borland }
  102.  
  103.   hcNew          = $FF01;
  104.   hcOpen         = $FF02;
  105.   hcSave         = $FF03;
  106.   hcSaveAs       = $FF04;
  107.   hcSaveAll      = $FF05;
  108.   hcChangeDir    = $FF06;
  109.   hcDosShell     = $FF07;
  110.   hcExit         = $FF08;
  111.  
  112.   hcUndo         = $FF10;
  113.   hcCut          = $FF11;
  114.   hcCopy         = $FF12;
  115.   hcPaste        = $FF13;
  116.   hcClear        = $FF14;
  117.  
  118.   hcTile         = $FF20;
  119.   hcCascade      = $FF21;
  120.   hcCloseAll     = $FF22;
  121.   hcResize       = $FF23;
  122.   hcZoom         = $FF24;
  123.   hcNext         = $FF25;
  124.   hcPrev         = $FF26;
  125.   hcClose        = $FF27;
  126.  
  127. type
  128.  
  129. { TBackground object }
  130.  
  131.   PBackground = ^TBackground;
  132.   TBackground = object(TView)
  133.     Pattern: Char;
  134.     constructor Init(var Bounds: TRect; APattern: Char);
  135.     constructor Load(var S: TStream);
  136.     procedure Draw; virtual;
  137.     function GetPalette: PPalette; virtual;
  138.     procedure Store(var S: TStream);
  139.   end;
  140.  
  141. { TDesktop object }
  142.  
  143.   PDesktop = ^TDesktop;
  144.   TDesktop = object(TGroup)
  145.     Background: PBackground;
  146.     TileColumnsFirst: Boolean;
  147.     constructor Init(var Bounds: TRect);
  148.     constructor Load(var S: TStream);
  149.     procedure Cascade(var R: TRect);
  150.     procedure HandleEvent(var Event: TEvent); virtual;
  151.     procedure InitBackground; virtual;
  152.     procedure Store(var S: TStream);
  153.     procedure Tile(var R: TRect);
  154.     procedure TileError; virtual;
  155.   end;
  156.  
  157. { TProgram object }
  158.  
  159.   { Palette layout }
  160.   {     1 = TBackground }
  161.   {  2- 7 = TMenuView and TStatusLine }
  162.   {  8-15 = TWindow(Blue) }
  163.   { 16-23 = TWindow(Cyan) }
  164.   { 24-31 = TWindow(Gray) }
  165.   { 32-63 = TDialog }
  166.  
  167.   PProgram = ^TProgram;
  168.   TProgram = object(TGroup)
  169.     constructor Init;
  170.     destructor Done; virtual;
  171.     function CanMoveFocus: Boolean;
  172.     function ExecuteDialog(P: PDialog; Data: Pointer): Word;
  173.     procedure GetEvent(var Event: TEvent); virtual;
  174.     function GetPalette: PPalette; virtual;
  175.     procedure HandleEvent(var Event: TEvent); virtual;
  176.     procedure Idle; virtual;
  177.     procedure InitDesktop; virtual;
  178.     procedure InitMenuBar; virtual;
  179.     procedure InitScreen; virtual;
  180.     procedure InitStatusLine; virtual;
  181.     function InsertWindow(P: PWindow): PWindow;
  182.     procedure OutOfMemory; virtual;
  183.     procedure PutEvent(var Event: TEvent); virtual;
  184.     procedure Run; virtual;
  185.     procedure SetScreenMode(Mode: Word);
  186.     function ValidView(P: PView): PView;
  187.   end;
  188.  
  189. { TApplication object }
  190.  
  191.   PApplication = ^TApplication;
  192.   TApplication = object(TProgram)
  193.     constructor Init;
  194.     destructor Done; virtual;
  195.     procedure Cascade;
  196.     procedure DosShell;
  197.     procedure GetTileRect(var R: TRect); virtual;
  198.     procedure HandleEvent(var Event: TEvent); virtual;
  199.     procedure Tile;
  200.     procedure WriteShellMsg; virtual;
  201.   end;
  202.  
  203. { Standard menus and status lines }
  204.  
  205. function StdStatusKeys(Next: PStatusItem): PStatusItem;
  206.  
  207. function StdFileMenuItems(Next: PMenuItem): PMenuItem;
  208. function StdEditMenuItems(Next: PMenuItem): PMenuItem;
  209. function StdWindowMenuItems(Next: PMenuItem): PMenuItem;
  210.  
  211. { App registration procedure }
  212.  
  213. procedure RegisterApp;
  214.  
  215. const
  216.  
  217. { Public variables }
  218.  
  219.   Application: PProgram = nil;
  220.   Desktop: PDesktop = nil;
  221.   StatusLine: PStatusLine = nil;
  222.   MenuBar: PMenuView = nil;
  223.   AppPalette: Integer = apColor;
  224.  
  225. { Stream registration records }
  226.  
  227. const
  228.   RBackground: TStreamRec = (
  229.     ObjType: 30;
  230.     VmtLink: Ofs(TypeOf(TBackground)^);
  231.     Load: @TBackground.Load;
  232.     Store: @TBackground.Store);
  233.  
  234. const
  235.   RDesktop: TStreamRec = (
  236.     ObjType: 31;
  237.     VmtLink: Ofs(TypeOf(TDesktop)^);
  238.     Load: @TDesktop.Load;
  239.     Store: @TDesktop.Store);
  240.  
  241. implementation
  242.  
  243. uses Dos, VpSysLow;
  244.  
  245. const
  246.  
  247. { Private variables }
  248.  
  249.   Pending: TEvent = (What: evNothing);
  250.  
  251. { TBackground }
  252.  
  253. constructor TBackground.Init(var Bounds: TRect; APattern: Char);
  254. begin
  255.   TView.Init(Bounds);
  256.   GrowMode := gfGrowHiX + gfGrowHiY;
  257.   Pattern := APattern;
  258. end;
  259.  
  260. constructor TBackground.Load(var S: TStream);
  261. begin
  262.   TView.Load(S);
  263.   S.Read(Pattern, SizeOf(Pattern));
  264. end;
  265.  
  266. procedure TBackground.Draw;
  267. var
  268.   B: TDrawBuffer;
  269. begin
  270.   MoveChar(B, Pattern, GetColor($01), Size.X);
  271.   WriteLine(0, 0, Size.X, Size.Y, B);
  272. end;
  273.  
  274. function TBackground.GetPalette: PPalette;
  275. const
  276.   P: string[Length(CBackground)] = CBackground;
  277. begin
  278.   GetPalette := @P;
  279. end;
  280.  
  281. procedure TBackground.Store(var S: TStream);
  282. begin
  283.   TView.Store(S);
  284.   S.Write(Pattern, SizeOf(Pattern));
  285. end;
  286.  
  287. { TDesktop object }
  288.  
  289. constructor TDesktop.Init(var Bounds: TRect);
  290. begin
  291.   inherited Init(Bounds);
  292.   GrowMode := gfGrowHiX + gfGrowHiY;
  293.   InitBackground;
  294.   if Background <> nil then Insert(Background);
  295. end;
  296.  
  297. constructor TDesktop.Load(var S: TStream);
  298. begin
  299.   inherited Load(S);
  300.   GetSubViewPtr(S, Background);
  301.   S.Read(TileColumnsFirst, SizeOf(TileColumnsFirst));
  302. end;
  303.  
  304. function Tileable(P: PView): Boolean;
  305. begin
  306.   Tileable := (P^.Options and ofTileable <> 0) and
  307.     (P^.State and sfVisible <> 0);
  308. end;
  309.  
  310. procedure TDesktop.Cascade(var R: TRect);
  311. var
  312.   CascadeNum: Integer;
  313.   LastView: PView;
  314.   Min, Max: TPoint;
  315.  
  316.  
  317. procedure DoCount(P: PView); far;
  318. begin
  319.   if Tileable(P) then
  320.   begin
  321.     Inc(CascadeNum);
  322.     LastView := P;
  323.   end;
  324. end;
  325.  
  326. procedure DoCascade(P: PView); far;
  327. var
  328.   NR: TRect;
  329. begin
  330.   if Tileable(P) and (CascadeNum >= 0) then
  331.   begin
  332.     NR.Copy(R);
  333.     Inc(NR.A.X, CascadeNum); Inc(NR.A.Y, CascadeNum);
  334.     P^.Locate(NR);
  335.     Dec(CascadeNum);
  336.   end;
  337. end;
  338.  
  339. begin
  340.   CascadeNum := 0;
  341.   ForEach(@DoCount);
  342.   if CascadeNum > 0 then
  343.   begin
  344.     LastView^.SizeLimits(Min, Max);
  345.     if (Min.X > R.B.X - R.A.X - CascadeNum) or
  346.        (Min.Y > R.B.Y - R.A.Y - CascadeNum) then TileError
  347.     else
  348.     begin
  349.       Dec(CascadeNum);
  350.       Lock;
  351.       ForEach(@DoCascade);
  352.       Unlock;
  353.     end;
  354.   end;
  355. end;
  356.  
  357. procedure TDesktop.HandleEvent(var Event: TEvent);
  358. begin
  359.   TGroup.HandleEvent(Event);
  360.   if Event.What = evCommand then
  361.   begin
  362.     case Event.Command of
  363.       cmNext: FocusNext(False);
  364.       cmPrev:
  365.         if Valid(cmReleasedFocus) then
  366.           Current^.PutInFrontOf(Background);
  367.     else
  368.       Exit;
  369.     end;
  370.     ClearEvent(Event);
  371.   end;
  372. end;
  373.  
  374. procedure TDesktop.InitBackground;
  375. var
  376.   R: TRect;
  377. begin
  378.   GetExtent(R);
  379.   New(Background, Init(R, ldDesktopBackground));
  380. end;
  381.  
  382. function ISqr(X: Integer): Integer; {&USES ebx} {&FRAME-}
  383. asm
  384.                 mov     ecx,X
  385.                 xor     ebx,ebx
  386.               @@1:
  387.                 inc     ebx
  388.                 mov     eax,ebx
  389.                 imul    eax
  390.                 cmp     eax,ecx
  391.                 jle     @@1
  392.                 lea     eax,[ebx-1]
  393. end;
  394.  
  395. procedure MostEqualDivisors(N: Integer; var X, Y: Integer; FavorY: Boolean);
  396. var
  397.   I: Integer;
  398. begin
  399.   I := ISqr(N);
  400.   if ((N mod I) <> 0) then
  401.     if (N mod (I+1)) = 0 then Inc(I);
  402.   if I < (N div I) then I := N div I;
  403.   if FavorY then
  404.   begin
  405.     X := N div I;
  406.     Y := I;
  407.   end
  408.   else
  409.   begin
  410.     Y := N div I;
  411.     X := I;
  412.   end;
  413. end;
  414.  
  415. procedure TDesktop.Store(var S: TStream);
  416. begin
  417.   inherited Store(S);
  418.   PutSubViewPtr(S, Background);
  419.   S.Write(TileColumnsFirst, SizeOf(TileColumnsFirst));
  420. end;
  421.  
  422. procedure TDesktop.Tile(var R: TRect);
  423. var
  424.   NumCols, NumRows, NumTileable, LeftOver, TileNum: Integer;
  425.  
  426. procedure DoCountTileable(P: PView); far;
  427. begin
  428.   if Tileable(P) then Inc(NumTileable);
  429. end;
  430.  
  431. function DividerLoc(Lo, Hi, Num, Pos: Integer): Integer;
  432. begin
  433.   DividerLoc := ((Hi - Lo) * Pos) div Num + Lo;
  434. end;
  435.  
  436. procedure CalcTileRect(Pos: Integer; var NR: TRect);
  437. var
  438.   X,Y,D: Integer;
  439. begin
  440.   D := (NumCols - LeftOver) * NumRows;
  441.   if Pos < D then
  442.   begin
  443.     X := Pos div NumRows;
  444.     Y := Pos mod NumRows;
  445.   end else
  446.   begin
  447.     X := (Pos - D) div (NumRows + 1) + (NumCols - LeftOver);
  448.     Y := (Pos - D) mod (NumRows + 1);
  449.   end;
  450.   NR.A.X := DividerLoc(R.A.X, R.B.X, NumCols, X);
  451.   NR.B.X := DividerLoc(R.A.X, R.B.X, NumCols, X+1);
  452.   if Pos >= D then
  453.   begin
  454.     NR.A.Y := DividerLoc(R.A.Y, R.B.Y, NumRows+1, Y);
  455.     NR.B.Y := DividerLoc(R.A.Y, R.B.Y, NumRows+1, Y+1);
  456.   end else
  457.   begin
  458.     NR.A.Y := DividerLoc(R.A.Y, R.B.Y, NumRows, Y);
  459.     NR.B.Y := DividerLoc(R.A.Y, R.B.Y, NumRows, Y+1);
  460.   end;
  461. end;
  462.  
  463. procedure DoTile(P: PView); far;
  464. var
  465.   R: TRect;
  466. begin
  467.   if Tileable(P) then
  468.   begin
  469.     CalcTileRect(TileNum, R);
  470.     P^.Locate(R);
  471.     Dec(TileNum);
  472.   end;
  473. end;
  474.  
  475. begin
  476.   NumTileable := 0;
  477.   ForEach(@DoCountTileable);
  478.   if NumTileable > 0 then
  479.   begin
  480.     MostEqualDivisors(NumTileable, NumCols, NumRows, not TileColumnsFirst);
  481.     if ((R.B.X - R.A.X) div NumCols = 0) or
  482.        ((R.B.Y - R.A.Y) div NumRows = 0) then TileError
  483.     else
  484.     begin
  485.       LeftOver := NumTileable mod NumCols;
  486.       TileNum := NumTileable-1;
  487.       Lock;
  488.       ForEach(@DoTile);
  489.       Unlock;
  490.     end;
  491.   end;
  492. end;
  493.  
  494. procedure TDesktop.TileError;
  495. begin
  496. end;
  497.  
  498. { TProgram }
  499.  
  500. constructor TProgram.Init;
  501. var
  502.   R: TRect;
  503. begin
  504.   Application := @Self;
  505.   InitScreen;
  506.   R.Assign(0, 0, ScreenWidth, ScreenHeight);
  507.   TGroup.Init(R);
  508.   State := sfVisible + sfSelected + sfFocused + sfModal + sfExposed;
  509.   Options := 0;
  510.   Buffer := ScreenBuffer;
  511.   InitDesktop;
  512.   InitStatusLine;
  513.   InitMenuBar;
  514.   if Desktop <> nil then Insert(Desktop);
  515.   if StatusLine <> nil then Insert(StatusLine);
  516.   if MenuBar <> nil then Insert(MenuBar);
  517. end;
  518.  
  519. destructor TProgram.Done;
  520. begin
  521.   if Desktop <> nil then Dispose(Desktop, Done);
  522.   if MenuBar <> nil then Dispose(MenuBar, Done);
  523.   if StatusLine <> nil then Dispose(StatusLine, Done);
  524.   Application := nil;
  525.   inherited Done;
  526. end;
  527.  
  528. function TProgram.CanMoveFocus: Boolean;
  529. begin
  530.   CanMoveFocus := Desktop^.Valid(cmReleasedFocus);
  531. end;
  532.  
  533. function TProgram.ExecuteDialog(P: PDialog; Data: Pointer): Word;
  534. var
  535.   C: Word;
  536. begin
  537.   ExecuteDialog := cmCancel;
  538.   if ValidView(P) <> nil then
  539.   begin
  540.     if Data <> nil then P^.SetData(Data^);
  541.     C := Desktop^.ExecView(P);
  542.     if (C <> cmCancel) and (Data <> nil) then P^.GetData(Data^);
  543.     Dispose(P, Done);
  544.     ExecuteDialog := C;
  545.   end;
  546. end;
  547.  
  548. procedure TProgram.GetEvent(var Event: TEvent);
  549. var
  550.   R: TRect;
  551.  
  552. function ContainsMouse(P: PView): Boolean; far;
  553. begin
  554.   ContainsMouse := (P^.State and sfVisible <> 0) and
  555.     P^.MouseInView(Event.Where);
  556. end;
  557.  
  558. begin
  559.   if Pending.What <> evNothing then
  560.   begin
  561.     Event := Pending;
  562.     Pending.What := evNothing;
  563.   end else
  564.   begin
  565.     GetMouseEvent(Event);
  566.     if Event.What = evNothing then
  567.     begin
  568.       GetKeyEvent(Event);
  569.       if Event.What = evNothing then Idle;
  570.     end;
  571.   end;
  572.   if StatusLine <> nil then
  573.     if (Event.What and evKeyDown <> 0) or
  574.       (Event.What and evMouseDown <> 0) and
  575.       (FirstThat(@ContainsMouse) = PView(StatusLine)) then
  576.       StatusLine^.HandleEvent(Event);
  577. end;
  578.  
  579. function TProgram.GetPalette: PPalette;
  580. const
  581.   P: array[apColor..apMonochrome] of string[Length(CAppColor)] =
  582.     (CAppColor, CAppBlackWhite, CAppMonochrome);
  583. begin
  584.   GetPalette := @P[AppPalette];
  585. end;
  586.  
  587. procedure TProgram.HandleEvent(var Event: TEvent);
  588. var
  589.   I: Word;
  590.   C: Char;
  591. begin
  592.   if Event.What = evKeyDown then
  593.   begin
  594.     C := GetAltChar(Event.KeyCode);
  595.     if (C >= '1') and (C <= '9') then
  596.       if Message(Desktop, evBroadCast, cmSelectWindowNum,
  597.         Pointer(Byte(C) - $30)) <> nil then ClearEvent(Event);
  598.   end;
  599.   TGroup.HandleEvent(Event);
  600.   if Event.What = evCommand then
  601.     if Event.Command = cmQuit then
  602.     begin
  603.       EndModal(cmQuit);
  604.       ClearEvent(Event);
  605.     end;
  606. end;
  607.  
  608. procedure TProgram.Idle;
  609. begin
  610.   if StatusLine <> nil then StatusLine^.Update;
  611.   if CommandSetChanged then
  612.   begin
  613.     Message(@Self, evBroadcast, cmCommandSetChanged, nil);
  614.     CommandSetChanged := False;
  615.   end;
  616.   SysCtrlSleep(1);
  617. end;
  618.  
  619. procedure TProgram.InitDesktop;
  620. var
  621.   R: TRect;
  622. begin
  623.   GetExtent(R);
  624.   Inc(R.A.Y);
  625.   Dec(R.B.Y);
  626.   New(Desktop, Init(R));
  627. end;
  628.  
  629. procedure TProgram.InitMenuBar;
  630. var
  631.   R: TRect;
  632. begin
  633.   GetExtent(R);
  634.   R.B.Y := R.A.Y + 1;
  635.   MenuBar := New(PMenuBar, Init(R, nil));
  636. end;
  637.  
  638. procedure TProgram.InitScreen;
  639. begin
  640.   if Lo(ScreenMode) <> smMono then
  641.   begin
  642.     if ScreenMode and smFont8x8 <> 0 then
  643.       ShadowSize.X := 1 else
  644.       ShadowSize.X := 2;
  645.     ShadowSize.Y := 1;
  646.     ShowMarkers := False;
  647.     if Lo(ScreenMode) = smBW80 then
  648.       AppPalette := apBlackWhite else
  649.       AppPalette := apColor;
  650.   end else
  651.   begin
  652.     ShadowSize.X := 0;
  653.     ShadowSize.Y := 0;
  654.     ShowMarkers := True;
  655.     AppPalette := apMonochrome;
  656.   end;
  657. end;
  658.  
  659. procedure TProgram.InitStatusLine;
  660. var
  661.   R: TRect;
  662. begin
  663.   GetExtent(R);
  664.   R.A.Y := R.B.Y - 1;
  665.   New(StatusLine, Init(R,
  666.     NewStatusDef(0, $FFFF,
  667.       NewStatusKey('~Alt-X~ Exit', kbAltX, cmQuit,
  668.       StdStatusKeys(nil)), nil)));
  669. end;
  670.  
  671. function TProgram.InsertWindow(P: PWindow): PWindow;
  672. begin
  673.   InsertWindow := nil;
  674.   if ValidView(P) <> nil then
  675.     if CanMoveFocus then
  676.     begin
  677.       Desktop^.Insert(P);
  678.       InsertWindow := P;
  679.     end
  680.     else
  681.       Dispose(P, Done);
  682. end;
  683.  
  684. procedure TProgram.OutOfMemory;
  685. begin
  686. end;
  687.  
  688. procedure TProgram.PutEvent(var Event: TEvent);
  689. begin
  690.   Pending := Event;
  691. end;
  692.  
  693. procedure TProgram.Run;
  694. begin
  695.   Execute;
  696. end;
  697.  
  698. procedure TProgram.SetScreenMode(Mode: Word);
  699. var
  700.   R: TRect;
  701. begin
  702.   HideMouse;
  703.   SetVideoMode(Mode);
  704.   DoneMemory;
  705.   InitMemory;
  706.   InitScreen;
  707.   Buffer := ScreenBuffer;
  708.   R.Assign(0, 0, ScreenWidth, ScreenHeight);
  709.   ChangeBounds(R);
  710.   ShowMouse;
  711. end;
  712.  
  713. function TProgram.ValidView(P: PView): PView;
  714. begin
  715.   ValidView := nil;
  716.   if P <> nil then
  717.   begin
  718.     if LowMemory then
  719.     begin
  720.       Dispose(P, Done);
  721.       OutOfMemory;
  722.       Exit;
  723.     end;
  724.     if not P^.Valid(cmValid) then
  725.     begin
  726.       Dispose(P, Done);
  727.       Exit;
  728.     end;
  729.     ValidView := P;
  730.   end;
  731. end;
  732.  
  733. { TApplication }
  734.  
  735. constructor TApplication.Init;
  736. begin
  737.   InitMemory;
  738.   InitVideo;
  739.   InitEvents;
  740.   InitSysError;
  741.   InitHistory;
  742.   TProgram.Init;
  743. end;
  744.  
  745. destructor TApplication.Done;
  746. begin
  747.   TProgram.Done;
  748.   DoneHistory;
  749.   DoneSysError;
  750.   DoneEvents;
  751.   DoneVideo;
  752.   DoneMemory;
  753. end;
  754.  
  755. procedure TApplication.Cascade;
  756. var
  757.   R: TRect;
  758. begin
  759.   GetTileRect(R);
  760.   if Desktop <> nil then Desktop^.Cascade(R);
  761. end;
  762.  
  763. procedure TApplication.DosShell;
  764. var
  765.   x,y: SmallWord;
  766. begin
  767.   DoneSysError;
  768.   DoneEvents;
  769.   DoneVideo;
  770.   DoneDosMem;
  771.   WriteShellMsg;
  772.   // Force update of cursor prior to shell
  773.   SysGetCurPos(x,y);
  774.   SysTVSetCurPos(x,y);
  775.   Exec(GetEnv('COMSPEC'), '');
  776.   InitDosMem;
  777.   InitVideo;
  778.   InitKeyboard;
  779.   InitEvents;
  780.   InitSysError;
  781.   Redraw;
  782. end;
  783.  
  784. procedure TApplication.GetTileRect(var R: TRect);
  785. begin
  786.   Desktop^.GetExtent(R);
  787. end;
  788.  
  789. procedure TApplication.HandleEvent(var Event: TEvent);
  790. begin
  791.   inherited HandleEvent(Event);
  792.   case Event.What of
  793.     evCommand:
  794.       begin
  795.         case Event.Command of
  796.           cmTile: Tile;
  797.           cmCascade: Cascade;
  798.           cmDosShell: DosShell;
  799.         else
  800.           Exit;
  801.         end;
  802.         ClearEvent(Event);
  803.       end;
  804.   end;
  805. end;
  806.  
  807. procedure TApplication.Tile;
  808. var
  809.   R: TRect;
  810. begin
  811.   GetTileRect(R);
  812.   if Desktop <> nil then Desktop^.Tile(R);
  813. end;
  814.  
  815. procedure TApplication.WriteShellMsg;
  816. begin
  817.   PrintStr(#13#10'Type EXIT to return...'#13#10);
  818. end;
  819.  
  820. { App registration procedure }
  821.  
  822. procedure RegisterApp;
  823. begin
  824.   RegisterType(RBackground);
  825.   RegisterType(RDesktop);
  826. end;
  827.  
  828. { Standard menus and status lines }
  829.  
  830. function StdStatusKeys(Next: PStatusItem): PStatusItem;
  831. begin
  832.   StdStatusKeys :=
  833.     NewStatusKey('', kbAltX, cmQuit,
  834.     NewStatusKey('', kbF10, cmMenu,
  835.     NewStatusKey('', kbAltF3, cmClose,
  836.     NewStatusKey('', kbF5, cmZoom,
  837.     NewStatusKey('', kbCtrlF5, cmResize,
  838.     NewStatusKey('', kbF6, cmNext,
  839.     NewStatusKey('', kbShiftF6, cmPrev,
  840.     Next)))))));
  841. end;
  842.  
  843. function StdFileMenuItems(Next: PMenuItem): PMenuItem;
  844. begin
  845.   StdFileMenuItems :=
  846.     NewItem('~N~ew', '', kbNoKey, cmNew, hcNew,
  847.     NewItem('~O~pen...', 'F3', kbF3, cmOpen, hcOpen,
  848.     NewItem('~S~ave', 'F2', kbF2, cmSave, hcSave,
  849.     NewItem('S~a~ve as...', '', kbNoKey, cmSaveAs, hcSaveAs,
  850.     NewItem('Save a~l~l', '', kbNoKey, cmSaveAll, hcSaveAll,
  851.     NewLine(
  852.     NewItem('~C~hange dir...', '', kbNoKey, cmChangeDir, hcChangeDir,
  853.     NewItem('~D~OS shell', '', kbNoKey, cmDosShell, hcDosShell,
  854.     NewItem('E~x~it', 'Alt+X', kbAltX, cmQuit, hcExit,
  855.     Next)))))))));
  856. end;
  857.  
  858. function StdEditMenuItems(Next: PMenuItem): PMenuItem;
  859. begin
  860.   StdEditMenuItems :=
  861.     NewItem('~U~ndo', '', kbAltBack, cmUndo, hcUndo,
  862.     NewLine(
  863.     NewItem('Cu~t~', 'Shift+Del', kbShiftDel, cmCut, hcCut,
  864.     NewItem('~C~opy', 'Ctrl+Ins', kbCtrlIns, cmCopy, hcCopy,
  865.     NewItem('~P~aste', 'Shift+Ins', kbShiftIns, cmPaste, hcPaste,
  866.     NewItem('C~l~ear', 'Ctrl+Del', kbCtrlDel, cmClear, hcClear,
  867.     Next))))));
  868. end;
  869.  
  870. function StdWindowMenuItems(Next: PMenuItem): PMenuItem;
  871. begin
  872.   StdWindowMenuItems :=
  873.     NewItem('~T~ile', '', kbNoKey, cmTile, hcTile,
  874.     NewItem('C~a~scade', '', kbNoKey, cmCascade, hcCascade,
  875.     NewItem('Cl~o~se all', '', kbNoKey, cmCloseAll, hcCloseAll,
  876.     NewLine(
  877.     NewItem('~S~ize/Move','Ctrl+F5', kbCtrlF5, cmResize, hcResize,
  878.     NewItem('~Z~oom', 'F5', kbF5, cmZoom, hcZoom,
  879.     NewItem('~N~ext', 'F6', kbF6, cmNext, hcNext,
  880.     NewItem('~P~revious', 'Shift+F6', kbShiftF6, cmPrev, hcPrev,
  881.     NewItem('~C~lose', 'Alt+F3', kbAltF3, cmClose, hcClose,
  882.     Next)))))))));
  883. end;
  884.  
  885. end.
  886.