freepascal.compiler/fv/test/testapp.pas

PROGRAM TestApp;

{ $UNDEF OS2PM}

{$IFDEF OS2PM}
 {&PMTYPE PM}                                          { FULL GUI MODE }
{$ENDIF OS2PM}

{ ******************************* REMARK ****************************** }
{  This is a basic test program to test the app framework. In use will  }
{  be menus, statuslines, windows, dialogs, scrollbars, statictext,     }
{  radiobuttons, check boxes, list boxes and input lines.               }
{                                                                       }
{  Working compilers:                                                   }
{     WINDOWS BPW, VP2, Delphi1, FPC WIN (0.9912)                       }
{     DOS has draw bugs but works for BP and FPC DOS (GO32V2)           }
{     OS2 dows not work still some PM bits to do                        }
{                                                                       }
{  Not working:                                                         }
{     Delphi3, Delphi5 (sus 4) will compile but Tgroup.ForEach etc U/S. }
{     Sybil2 Win32 should work but to big for demo mode so unsure!      }
{                                                                       }
{  Special things to try out:                                           }
{    Check out the standard windows minimize etc icons.                 }
{                                                                       }
{                                                                       }
{  Comments:                                                            }
{    There is alot that may seem more complex than it needs to but      }
{    I have much more elaborate objects operating such as bitmaps,      }
{    bitmap buttons, percentage bars etc and they need these hooks.     }
{    Basically the intention is to be able to port existing TV apps     }
{    as a start point and then start to optimize and use the new        }
{    GUI specific objects. I will try to get some documentation         }
{    done on how everything works because some things are hard to       }
{    follow in windows.                                                 }
{ ****************************** END REMARK *** Leon de Boer, 06Nov99 * }

{$I Platform.inc}
  USES
{$IFDEF OS2PM}
     {$IFDEF OS_OS2} Os2Def, os2PmApi,  {$ENDIF}
{$ENDIF OS2PM}
     Objects, Drivers, Views, Menus, Dialogs, App,             { Standard GFV units }
     FVConsts,
     {$ifdef TEST}
     AsciiTab,
     {$endif TEST}
     {$ifdef DEBUG}
     Gfvgraph,
     {$endif DEBUG}
     Gadgets, TimedDlg, MsgBox;


CONST cmAppToolbar = 1000;
      cmWindow1    = 1001;
      cmWindow2    = 1002;
      cmWindow3    = 1003;
      cmTimedBox   = 1004;
      cmAscii      = 1010;
      cmCloseWindow1    = 1101;
      cmCloseWindow2    = 1102;
      cmCloseWindow3    = 1103;

{---------------------------------------------------------------------------}
{          TTestAppp OBJECT - STANDARD APPLICATION WITH MENU                }
{---------------------------------------------------------------------------}
TYPE
   PTVDemo = ^TTVDemo;
   TTVDemo = OBJECT (TApplication)
        Clock: PClockView;
        Heap: PHeapView;
        P1,P2,P3 : PGroup;
     {$ifdef TEST}
        ASCIIChart : PAsciiChart;
     {$endif TEST}
      CONSTRUCTOR Init;
      PROCEDURE Idle; Virtual;
      PROCEDURE HandleEvent(var Event : TEvent);virtual;
      PROCEDURE InitMenuBar; Virtual;
      PROCEDURE InitDeskTop; Virtual;
      PROCEDURE Window1;
      PROCEDURE Window2;
      PROCEDURE Window3;
      PROCEDURE TimedBox;
      PROCEDURE AsciiWindow;
      PROCEDURE CloseWindow(var P : PGroup);
    End;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                           TTvDemo OBJECT METHODS                          }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

CONSTRUCTOR TTvDemo.Init;
VAR R: TRect;
BEGIN
  Inherited Init;
  { Initialize demo gadgets }

  GetExtent(R);
  R.A.X := R.B.X - 9; R.B.Y := R.A.Y + 1;
  Clock := New(PClockView, Init(R));
  Insert(Clock);

  GetExtent(R);
  Dec(R.B.X);
  R.A.X := R.B.X - 12; R.A.Y := R.B.Y - 1;
  Heap := New(PHeapView, Init(R));
  Insert(Heap);
END;

procedure TTVDemo.Idle;

function IsTileable(P: PView): Boolean; far;
begin
  IsTileable := (P^.Options and ofTileable <> 0) and
    (P^.State and sfVisible <> 0);
end;

{$ifdef DEBUG}
Var
   WasSet : boolean;
{$endif DEBUG}
begin
  inherited Idle;
{$ifdef DEBUG}
   if WriteDebugInfo then
     begin
      WasSet:=true;
      WriteDebugInfo:=false;
     end
   else
      WasSet:=false;
   if WriteDebugInfo then
{$endif DEBUG}
  Clock^.Update;
  Heap^.Update;
{$ifdef DEBUG}
   if WasSet then
     WriteDebugInfo:=true;
{$endif DEBUG}
  if Desktop^.FirstThat(@IsTileable) <> nil then
    EnableCommands([cmTile, cmCascade])
  else
    DisableCommands([cmTile, cmCascade]);
end;

PROCEDURE TTVDemo.HandleEvent(var Event : TEvent);
BEGIN
   Inherited HandleEvent(Event);                      { Call ancestor }
   If (Event.What = evCommand) Then Begin
     Case Event.Command Of
       cmWindow1 : Window1;
       cmWindow2 : Window2;
       cmWindow3 : Window3;
       cmTimedBox: TimedBox;
       cmAscii   : AsciiWindow;
       cmCloseWindow1 : CloseWindow(P1);
       cmCloseWindow2 : CloseWindow(P2);
       cmCloseWindow3 : CloseWindow(P3);
       Else Exit;                                     { Unhandled exit }
     End;
   End;
   ClearEvent(Event);
END;

{--TTvDemo------------------------------------------------------------------}
{  InitMenuBar -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 05Nov99 LdB       }
{---------------------------------------------------------------------------}
PROCEDURE TTVDemo.InitMenuBar;
VAR R: TRect;
BEGIN
   GetExtent(R);                                      { Get view extents }
   R.B.Y := R.A.Y + 1;                                { One line high  }
   MenuBar := New(PMenuBar, Init(R, NewMenu(
    NewSubMenu('~F~ile', 0, NewMenu(
      StdFileMenuItems(Nil)),                         { Standard file menu }
    NewSubMenu('~E~dit', 0, NewMenu(
      StdEditMenuItems(Nil)),                         { Standard edit menu }
    NewSubMenu('~T~est', 0, NewMenu(
      NewItem('Ascii Chart','',kbNoKey,cmAscii,hcNoContext,
      NewItem('Window 1','',kbNoKey,cmWindow1,hcNoContext,
      NewItem('Window 2','',kbNoKey,cmWindow2,hcNoContext,
      NewItem('Window 3','',kbNoKey,cmWindow3,hcNoContext,
      NewItem('Timed Box','',kbNoKey,cmTimedBox,hcNoContext,
      NewItem('Close Window 1','',kbNoKey,cmCloseWindow1,hcNoContext,
      NewItem('Close Window 2','',kbNoKey,cmCloseWindow2,hcNoContext,
      NewItem('Close Window 3','',kbNoKey,cmCloseWindow3,hcNoContext,
      Nil))))))))),
    NewSubMenu('~W~indow', 0, NewMenu(
      StdWindowMenuItems(Nil)), Nil)))))));            { Standard window  menu }
END;

{--TTvDemo------------------------------------------------------------------}
{  InitDesktop -> Platforms DOS/DPMI/WIN/NT/OS2 - Updated 08Nov99 LdB       }
{---------------------------------------------------------------------------}
PROCEDURE TTvDemo.InitDesktop;
VAR R: TRect; {ToolBar: PToolBar;}
BEGIN
   GetExtent(R);                                      { Get app extents }
   Inc(R.A.Y);               { Adjust top down }
   Dec(R.B.Y);            { Adjust bottom up }
(*   ToolBar := New(PToolBar, Init(R.A.X*FontWidth,
     R.A.Y*FontHeight, (R.B.X-R.A.X)*FontWidth, 20,
     cmAppToolBar));
   If (ToolBar <> Nil) Then Begin
     R.A.X := R.A.X*FontWidth;
     R.A.Y := R.A.Y*FontHeight + 25;
     R.B.X := -R.B.X*FontWidth;
     R.B.Y := -R.B.Y*Fontheight;
     ToolBar^.AddTool(NewToolEntry(cmQuit, True,
       '20X20EXIT', 'ToolBar.Res'));
     ToolBar^.AddTool(NewToolEntry(cmNew, True,
       '20X20NEW', 'ToolBar.Res'));
     ToolBar^.AddTool(NewToolEntry(cmOpen, True,
       '20X20LOAD', 'ToolBar.Res'));
     Insert(ToolBar);
   End;*)
   Desktop := New(PDeskTop, Init(R));
END;

PROCEDURE TTvDemo.Window1;
VAR R: TRect; P: PGroup;
BEGIN
   { Create a basic window with static text and radio }
   { buttons. The buttons should be orange and white  }
   R.Assign(5, 1, 35, 16);                            { Assign area }
   P := New(PWindow, Init(R, 'TEST WINDOW 1', 1));    { Create a window }
   If (P <> Nil) Then Begin                           { Window valid }
     R.Assign(5, 5, 20, 6);                           { Assign area }
     P^.Insert(New(PInputLine, Init(R, 30)));
     R.Assign(5, 8, 20, 9);                           { Assign area }
     P^.Insert(New(PRadioButtons, Init(R,
       NewSItem('Test',
       NewSITem('Item 2', Nil)))));                   { Red radio button }
     R.Assign(5, 10, 28, 11);                         { Assign area }
     P^.Insert(New(PStaticText, Init(R,
       'SOME STATIC TEXT')));                         { Insert static text }
   End;
   Desktop^.Insert(P);                                { Insert into desktop }
   P1:=P;
END;

PROCEDURE TTvDemo.AsciiWindow;
begin
{$ifdef TEST}
  if ASCIIChart=nil then
    begin
      New(ASCIIChart, Init);
      Desktop^.Insert(ASCIIChart);
    end
  else
    ASCIIChart^.Focus;
{$endif TEST}
end;


PROCEDURE TTvDemo.TimedBox;
var
  X: longint;
  S: string;
begin
  X := TimedMessageBox ('Everything OK?', nil, mfConfirmation or mfOKCancel, 10);
  case X of
   cmCancel: MessageBox ('cmCancel', nil, mfOKButton);
   cmOK: MessageBox ('cmOK', nil, mfOKButton);
  else
   begin
    Str (X, S);
    MessageBox (S, nil, mfOKButton);
   end;
  end;
end;

PROCEDURE TTvDemo.CloseWindow(var P : PGroup);
BEGIN
  If Assigned(P) then
    BEGIN
      Desktop^.Delete(P);
      Dispose(P,Done);
      P:=Nil;
    END;
END;
PROCEDURE TTvDemo.Window2;
VAR R: TRect; P: PGroup;
BEGIN
   { Create a basic window with check boxes. The  }
   { check boxes should be orange and white       }
   R.Assign(15, 3, 45, 18);                           { Assign area }
   P := New(PWindow, Init(R, 'TEST WINDOW 2', 2));    { Create window 2 }
   If (P <> Nil) Then Begin                           { Window valid }
     R.Assign(5, 5, 20, 7);                           { Assign area }
     P^.Insert(New(PCheckBoxes, Init(R,
       NewSItem('Test check',
       NewSITem('Item 2', Nil)))));                   { Create check box }
   End;
   Desktop^.Insert(P);                                { Insert into desktop }
   P2:=P;
END;

PROCEDURE TTvDemo.Window3;
VAR R: TRect; P: PGroup; B: PScrollBar;
    List: PStrCollection; Lb: PListBox;
BEGIN
   { Create a basic dialog box. In it are buttons,  }
   { list boxes, scrollbars, inputlines, checkboxes }
   R.Assign(32, 2, 77, 18);                           { Assign screen area }
   P := New(PDialog, Init(R, 'TEST DIALOG'));         { Create dialog }
   If (P <> Nil) Then Begin                           { Dialog valid }
     R.Assign(5, 5, 20, 7);                          { Allocate area }
     P^.Insert(New(PCheckBoxes, Init(R,
       NewSItem('Test',
       NewSITem('Item 2', Nil)))));                   { Insert check box }
     R.Assign(5, 2, 20, 3);                           { Assign area }
     B := New(PScrollBar, Init(R));                   { Insert scroll bar }
     If (B <> Nil) Then Begin                         { Scrollbar valid }
       B^.SetRange(0, 100);                           { Set scrollbar range }
       B^.SetValue(50);                               { Set position }
       P^.Insert(B);                                  { Insert scrollbar }
     End;
     R.Assign(5, 10, 20, 11);                         { Assign area }
     P^.Insert(New(PInputLine, Init(R, 60)));         { Create input line }
     R.Assign(5, 13, 20, 14);                         { Assign area }
     P^.Insert(New(PInputLine, Init(R, 60)));         { Create input line }
     R.Assign(40, 8, 41, 14);                         { Assign area }
     B := New(PScrollBar, Init(R));                   { Create scrollbar }
     P^.Insert(B);                                    { Insert scrollbar }
     R.Assign(25, 8, 40, 14);                         { Assign area }
     Lb := New(PListBox, Init(R, 1, B));              { Create listbox }
     P^.Insert(Lb);                                   { Insert listbox }
     List := New(PStrCollection, Init(10, 5));        { Create string list }
     List^.AtInsert(0, NewStr('Zebra'));              { Insert text }
     List^.AtInsert(1, NewStr('Apple'));              { Insert text }
     List^.AtInsert(2, NewStr('Third'));              { Insert text }
     List^.AtInsert(3, NewStr('Peach'));              { Insert text }
     List^.AtInsert(4, NewStr('Rabbit'));             { Insert text }
     List^.AtInsert(5, NewStr('Item six'));           { Insert text }
     List^.AtInsert(6, NewStr('Jaguar'));             { Insert text }
     List^.AtInsert(7, NewStr('Melon'));              { Insert text }
     List^.AtInsert(8, NewStr('Ninth'));              { Insert text }
     List^.AtInsert(9, NewStr('Last item'));          { Insert text }
     Lb^.Newlist(List);                               { Give list to listbox }
     R.Assign(30, 2, 40, 4);                          { Assign area }
     P^.Insert(New(PButton, Init(R, '~O~k', 100, bfGrabFocus)));{ Create okay button }
     R.Assign(30, 15, 40, 17);                        { Assign area }
     Desktop^.Insert(P);                              { Insert dialog }
     P3:=P;
   End;
END;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                             MAIN PROGRAM START                            }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
VAR I: Integer; R: TRect; P: PGroup; MyApp: TTvDemo;
{$IFDEF OS2PM}
    {$IFDEF OS_OS2} Message: QMSg; Event: TEvent; {$ENDIF}
{$ENDIF OS2PM}
BEGIN
   (*SystemPalette := CreateRGBPalette(256);            { Create palette }
   For I := 0 To 15 Do Begin
     GetSystemRGBEntry(I, RGB);                       { Get palette entry }
     AddToRGBPalette(RGB, SystemPalette);             { Add entry to palette }
   End;*)

   MyApp.Init;                                        { Initialize app }


   MyApp.Run;                                         { Run the app }
{$IFDEF OS2PM}
   {$IFDEF OS_OS2}
   while (MyApp.EndState = 0)
   AND WinGetMsg(Anchor, Message, 0, 0, 0) Do Begin
       WinDispatchMsg(Anchor, Message);
       NextQueuedEvent(Event);
       If (event.What <>  evNothing)
         Then MyApp.handleEvent(Event);
   End;
   {$ENDIF}
{$ENDIF OS2PM}
   MyApp.Done;                                        { Dispose of app }

   {DisposeRGBPalette(SystemPalette);}
END.