home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Pascal / BPASCAL.700 / D11 / TVSRC.ZIP / APP.PAS next >
Encoding:
Pascal/Delphi Source File  |  1992-10-01  |  20.7 KB  |  876 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.   RBackground: TStreamRec = (
  225.     ObjType: 30;
  226.     VmtLink: Ofs(TypeOf(TBackground)^);
  227.     Load: @TBackground.Load;
  228.     Store: @TBackground.Store);
  229.  
  230.   RDesktop: TStreamRec = (
  231.     ObjType: 31;
  232.     VmtLink: Ofs(TypeOf(TDesktop)^);
  233.     Load: @TDesktop.Load;
  234.     Store: @TDesktop.Store);
  235.  
  236. implementation
  237.  
  238. uses Dos;
  239.  
  240. const
  241.  
  242. { Private variables }
  243.  
  244.   Pending: TEvent = (What: evNothing);
  245.  
  246. { TBackground }
  247.  
  248. constructor TBackground.Init(var Bounds: TRect; APattern: Char);
  249. begin
  250.   TView.Init(Bounds);
  251.   GrowMode := gfGrowHiX + gfGrowHiY;
  252.   Pattern := APattern;
  253. end;
  254.  
  255. constructor TBackground.Load(var S: TStream);
  256. begin
  257.   TView.Load(S);
  258.   S.Read(Pattern, SizeOf(Pattern));
  259. end;
  260.  
  261. procedure TBackground.Draw;
  262. var
  263.   B: TDrawBuffer;
  264. begin
  265.   MoveChar(B, Pattern, GetColor($01), Size.X);
  266.   WriteLine(0, 0, Size.X, Size.Y, B);
  267. end;
  268.  
  269. function TBackground.GetPalette: PPalette;
  270. const
  271.   P: string[Length(CBackground)] = CBackground;
  272. begin
  273.   GetPalette := @P;
  274. end;
  275.  
  276. procedure TBackground.Store(var S: TStream);
  277. begin
  278.   TView.Store(S);
  279.   S.Write(Pattern, SizeOf(Pattern));
  280. end;
  281.  
  282. { TDesktop object }
  283.  
  284. constructor TDesktop.Init(var Bounds: TRect);
  285. begin
  286.   inherited Init(Bounds);
  287.   GrowMode := gfGrowHiX + gfGrowHiY;
  288.   InitBackground;
  289.   if Background <> nil then Insert(Background);
  290. end;
  291.  
  292. constructor TDesktop.Load(var S: TStream);
  293. begin
  294.   inherited Load(S);
  295.   GetSubViewPtr(S, Background);
  296.   S.Read(TileColumnsFirst, SizeOf(TileColumnsFirst));
  297. end;
  298.  
  299. function Tileable(P: PView): Boolean;
  300. begin
  301.   Tileable := (P^.Options and ofTileable <> 0) and
  302.     (P^.State and sfVisible <> 0);
  303. end;
  304.  
  305. procedure TDesktop.Cascade(var R: TRect);
  306. var
  307.   CascadeNum: Integer;
  308.   LastView: PView;
  309.   Min, Max: TPoint;
  310.  
  311.  
  312. procedure DoCount(P: PView); far;
  313. begin
  314.   if Tileable(P) then
  315.   begin
  316.     Inc(CascadeNum);
  317.     LastView := P;
  318.   end;
  319. end;
  320.  
  321. procedure DoCascade(P: PView); far;
  322. var
  323.   NR: TRect;
  324. begin
  325.   if Tileable(P) and (CascadeNum >= 0) then
  326.   begin
  327.     NR.Copy(R);
  328.     Inc(NR.A.X, CascadeNum); Inc(NR.A.Y, CascadeNum);
  329.     P^.Locate(NR);
  330.     Dec(CascadeNum);
  331.   end;
  332. end;
  333.  
  334. begin
  335.   CascadeNum := 0;
  336.   ForEach(@DoCount);
  337.   if CascadeNum > 0 then
  338.   begin
  339.     LastView^.SizeLimits(Min, Max);
  340.     if (Min.X > R.B.X - R.A.X - CascadeNum) or
  341.        (Min.Y > R.B.Y - R.A.Y - CascadeNum) then TileError
  342.     else
  343.     begin
  344.       Dec(CascadeNum);
  345.       Lock;
  346.       ForEach(@DoCascade);
  347.       Unlock;
  348.     end;
  349.   end;
  350. end;
  351.  
  352. procedure TDesktop.HandleEvent(var Event: TEvent);
  353. begin
  354.   TGroup.HandleEvent(Event);
  355.   if Event.What = evCommand then
  356.   begin
  357.     case Event.Command of
  358.       cmNext: FocusNext(False);
  359.       cmPrev:
  360.         if Valid(cmReleasedFocus) then
  361.           Current^.PutInFrontOf(Background);
  362.     else
  363.       Exit;
  364.     end;
  365.     ClearEvent(Event);
  366.   end;
  367. end;
  368.  
  369. procedure TDesktop.InitBackground;
  370. var
  371.   R: TRect;
  372. begin
  373.   GetExtent(R);
  374.   New(Background, Init(R, #176));
  375. end;
  376.  
  377. function ISqr(X: Integer): Integer; assembler;
  378. asm
  379.     MOV    CX,X
  380.         MOV    BX,0
  381. @@1:    INC     BX
  382.     MOV    AX,BX
  383.     IMUL    AX
  384.         CMP    AX,CX
  385.         JLE    @@1
  386.     MOV    AX,BX
  387.         DEC     AX
  388. end;
  389.  
  390. procedure MostEqualDivisors(N: Integer; var X, Y: Integer; FavorY: Boolean);
  391. var
  392.   I: Integer;
  393. begin
  394.   I := ISqr(N);
  395.   if ((N mod I) <> 0) then
  396.     if (N mod (I+1)) = 0 then Inc(I);
  397.   if I < (N div I) then I := N div I;
  398.   if FavorY then
  399.   begin
  400.     X := N div I;
  401.     Y := I;
  402.   end
  403.   else
  404.   begin
  405.     Y := N div I;
  406.     X := I;
  407.   end;
  408. end;
  409.  
  410. procedure TDesktop.Store(var S: TStream);
  411. begin
  412.   inherited Store(S);
  413.   PutSubViewPtr(S, Background);
  414.   S.Write(TileColumnsFirst, SizeOf(TileColumnsFirst));
  415. end;
  416.  
  417. procedure TDesktop.Tile(var R: TRect);
  418. var
  419.   NumCols, NumRows, NumTileable, LeftOver, TileNum: Integer;
  420.  
  421. procedure DoCountTileable(P: PView); far;
  422. begin
  423.   if Tileable(P) then Inc(NumTileable);
  424. end;
  425.  
  426. function DividerLoc(Lo, Hi, Num, Pos: Integer): Integer;
  427. begin
  428.   DividerLoc := LongDiv(LongMul(Hi - Lo, Pos), Num) + Lo;
  429. end;
  430.  
  431. procedure CalcTileRect(Pos: Integer; var NR: TRect);
  432. var
  433.   X,Y,D: Integer;
  434. begin
  435.   D := (NumCols - LeftOver) * NumRows;
  436.   if Pos < D then
  437.   begin
  438.     X := Pos div NumRows;
  439.     Y := Pos mod NumRows;
  440.   end else
  441.   begin
  442.     X := (Pos - D) div (NumRows + 1) + (NumCols - LeftOver);
  443.     Y := (Pos - D) mod (NumRows + 1);
  444.   end;
  445.   NR.A.X := DividerLoc(R.A.X, R.B.X, NumCols, X);
  446.   NR.B.X := DividerLoc(R.A.X, R.B.X, NumCols, X+1);
  447.   if Pos >= D then
  448.   begin
  449.     NR.A.Y := DividerLoc(R.A.Y, R.B.Y, NumRows+1, Y);
  450.     NR.B.Y := DividerLoc(R.A.Y, R.B.Y, NumRows+1, Y+1);
  451.   end else
  452.   begin
  453.     NR.A.Y := DividerLoc(R.A.Y, R.B.Y, NumRows, Y);
  454.     NR.B.Y := DividerLoc(R.A.Y, R.B.Y, NumRows, Y+1);
  455.   end;
  456. end;
  457.  
  458. procedure DoTile(P: PView); far;
  459. var
  460.   R: TRect;
  461. begin
  462.   if Tileable(P) then
  463.   begin
  464.     CalcTileRect(TileNum, R);
  465.     P^.Locate(R);
  466.     Dec(TileNum);
  467.   end;
  468. end;
  469.  
  470. begin
  471.   NumTileable := 0;
  472.   ForEach(@DoCountTileable);
  473.   if NumTileable > 0 then
  474.   begin
  475.     MostEqualDivisors(NumTileable, NumCols, NumRows, not TileColumnsFirst);
  476.     if ((R.B.X - R.A.X) div NumCols = 0) or
  477.        ((R.B.Y - R.A.Y) div NumRows = 0) then TileError
  478.     else
  479.     begin
  480.       LeftOver := NumTileable mod NumCols;
  481.       TileNum := NumTileable-1;
  482.       Lock;
  483.       ForEach(@DoTile);
  484.       Unlock;
  485.     end;
  486.   end;
  487. end;
  488.  
  489. procedure TDesktop.TileError;
  490. begin
  491. end;
  492.  
  493. { TProgram }
  494.  
  495. constructor TProgram.Init;
  496. var
  497.   R: TRect;
  498. begin
  499.   Application := @Self;
  500.   InitScreen;
  501.   R.Assign(0, 0, ScreenWidth, ScreenHeight);
  502.   TGroup.Init(R);
  503.   State := sfVisible + sfSelected + sfFocused + sfModal + sfExposed;
  504.   Options := 0;
  505.   Buffer := ScreenBuffer;
  506.   InitDesktop;
  507.   InitStatusLine;
  508.   InitMenuBar;
  509.   if Desktop <> nil then Insert(Desktop);
  510.   if StatusLine <> nil then Insert(StatusLine);
  511.   if MenuBar <> nil then Insert(MenuBar);
  512. end;
  513.  
  514. destructor TProgram.Done;
  515. begin
  516.   if Desktop <> nil then Dispose(Desktop, Done);
  517.   if MenuBar <> nil then Dispose(MenuBar, Done);
  518.   if StatusLine <> nil then Dispose(StatusLine, Done);
  519.   Application := nil;
  520.   inherited Done;
  521. end;
  522.  
  523. function TProgram.CanMoveFocus: Boolean;
  524. begin
  525.   CanMoveFocus := Desktop^.Valid(cmReleasedFocus);
  526. end;
  527.  
  528. function TProgram.ExecuteDialog(P: PDialog; Data: Pointer): Word;
  529. var
  530.   C: Word;
  531. begin
  532.   ExecuteDialog := cmCancel;
  533.   if ValidView(P) <> nil then
  534.   begin
  535.     if Data <> nil then P^.SetData(Data^);
  536.     C := Desktop^.ExecView(P);
  537.     if (C <> cmCancel) and (Data <> nil) then P^.GetData(Data^);
  538.     Dispose(P, Done);
  539.     ExecuteDialog := C;
  540.   end;
  541. end;
  542.  
  543. procedure TProgram.GetEvent(var Event: TEvent);
  544. var
  545.   R: TRect;
  546.  
  547. function ContainsMouse(P: PView): Boolean; far;
  548. begin
  549.   ContainsMouse := (P^.State and sfVisible <> 0) and
  550.     P^.MouseInView(Event.Where);
  551. end;
  552.  
  553. begin
  554.   if Pending.What <> evNothing then
  555.   begin
  556.     Event := Pending;
  557.     Pending.What := evNothing;
  558.   end else
  559.   begin
  560.     GetMouseEvent(Event);
  561.     if Event.What = evNothing then
  562.     begin
  563.       GetKeyEvent(Event);
  564.       if Event.What = evNothing then Idle;
  565.     end;
  566.   end;
  567.   if StatusLine <> nil then
  568.     if (Event.What and evKeyDown <> 0) or
  569.       (Event.What and evMouseDown <> 0) and
  570.       (FirstThat(@ContainsMouse) = PView(StatusLine)) then
  571.       StatusLine^.HandleEvent(Event);
  572. end;
  573.  
  574. function TProgram.GetPalette: PPalette;
  575. const
  576.   P: array[apColor..apMonochrome] of string[Length(CAppColor)] =
  577.     (CAppColor, CAppBlackWhite, CAppMonochrome);
  578. begin
  579.   GetPalette := @P[AppPalette];
  580. end;
  581.  
  582. procedure TProgram.HandleEvent(var Event: TEvent);
  583. var
  584.   I: Word;
  585.   C: Char;
  586. begin
  587.   if Event.What = evKeyDown then
  588.   begin
  589.     C := GetAltChar(Event.KeyCode);
  590.     if (C >= '1') and (C <= '9') then
  591.       if Message(Desktop, evBroadCast, cmSelectWindowNum,
  592.         Pointer(Byte(C) - $30)) <> nil then ClearEvent(Event);
  593.   end;
  594.   TGroup.HandleEvent(Event);
  595.   if Event.What = evCommand then
  596.     if Event.Command = cmQuit then
  597.     begin
  598.       EndModal(cmQuit);
  599.       ClearEvent(Event);
  600.     end;
  601. end;
  602.  
  603. procedure TProgram.Idle;
  604. begin
  605.   if StatusLine <> nil then StatusLine^.Update;
  606.   if CommandSetChanged then
  607.   begin
  608.     Message(@Self, evBroadcast, cmCommandSetChanged, nil);
  609.     CommandSetChanged := False;
  610.   end;
  611. end;
  612.  
  613. procedure TProgram.InitDesktop;
  614. var
  615.   R: TRect;
  616. begin
  617.   GetExtent(R);
  618.   Inc(R.A.Y);
  619.   Dec(R.B.Y);
  620.   New(Desktop, Init(R));
  621. end;
  622.  
  623. procedure TProgram.InitMenuBar;
  624. var
  625.   R: TRect;
  626. begin
  627.   GetExtent(R);
  628.   R.B.Y := R.A.Y + 1;
  629.   MenuBar := New(PMenuBar, Init(R, nil));
  630. end;
  631.  
  632. procedure TProgram.InitScreen;
  633. begin
  634.   if Lo(ScreenMode) <> smMono then
  635.   begin
  636.     if ScreenMode and smFont8x8 <> 0 then
  637.       ShadowSize.X := 1 else
  638.       ShadowSize.X := 2;
  639.     ShadowSize.Y := 1;
  640.     ShowMarkers := False;
  641.     if Lo(ScreenMode) = smBW80 then
  642.       AppPalette := apBlackWhite else
  643.       AppPalette := apColor;
  644.   end else
  645.   begin
  646.     ShadowSize.X := 0;
  647.     ShadowSize.Y := 0;
  648.     ShowMarkers := True;
  649.     AppPalette := apMonochrome;
  650.   end;
  651. end;
  652.  
  653. procedure TProgram.InitStatusLine;
  654. var
  655.   R: TRect;
  656. begin
  657.   GetExtent(R);
  658.   R.A.Y := R.B.Y - 1;
  659.   New(StatusLine, Init(R,
  660.     NewStatusDef(0, $FFFF,
  661.       NewStatusKey('~Alt-X~ Exit', kbAltX, cmQuit,
  662.       StdStatusKeys(nil)), nil)));
  663. end;
  664.  
  665. function TProgram.InsertWindow(P: PWindow): PWindow;
  666. begin
  667.   InsertWindow := nil;
  668.   if ValidView(P) <> nil then
  669.     if CanMoveFocus then
  670.     begin
  671.       Desktop^.Insert(P);
  672.       InsertWindow := P;
  673.     end
  674.     else
  675.       Dispose(P, Done);
  676. end;
  677.  
  678. procedure TProgram.OutOfMemory;
  679. begin
  680. end;
  681.  
  682. procedure TProgram.PutEvent(var Event: TEvent);
  683. begin
  684.   Pending := Event;
  685. end;
  686.  
  687. procedure TProgram.Run;
  688. begin
  689.   Execute;
  690. end;
  691.  
  692. procedure TProgram.SetScreenMode(Mode: Word);
  693. var
  694.   R: TRect;
  695. begin
  696.   HideMouse;
  697.   SetVideoMode(Mode);
  698.   DoneMemory;
  699.   InitMemory;
  700.   InitScreen;
  701.   Buffer := ScreenBuffer;
  702.   R.Assign(0, 0, ScreenWidth, ScreenHeight);
  703.   ChangeBounds(R);
  704.   ShowMouse;
  705. end;
  706.  
  707. function TProgram.ValidView(P: PView): PView;
  708. begin
  709.   ValidView := nil;
  710.   if P <> nil then
  711.   begin
  712.     if LowMemory then
  713.     begin
  714.       Dispose(P, Done);
  715.       OutOfMemory;
  716.       Exit;
  717.     end;
  718.     if not P^.Valid(cmValid) then
  719.     begin
  720.       Dispose(P, Done);
  721.       Exit;
  722.     end;
  723.     ValidView := P;
  724.   end;
  725. end;
  726.  
  727. { TApplication }
  728.  
  729. constructor TApplication.Init;
  730. begin
  731.   InitMemory;
  732.   InitVideo;
  733.   InitEvents;
  734.   InitSysError;
  735.   InitHistory;
  736.   TProgram.Init;
  737. end;
  738.  
  739. destructor TApplication.Done;
  740. begin
  741.   TProgram.Done;
  742.   DoneHistory;
  743.   DoneSysError;
  744.   DoneEvents;
  745.   DoneVideo;
  746.   DoneMemory;
  747. end;
  748.  
  749. procedure TApplication.Cascade;
  750. var
  751.   R: TRect;
  752. begin
  753.   GetTileRect(R);
  754.   if Desktop <> nil then Desktop^.Cascade(R);
  755. end;
  756.  
  757. procedure TApplication.DosShell;
  758. begin
  759.   DoneSysError;
  760.   DoneEvents;
  761.   DoneVideo;
  762.   DoneDosMem;
  763.   WriteShellMsg;
  764.   SwapVectors;
  765.   Exec(GetEnv('COMSPEC'), '');
  766.   SwapVectors;
  767.   InitDosMem;
  768.   InitVideo;
  769.   InitEvents;
  770.   InitSysError;
  771.   Redraw;
  772. end;
  773.  
  774. procedure TApplication.GetTileRect(var R: TRect);
  775. begin
  776.   Desktop^.GetExtent(R);
  777. end;
  778.  
  779. procedure TApplication.HandleEvent(var Event: TEvent);
  780. begin
  781.   inherited HandleEvent(Event);
  782.   case Event.What of
  783.     evCommand:
  784.       begin
  785.         case Event.Command of
  786.           cmTile: Tile;
  787.           cmCascade: Cascade;
  788.           cmDosShell: DosShell;
  789.         else
  790.           Exit;
  791.         end;
  792.         ClearEvent(Event);
  793.       end;
  794.   end;
  795. end;
  796.  
  797. procedure TApplication.Tile;
  798. var
  799.   R: TRect;
  800. begin
  801.   GetTileRect(R);
  802.   if Desktop <> nil then Desktop^.Tile(R);
  803. end;
  804.  
  805. procedure TApplication.WriteShellMsg;
  806. begin
  807.   PrintStr('Type EXIT to return...');
  808. end;
  809.  
  810. { App registration procedure }
  811.  
  812. procedure RegisterApp;
  813. begin
  814.   RegisterType(RBackground);
  815.   RegisterType(RDesktop);
  816. end;
  817.  
  818. { Standard menus and status lines }
  819.  
  820. function StdStatusKeys(Next: PStatusItem): PStatusItem;
  821. begin
  822.   StdStatusKeys :=
  823.     NewStatusKey('', kbAltX, cmQuit,
  824.     NewStatusKey('', kbF10, cmMenu,
  825.     NewStatusKey('', kbAltF3, cmClose,
  826.     NewStatusKey('', kbF5, cmZoom,
  827.     NewStatusKey('', kbCtrlF5, cmResize,
  828.     NewStatusKey('', kbF6, cmNext,
  829.     NewStatusKey('', kbShiftF6, cmPrev,
  830.     Next)))))));
  831. end;
  832.  
  833. function StdFileMenuItems(Next: PMenuItem): PMenuItem;
  834. begin
  835.   StdFileMenuItems :=
  836.     NewItem('~N~ew', '', kbNoKey, cmNew, hcNew,
  837.     NewItem('~O~pen...', 'F3', kbF3, cmOpen, hcOpen,
  838.     NewItem('~S~ave', 'F2', kbF2, cmSave, hcSave,
  839.     NewItem('S~a~ve as...', '', kbNoKey, cmSaveAs, hcSaveAs,
  840.     NewItem('Save a~l~l', '', kbNoKey, cmSaveAll, hcSaveAll,
  841.     NewLine(
  842.     NewItem('~C~hange dir...', '', kbNoKey, cmChangeDir, hcChangeDir,
  843.     NewItem('~D~OS shell', '', kbNoKey, cmDosShell, hcDosShell,
  844.     NewItem('E~x~it', 'Alt+X', kbAltX, cmQuit, hcExit,
  845.     Next)))))))));
  846. end;
  847.  
  848. function StdEditMenuItems(Next: PMenuItem): PMenuItem;
  849. begin
  850.   StdEditMenuItems :=
  851.     NewItem('~U~ndo', '', kbAltBack, cmUndo, hcUndo,
  852.     NewLine(
  853.     NewItem('Cu~t~', 'Shift+Del', kbShiftDel, cmCut, hcCut,
  854.     NewItem('~C~opy', 'Ctrl+Ins', kbCtrlIns, cmCopy, hcCopy,
  855.     NewItem('~P~aste', 'Shift+Ins', kbShiftIns, cmPaste, hcPaste,
  856.     NewItem('C~l~ear', 'Ctrl+Del', kbCtrlDel, cmClear, hcClear,
  857.     Next))))));
  858. end;
  859.  
  860. function StdWindowMenuItems(Next: PMenuItem): PMenuItem;
  861. begin
  862.   StdWindowMenuItems :=
  863.     NewItem('~T~ile', '', kbNoKey, cmTile, hcTile,
  864.     NewItem('C~a~scade', '', kbNoKey, cmCascade, hcCascade,
  865.     NewItem('Cl~o~se all', '', kbNoKey, cmCloseAll, hcCloseAll,
  866.     NewLine(
  867.     NewItem('~S~ize/Move','Ctrl+F5', kbCtrlF5, cmResize, hcResize,
  868.     NewItem('~Z~oom', 'F5', kbF5, cmZoom, hcZoom,
  869.     NewItem('~N~ext', 'F6', kbF6, cmNext, hcNext,
  870.     NewItem('~P~revious', 'Shift+F6', kbShiftF6, cmPrev, hcPrev,
  871.     NewItem('~C~lose', 'Alt+F3', kbAltF3, cmClose, hcClose,
  872.     Next)))))))));
  873. end;
  874.  
  875. end.
  876.