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