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