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