
{*******************************************************}
{                                                       }
{       Graphics Vision Example program                 }
{                                                       }
{       Copyright (c) 1996 Stefan Milius                }
{                                                       }
{*******************************************************}

(* To run this program you'll have to build EXAM.GVL by:

   GVLC exam.gvl english.gvs englishx.gvs exam.gvs

   Hint: If you want another than the English language just translate all
   the texts in the GVS files into this language and then rebuild EXAM.GVL!
   (Germans only have to translate exam.gvs)

   Besides GVDEMO.DLL must be accessible through the DOS path or be present
   in the current directory

This application shows:

   - usage of listboxes
   - usage of clusters (especially TMultiCheckBox)
   - usage of truetype fonts
   - usage of windows resources

Note that we must use different graphics units for Windows target.
*)

Uses 
  {$ifdef Windows} WinGr, {$else} MyFonts, {$endif}
  Objects, Drivers, KeyNames, GVViews, GVMenus, GVApp, GVDialog,
  GVTexts, GVFonts, WinRes, VGAMem, GVTable, GVCombo;

const

{ Commands }

  cmList = 100; cmCluster = 101;

{ HelpCtx }

  hcDialog = 500;

var
  Res: PStream;

type

{ TGListBox object }

  PGListBox = ^TGListBox;
  TGListBox = object(TListBox)
                Nilhorn, Ghost: Pointer;
                Font: PFont;
                constructor Init(var Bounds: TRect; AScrollBar: PScrollBar);
                destructor Done; virtual;
                procedure DrawItemText(Item: Integer; R: TRect); virtual;
                procedure GetItemRect(Item: Integer; var R: TRect); virtual;
              end;

{ TDemoApp object }

  TDemoApp = object(TApplication)
               constructor Init;
               destructor Done; virtual;
               procedure HandleEvent(var Event: TEvent); virtual;
               procedure InitStatusLine; virtual;
               function LanguageResource: String; virtual;
             private
               TableEntries: PCollection;
             end;

(**************************** TGListBox object ******************************)

constructor TGListBox.Init(var Bounds: TRect; AScrollBar: PScrollBar);
var L: PCollection;
Begin
  inherited Init(Bounds, AScrollBar);
  Nilhorn := LoadBitmapImg(Res^, 'Nilhorn');
  Ghost := LoadBitmapImg(Res^, 'WhiteGhost');
  L := New(PStringCollection, Init(8, 8));
  With L^ do Begin
    AtInsert(Count, NewStr(GetStr(794)));
    AtInsert(Count, NewStr(GetStr(795)));
    AtInsert(Count, NewStr(' '));
    AtInsert(Count, NewStr('Text'));
    AtInsert(Count, NewStr(' '));
    AtInsert(Count, NewStr(GetStr(796)));
    AtInsert(Count, NewStr(' '));
    AtInsert(Count, NewStr('Yeah'));
    AtInsert(Count, NewStr(' '));
  End;
  Font := New(PFont, Init('Times', PixelToScaling(50), ftNormal, nil));
  NewList(L);
  Flags := lfPartialLines;
End;

destructor TGListBox.Done;
var L: LongInt;
Begin
  L := LongInt(Nilhorn^);
  FreeMem(Nilhorn, ImageSize(0, 0, L and $FFFF, L shr 16));

  L := LongInt(Ghost^);
  FreeMem(Ghost, ImageSize(0, 0, L and $FFFF, L shr 16));

  NewList(nil);

  Dispose(Font, Done);
  inherited Done;
End;

procedure TGListBox.DrawItemText(Item: Integer; R: TRect);
var Sub: TRect;

 procedure WriteNormText(S: String; var R: TRect);
 Begin
   Dec(R.B.Y, R.A.Y);
   OutTextXY(R.A.X, R.A.Y + R.B.Y div 2 + 1, S);
 End;

 procedure WriteBigText(S: String; var R: TRect);
 var C: Byte;
 Begin
   If GetState (sfSelected) then
     If Item=Focused then C := 4
                     else C := 3
   Else C := 3;
   SetTextParams(Font^.GetFontHandle, 2, GetColor(C), true);
   SetTextJustify(CenterText, CenterText);
   Dec(R.B.X, R.A.X); Dec(R.B.Y, R.A.Y);
   OutTextXY(R.A.X + R.B.X div 2 - 1,  R.A.Y + R.B.Y div 2 + 1, S);
 End;

Begin
  GetItemSubRect(Sub);
  Sub.Intersect(R);
  SetSubRect(Sub);
  Case Item Of
    3, 7: WriteBigText(GetText(Item, $FF), R);
    6: PutImage(R.A.X + (R.B.X - R.A.X) div 2 - 16, R.A.Y + 1,
         Ghost^, NormalPut);
    8: PutImage(R.A.X + (R.B.X - R.A.X) div 2 - 75, R.A.Y + 1,
         Nilhorn^, NormalPut);
   else WriteNormText(GetText(Item, $FF), R);
  End;
End;

procedure TGListBox.GetItemRect(Item: Integer; var R: TRect);
var i, s: Byte;
Begin
  GetItemSubRect(R);
  R.B.Y := R.A.Y;
  For i := TopItem to Item do Begin
    Case i of
      3, 7: s := 50;
      6: s := 34;
      8: s := 102;
     else s := 15;
    End;
    Inc(R.B.Y, s);
  End;
  R.A.Y := R.B.Y - s;
End;

(******************************** TDemoApp object ***************************)

constructor TDemoApp.Init;
var R: TRect;
Begin
  Res := OpenResource('GVDEMO21.DLL');

  inherited Init;
  { lets create a table }
  TableEntries := New(PStringCollection, Init(8, 8));
  With TableEntries^ do Begin
    AtInsert(Count, NewStr(GetStr(783)));
    AtInsert(Count, NewStr(GetStr(784)));
    AtInsert(Count, NewStr(GetStr(785)));
    AtInsert(Count, NewStr(GetStr(786)));
  End
End;

destructor TDemoApp.Done;
Begin
  Dispose(TableEntries, Done);
  inherited Done;
  Dispose(Res, Done);
End;

{ This provides the states for the multicheckbox; must be a global routine }
procedure MultiStates; Assembler;
Asm
      DW	13
      DW	0000000000000000B
      DW	0000000000000000B
      DW	0000000000000000B
      DW	0000000000000000B
      DW	0000000000000000B
      DW	0000000000000000B
      DW	0000000000000000B
      DW	0000000000000000B
      DW	0000000000000000B
      DW	0000000000000000B
      DW	0000000000000000B
      DW	0000000000000000B
      DW	0000000000000000B
      DW 	13
      DW	0000000000000000B
      DW	0100000000010000B
      DW	0010000000100000B
      DW	0001000001000000B
      DW	0000100010000000B
      DW	0000010100000000B
      DW	0000001000000000B
      DW	0000010100000000B
      DW	0000100010000000B
      DW	0001000001000000B
      DW	0010000000100000B
      DW	0100000000010000B
      DW	0000000000000000B
      DW	13
      DW	0000000000000000B
      DW	0000000000000000B
      DW	0000011100000000B
      DW	0000100010000000B
      DW	0001100011000000B
      DW	0010010100100000B
      DW	0010000000100000B
      DW	0010010100100000B
      DW	0001100011000000B
      DW	0000100010000000B
      DW	0000011100000000B
      DW	0000000000000000B
      DW	0000000000000000B
      DW	13
      DW        0000000000000000B
      DW        0000000001000000B
      DW        0000000001000000B
      DW        0000000011000000B
      DW        0000000010000000B
      DW        0000000110000000B
      DW        0011000100000000B
      DW        0001101100000000B
      DW        0000101000000000B
      DW        0000111000000000B
      DW        0000010000000000B
      DW        0000000000000000B
      DW        0000000000000000B
End;


procedure TDemoApp.HandleEvent(var Event: TEvent);

  procedure ShowListViewer;
  var
    R, Cl: TRect;
    Mid: TPoint;
    D: PDialog;
    VSB, HSB: PScrollbar;
    Fields: PTableFields;
    Entries, Entr2: PCollection;
    Table: PTableViewer;
    L: PListBox;
    IL: PInputLine;
    i: Byte;
  begin
    R.Assign(0, 0, 600, 430);
    D := New(PDialog, Init(R, GetStr(778)));
    With D^ do Begin
      Palette := wpGrayWindow;
      HelpCtx := hcDialog;
      Options := Options or ofCentered;
      GetClientRect(Cl); Dec(Cl.B.Y, 60);
      With Cl do Begin
        Mid.X := A.X + (B.X - A.X) div 2;
        Mid.Y := A.Y + (B.Y - A.Y) div 2;
      End;

      { Tabelle }
      With Cl do
        R.Assign(Mid.X - 33, A.Y + 29, Mid.X - 15, Mid.Y - 27);
      VSB := Insert(New(PScrollbar, Init(R)));
      With Cl do
        R.Assign(A.X + 30, Mid.Y - 28, Mid.X - 32, Mid.Y - 10);
      HSB := Insert(New(PScrollbar, Init(R)));
      Fields := New(PTableFields, Init);
      With Fields^ do Begin
        DecimalField(GetStr(779), 70, 5);
        LeftField(GetStr(780), 100);
        CenterField(GetStr(781), 70);
        RightField(GetStr(782), 100);
      End;
      With Cl do
        R.Assign(A.X + 30, A.Y + 10, Mid.X - 32 , Mid.Y - 27);
      Table := Insert(New(PTableViewer, Init(R, HSB, VSB, Fields)));
      Table^.NewList(TableEntries);

      { Normale Listbox }
      With Cl do
        R.Assign(B.X - 48, A.Y + 10, B.X - 30, Mid.Y - 10);
      VSB := Insert(New(PScrollBar, Init(R)));
      With Cl do
        R.Assign(Mid.X + 15, A.Y + 10, B.X - 47, Mid.Y - 10);
      L := Insert(New(PListBox, Init(R, VSB)));
      Entries := New(PStringCollection, Init(8, 8));
      With Entries^ do Begin
        AtInsert(Count, NewStr(GetStr(787)));
        AtInsert(Count, NewStr(GetStr(788)));
        AtInsert(Count, NewStr(GetStr(789)));
        AtInsert(Count, NewStr(GetStr(790)));
        For i := 1 to 20 do AtInsert(Count, NewStr(' '));
        AtInsert(Count, NewStr('Yeah !'));
      End;
      L^.NewList(Entries);

      { Graphische Listbox }
      With Cl do
        R.Assign(Mid.X - 33, Mid.Y + 10, Mid.X - 15, B.Y - 10);
      VSB := Insert(New(PScrollBar, Init(R)));
      With Cl do
        R.Assign(A.X + 30, Mid.Y + 10, Mid.X - 32, B.Y - 10);
      Insert(New(PGListBox, Init(R, VSB)));

      { Combobox }
      With Cl do
        R.Assign(Mid.X + 15, Mid.Y + 30, B.X - 47, Mid.Y + 50);
      IL := Insert(New(PInputLine, Init(R, 46)));
      L := New(PComboViewer, Init(IL));
      Entr2 := New(PStringCollection, Init(8, 8));
      With Entr2^ do Begin
	Insert(NewStr(GetStr(791)));
	Insert(NewStr(GetStr(792)));
	Insert(NewStr(GetStr(793)))
      End;
      L^.NewList(Entr2);
      PComboViewer(L)^.Validator^.Strict := true;
      With Cl do
        R.Assign(B.X - 48, Mid.Y + 30, B.X - 30, Mid.Y + 50);
      Insert(New(PCombo, Init(R, PComboViewer(L))));

      { Buttons }
      R.Assign(180, Size.Y - 55, 280, Size.Y - 25);
      Insert(New(PButton, Init(R, GetStr(739), cmOK, bfDefault)));
      R.Move(120, 0);
      Insert(New(PButton, Init(R, GetStr(740), cmCancel, bfNormal)));
      SelectNext(false);

    end;
    ExecuteDialog(D, nil);
    Dispose(Entries, Done);
    Dispose(Entr2, Done)
  end;

  procedure ShowCluster;
  var D: PDialog;
      R, Cl: TRect;
      Mid: TPoint;
  const Data: Record R, C: Word; M: LongInt end = (R: 4; C: $001D;
    M: $9BC);
  Begin
    R.Assign(0, 0, 500, 320);
    D := New(PDialog, Init(R, GetStr(798)));
    With D^ do Begin
      Options := Options or ofCentered;
      HelpCtx := hcDialog;
      GetClientRect(Cl); Dec(Cl.B.Y, 60);
      With Cl do Begin
        Mid.X := (B.X - A.X) div 2 + A.X;
        Mid.Y := (B.Y - A.Y) div 2 + A.Y
      End;

      { Radiobuttons }
      With Cl do
        R.Assign(A.X + 30, A.Y + 10, Mid.X - 15, Mid.Y - 10);
      Insert(New(PRadioButtons, Init(R,
        NewSItem(GetStr(799),
        NewSItem(GetStr(800),
        NewSItem(GetStr(801),
        NewSItem(GetStr(802),
        NewSItem(GetStr(803),
        NewSItem(GetStr(804), nil)))))))));
      { CheckBoxes }
      With Cl do
        R.Assign(Mid.X + 15, A.Y + 10, B.X - 30, Mid.Y - 10);
      Insert(New(PCheckBoxes, Init(R,
        NewSItem(GetStr(805),
        NewSItem(GetStr(806),
        NewSItem(GetStr(807),
        NewSItem(GetStr(808),
        NewSItem(GetStr(809),
        NewSItem(GetStr(810), nil)))))))));

      { MultiCheckboxes }
      With Cl do
        R.Assign(A.X + 50, Mid.Y + 10, B.X - 50, B.Y - 10);
      Insert(New(PMultiCheckBoxes, Init(R,
        NewSItem(GetStr(811),
        NewSItem(GetStr(812),
        NewSItem(GetStr(813),
        NewSItem(GetStr(814),
        NewSItem(GetStr(815),
        NewSItem(GetStr(816), nil)))))), 4, cfTwoBits, @MultiStates)));

      { Buttons }
      R.Assign(110, Size.Y - 55, 210, Size.Y - 25);
      Insert(New(PButton, Init(R, GetStr(739), cmOK, bfDefault)));
      R.Move(120, 0);
      Insert(New(PButton, Init(R, GetStr(740), cmCancel, bfNormal)));
      SelectNext(false)
    End;
    ExecuteDialog(D, @Data);
  End;

Begin
  inherited HandleEvent(Event);
  If Event.What = evCommand then
    Case Event.Command Of
      cmList: ShowListViewer;
      cmCluster: ShowCluster;
    End
End;

procedure TDemoApp.InitStatusLine;
var R: TRect;
Begin
  Main^.GetExtent(R);
  R.A.Y := R.B.Y - 21;
  StatusLine := New(PStatusLine, Init(R,
    NewStatusDef(0, 0,
      NewStatusKeyKN(GetStr(600), kbAltX, cmQuit,
      NewStatusKeyKN(GetStr(619), kbF3, cmList,
      NewStatusKeyKN(GetStr(620), kbF4, cmCluster, nil))),
    NewStatusDef (500, 699,
      NewStatusKeyKN (GetStr(609), kbEsc, cmCancel,
      NewStatusKeyKN (GetStr(610), kbEnter, cmOk,
      NewStatusKeyKN (GetStr(611),kbCtrlF5, cmResize, nil))),
    StdDraggingStatusDef(
    nil)))));
End;

function TDemoApp.LanguageResource: String;
Begin
  LanguageResource := 'EXAM.GVL';
End;

var App: TDemoApp;

Begin
  Language := lfEnglish;
  App.Init;
  App.Run;
  App.Done;
End.
