Monster Media 1994 #1/monster.zip/monster/PROG_GEN/TCYBER.ZIP/CYFONT.PAS

Pascal/Delphi Source File | 1994-01-15 | 36KB | 1,351 lines

{
Turbo Vision CyberTools 1.0
(C) 1994 Steve Goldsmith
All Rights Reserved

CyberFont application shows how to use fonts, graphics, sprites, bit map
animation, PCX images and DAC palettes.  Borland Pascal 7.x or Turbo Pascal
7.x and Turbo Vision 2.x are required to compile.

Set IDE directories to

\BP\UNITS;
\BP\EXAMPLES\DOS\TVDEMO;
\BP\EXAMPLES\DOS\TVFM;

These path names are BP 7.x defaults.  If you changed any of these then use
the correct paths in Options|Directories...  See APP.INC for global compiler
switches.
}

program CyberFont;

{$I APP.INC}
{$X+}

uses

  Dos,                           {bp units}
  Memory, Drivers, Objects,      {tv units}
  Views, Menus, Dialogs,
  App, MsgBox, StdDlg, ColorSel,
  Gadgets, AsciiTab, HelpFile,   {tvdemo units}
  ViewText,                      {tvfm units}
  CFHelp, CFCmds,                {cybertools units}
  VGA, VGACGFil, CFSprite, ChrPCX,
  CFDlgs;

const

  appDocName  = 'CYBER.DOC';  {doc file name}
  appCfgName  = 'CYFONT.CFG'; {config stream file name}
  appHelpName = 'CFHELP.HLP'; {help file name}
  appExeName  = 'CYFONT.EXE'; {name used to locate .exe for older dos}
  appCfgHeaderLen = 10;       {header used by config stream}
  appCfgHeader : string[appCfgHeaderLen] = 'CYBERFONT'#26;
  appViewDocBuf = 8192;       {buffer size for viewing doc file}

  appChrWidth8  = $01;        {set app options bit to 1 to select option}
  appPageMode   = $02;
  app8Colors    = $04;
  appAniBitMap  = $08;
  appHelpInUse  = $8000;      {used by help system}
  appScrOpts    = $0f;        {mask of just screen options}

  appGraphWinX = 32; {x = 32*8 = 256 pixels}
  appGraphWinY = 8;  {y = 8*16 = 128 pixels}

  CSysColor = #$00#$00#$00; {app palette additions for tv system stuff}
  CSysPal   = #144#145#146;

type

  TCyberFont = object (TApplication)
    FontTable1,
    FontTable2,
    AniTable : byte;
    FrameDelay : integer;
    AppOptions,
    PageOfs,
    DefChrHeight : word;
    BiosTimer,
    TickDelay : longint;
    Page : pointer;
    DefFont : vgaChrTablePtr;
    DacPalette : vgaPalette;
    ScrData : ScrOptsData;
    Clock : PClockView;
    Heap : PHeapView;
    constructor Init;
    destructor Done; virtual;
    procedure SetCustomScreen;
    procedure FlipPage;
    procedure ClearDeskTop;
    procedure Idle; virtual;
    procedure AboutBox;
    function SelectFile (Title : string; WildCard : PathStr; ReadFlag : boolean) : PathStr;
    procedure LoadFontTable (ChrData : pointer;
                             ChrTable, ChrHeight :byte;
                             StartChr, NumChrs : word);
    function SaveFontTable (ChrTable, ChrHeight :byte;
                            StartChr, NumChrs : word) : vgaChrTablePtr;
    procedure LoadChrFile (F : PathStr; ChrTbl : byte);
    procedure SaveChrFile (F : PathStr);
    procedure GraphicsWin (T : string);
    procedure RestoreDesktop (F : PathStr);
    procedure SaveDeskTop (F : PathStr);
    procedure GetEvent (var Event : TEvent); virtual;
    function GetPalette : PPalette; virtual;
    procedure HandleEvent (var Event : TEvent); virtual;
    procedure InitDeskTop; virtual;
    procedure InitMenuBar; virtual;
    procedure InitStatusLine; virtual;
    procedure OutOfMemory; virtual;
    procedure LoadDesktop (var S : TStream);
    procedure StoreDesktop (var S : TStream);
  end;

constructor TCyberFont.Init;

var

  R :TRect;

begin
  LowMemSize := 4095; {65520 byte safety pool needed to do dos shell safely}
  inherited Init;
  RegisterObjects;    {register stuff for stream access}
  RegisterViews;
  RegisterMenus;
  RegisterDialogs;
  RegisterApp;
  RegisterAsciiTab;
  RegisterHelpFile;
  R.Assign (71,0,79,1);
  Clock := New (PClockView,Init (R)); {gadgets included with tvdemo}
  Insert (Clock);
  R.Assign (64,0,70,1);
  Heap := New (PHeapView,Init(R));
  Insert (Heap);
  RestoreDesktop (appCfgName); {load config stream}
  AniTable := 1;               {start font 2 table animation with table 1}
  FrameDelay := ScrData.Delay; {frame delay in 1/18 seconds}
  Randomize                    {animation dialogs use random numbers}
end;

destructor TCyberFont.Done;

begin
  if DefFont <> nil then      {dispose default font}
    FreeMem (DefFont,vgaMaxChrs*DefChrHeight);
  FadeOutDAC;                 {fade to black}
  SetVideoMode (StartUpMode); {this resets all the custom stuff with bios}
  inherited Done
end;

procedure TCyberFont.SetCustomScreen;

begin
  HideMouse;
  if AppOptions and appPageMode = 0 then
    SetPage (vgaPageOfsLoc[0]); {screen page 0 for non page flipping displays}
  if AppOptions and app8Colors = app8Colors then
    SetAttrCont (vgaAttrCPEnable,$07)  {use 8 colors}
  else
    SetAttrCont (vgaAttrCPEnable,$0f); {use 16 colors}
  if AppOptions and appChrWidth8 = appChrWidth8 then
  begin
    if IsChrWidth9 then
      SetChrWidth8 {640 x 400 screen}
  end
  else
  begin
    if not IsChrWidth9 then
      SetChrWidth9 {720 x 400 screen}
  end;
  FontMapSelect (vgaChrTableMap1[FontTable1],
  vgaChrTableMap2[FontTable2]);    {select font tables}
  SetDACBlock (@DacPalette,0,256); {set 256 color palette}
  asm                 {new mouse cursor mask that looks right}
    mov     ax,0ah    {when mouse is over graphic characters}
    mov     bx,00h
    mov     cx,0ffffh {and mask}
    mov     dx,7700h  {xor mask}
    int     33h       {mouse interrupt}
  end;
  ShowMouse
end;

procedure TCyberFont.FlipPage;

begin {copy screen page 0 to new non-visiable page and flip to new page}
  CopyScrMem (ScreenBuffer,Page,vgaScrSize25);
  SetPage (PageOfs);
  if PageOfs = vgaPageOfsLoc[1] then
  begin
    PageOfs := vgaPageOfsLoc[2];
    Page := vgaPageLoc[2]
  end
  else
  begin
    PageOfs := vgaPageOfsLoc[1];
    Page := vgaPageLoc[1]
  end;
  WaitVertSync {wait for vga vert sync before drawing anything}
end;

procedure TCyberFont.ClearDeskTop;

procedure CloseDlg (P : PView); far;

begin
  Message (P,evCommand,cmClose,nil)
end;

begin
  Desktop^.ForEach (@CloseDlg)
end;

procedure TCyberFont.Idle;

function IsTileable (P : PView) : Boolean; far;

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

function IsThere (P : PView) : Boolean; far;

begin
  IsThere := (P^.State and sfActive = sfActive)
end;

function IsModal (P : PView) : Boolean; far;

begin
  IsModal := (P^.State and sfModal = sfModal)
end;

procedure AniMsg (P: PView); far;

begin
  Message (P,evBroadcast,cmAnimate,nil)
end;

begin
  inherited Idle;
  BiosTimer := longint (Ptr (Seg0040,$6c)^); {read time from bios area}
  Clock^.Update; {update tvdemo gadgets}
  Heap^.Update;
  if Desktop^.FirstThat (@IsThere) <> nil then {see if anything is}
  begin                                        {on the desk top}
    EnableCommands ([cmCloseAll]);
    if Desktop^.FirstThat (@IsTileable) <> nil then {see if any tileable}
      EnableCommands ([cmTile,cmCascade])           {windows are on the}
    else                                            {desk top}
      DisableCommands ([cmTile,cmCascade]);
    Desktop^.ForEach (@AniMsg) {update all animation dialogs}
  end
  else
    DisableCommands ([cmCloseAll,cmTile,cmCascade]);
  if (Desktop^.FirstThat (@IsModal) <> nil)
  or (AppOptions and appHelpInUse = appHelpInUse) then   {see if a modal dialog}
    DisableCommands ([cmQuit,cmRestoreDef,cmScreenOpts]) {is on the desk top}
  else
    EnableCommands ([cmQuit,cmRestoreDef,cmScreenOpts]);
  if AppOptions and appPageMode = appPageMode then
    FlipPage; {if page mode is enabled then flip page each idle cycle}
  if (AppOptions and appAniBitMap = appAniBitMap) and
  (BiosTimer <> TickDelay) then {see if we are ready to display next frame}
  begin
    TickDelay := BiosTimer;     {reset tick delay to equal bios time}
    Dec (FrameDelay);           {count down ticks}
    if FrameDelay = 0 then      {see if counted down to zero}
    begin                       {display next frame}
      FontMapSelect (vgaChrTableMap1[FontTable1],vgaChrTableMap2[AniTable]);
      Inc (AniTable);
      if AniTable = vgaMaxChrTables then {see if last frame reached}
        AniTable := 1;                   {yes, then restart at 1}
      FrameDelay := ScrData.Delay        {reset frame delay}
    end
  end
end;

procedure TCyberFont.AboutBox;

begin
  MessageBox(
    #3'Turbo Vision CyberTools 1.0'#13+
    #3'(C) 1994 Steve Goldsmith'#13+
{$IFDEF DPMI}
    #3'CyberFont »> PROTECTED <«',
{$ELSE}
    #3'CyberFont »> REAL <«',
{$ENDIF}
    nil, mfInformation or mfOKButton)
end;

function TCyberFont.SelectFile (Title : string; WildCard : PathStr; ReadFlag : boolean) : PathStr;

var

  F : file;

begin
  HelpCtx := hcFOFileOpenDBox;
  if ExecuteDialog (New (PFileDialog,Init (WildCard,Title,
    '~N~ame',fdOkButton,100)),@WildCard) <> cmCancel then
  begin
    if ReadFlag then
      SelectFile := WildCard
    else
    begin
      Assign (F,WildCard);
      {$I-} Reset (F); {$I+}
      if IoResult = 0 then {see if file exists before writes}
      begin
        {$I-} Close (F); {$I+}
        if MessageBox (WildCard+' already exists.  Erase and continue?',
        nil,mfConfirmation or mfYesNoCancel) = cmYes then
          SelectFile := WildCard
        else
          SelectFile := ''
      end
      else
        SelectFile := WildCard
    end
  end
  else
    SelectFile := '';
  HelpCtx := hcNoContext
end;

procedure TCyberFont.LoadFontTable (ChrData : pointer;
                                       ChrTable, ChrHeight :byte;
                                       StartChr, NumChrs : word);

begin
  HideMouse;
  AccessFontMem;
  SetRamTable (StartChr,NumChrs,ChrHeight,ChrData,vgaChrTableLoc[ChrTable]);
  AccessScreenMem;
  ShowMouse
end;

function TCyberFont.SaveFontTable (ChrTable, ChrHeight :byte;
                                      StartChr, NumChrs : word) : vgaChrTablePtr;

begin
  HideMouse;
  AccessFontMem;
  SaveFontTable :=
  GetRamTable (StartChr,NumChrs,ChrHeight,vgaChrTableLoc [ChrTable]);
  AccessScreenMem;
  ShowMouse
end;

procedure TCyberFont.LoadChrFile (F : PathStr; ChrTbl : byte);

var

  ChrFile : TChrGenFile;

begin {load .cgf file and use bios to store in table}
  ChrFile.Init;
  ChrFile.OpenRead (F);
  if (ChrFile.IoError = 0) and
  (ChrFile.Header.Height = DefChrHeight) then
  begin
    ChrFile.ReadChrTable;
    LoadFontTable (
    ChrFile.ChrTablePtr,ChrTbl,ChrFile.Header.Height,
    ChrFile.Header.StartChr,ChrFile.Header.TotalChrs)
  end
  else
    MessageBox (#3'Problem reading font file.',nil,mfOkButton+mfError);
  ChrFile.FreeChrTable;
  ChrFile.Done
end;

procedure TCyberFont.SaveChrFile (F : PathStr);

var

  ChrFile : TChrGenFile;

begin {save .cgf file from table}
  ChrFile.Init;
  HideMouse;
  AccessFontMem;
  ChrFile.GetFontTable (FontTable1,0,vgaMaxChrs,DefChrHeight);
  AccessScreenMem;
  ShowMouse;
  ChrFile.OpenWrite (F);
  if ChrFile.IoError = 0 then
    ChrFile.WriteChrTable
  else
    MessageBox (#3'Problem writing font file.',nil,mfOkButton+mfError);
  ChrFile.FreeChrTable;
  ChrFile.Done
end;

procedure TCyberFont.GraphicsWin (T : string);

var

  P : PChrSetDlg;

function IsThere (P : PView) : Boolean; far;

begin {see if view is a chr set dialog}
  IsThere := (TypeOf (P^) = TypeOf (TChrSetDlg))
end;

begin
  PView (P) := Desktop^.FirstThat (@IsThere);
  if P <> nil then {if on screen then close}
  begin
    if PChrSetDlg (P)^.Title <> nil then
      DisposeStr (PChrSetDlg (P)^.Title);
    PChrSetDlg (P)^.Title := NewStr (T);
    PChrSetDlg (P)^.Frame^.DrawView;
    PChrSetDlg (P)^.MakeFirst;
  end
  else
  begin
    P := New(PChrSetDlg,Init (T,appGraphWinX,appGraphWinY));
    P^.Options := P^.Options or ofCentered;
    P^.HelpCtx := hcGraphicsWindow;
    InsertWindow (P)
  end
end;

procedure TCyberFont.RestoreDesktop (F : PathStr);

var

  I : byte;
  S : PStream;
  Signature : string[appCfgHeaderLen];

begin
  S := New (PBufStream,Init (F,stOpenRead,1024));
  if LowMemory then OutOfMemory
  else
    if S^.Status <> stOk then
    begin
      MessageBox (#3'Unable to open file.',nil,mfOkButton+mfError)
    end
    else
    begin
      Signature[0] := Char (appCfgHeaderLen);
      S^.Read (Signature[1],appCfgHeaderLen);
      if Signature = appCfgHeader then {see if signature is right}
      begin
        S^.Read (AppOptions,SizeOf (AppOptions)); {read data from stream}
        S^.Read (DefChrHeight,SizeOf (DefChrHeight));
        S^.Read (ScrData.Delay,SizeOf (ScrData.Delay));
        if DefFont = nil then
          DefFont := MemAlloc (DefChrHeight*vgaMaxChrs);
        HideMouse; {no screen writes during font mem access}
        AccessFontMem;
        for I := 0 to 7 do
        begin
          S^.Read (DefFont^,DefChrHeight*vgaMaxChrs);
          SetRamTable (0,vgaMaxChrs,DefChrHeight,DefFont,vgaChrTableLoc[I])
        end;
        AccessScreenMem;
        ShowMouse;
        S^.Read (FontTable1,SizeOf (FontTable1));
        S^.Read (FontTable2,SizeOf (FontTable2));
        S^.Read (DacPalette,SizeOf (DacPalette));
        LoadDesktop (S^);
        LoadIndexes (S^);
        ShadowAttr := GetColor (144);   {tv shadow color}
        SysColorAttr := (GetColor (145) shl 8) or GetColor (145); {tv system error color}
        ErrorAttr := GetColor (146);    {tv palette index error color}
        if DefFont <> nil then
        begin
          FreeMem (DefFont,DefChrHeight*vgaMaxChrs);
          DefFont := SaveFontTable (FontTable1,DefChrHeight,0,vgaMaxChrs)
        end;
        SetCustomScreen;
        Application^.ReDraw; {draw app with new config}
        GraphicsWin ('');    {say hello with graphic window}
        if S^.Status <> stOk then
          MessageBox (#3'Stream error.',nil,mfOkButton+mfError);
      end
      else
        MessageBox (#3'Invalid configuration format.',nil,mfOkButton+mfError)
    end;
  Dispose (S,Done)
end;

procedure TCyberFont.SaveDesktop (F : PathStr);

var

  I : byte;
  CfgFile : File;
  S : PStream;
  SFont : vgaChrTablePtr;

begin
  S := New(PBufStream,Init (F,stCreate,1024));
  if not LowMemory and (S^.Status = stOk) then
  begin
    S^.Write (appCfgHeader[1],appCfgHeaderLen); {write stream data}
    S^.Write (AppOptions,SizeOf (AppOptions));
    S^.Write (DefChrHeight,SizeOf (DefChrHeight));
    S^.Write (ScrData.Delay,SizeOf (ScrData.Delay));
    HideMouse; {no screen write during font mem access}
    AccessFontMem;
    for I := 0 to 7 do {save all 8 vga font tables}
    begin
      SFont := GetRamTable (0,vgaMaxChrs,DefChrHeight,vgaChrTableLoc[I]);
      S^.Write (SFont^,DefChrHeight*vgaMaxChrs);
      if SFont <> nil then
        FreeMem (SFont,DefChrHeight*vgaMaxChrs)
    end;
    AccessScreenMem;
    ShowMouse;
    S^.Write (FontTable1,SizeOf (FontTable1));
    S^.Write (FontTable2,SizeOf (FontTable2));
    GetDACBlock (@DacPalette,0,256);
    S^.Write(DacPalette,SizeOf (DacPalette));
    StoreDesktop (S^);
    StoreIndexes (S^);
    if S^.Status <> stOk then
    begin {if stream error then delete file}
      MessageBox (#3'Could not create stream.',nil,mfOkButton+mfError);
      Dispose (S,Done);
      Assign (CfgFile,F);
      {$I-} Erase (CfgFile) {$I+};
      Exit
    end
  end;
  Dispose (S,Done)
end;

procedure TCyberFont.GetEvent (var Event : TEvent);

function CalcHelpName : PathStr;

var

  EXEName : PathStr;
  Dir : DirStr;
  Name : NameStr;
  Ext : ExtStr;

begin
  if Lo (DosVersion) >= 3 then
    EXEName := ParamStr (0)
  else
    EXEName := FSearch (appExeName, GetEnv ('PATH'));
  FSplit (EXEName, Dir, Name, Ext);
  if Dir[Length (Dir)] = '\' then
    Dec (Dir[0]);
  CalcHelpName := FSearch (appHelpName, Dir);
end;

var

  W : PWindow;
  HFile : PHelpFile;
  HelpStrm : PDosStream;

begin
  inherited GetEvent (Event);
  case Event.What of
    evCommand:
      if (Event.Command = cmHelp) and (AppOptions and appHelpInUse = 0) then
      begin {process help command if not in use}
        AppOptions := AppOptions or appHelpInUse; {help's in use}
        HelpStrm := New (PDosStream, Init (CalcHelpName, stOpenRead));
        HFile := New (PHelpFile, Init (HelpStrm));
        if HelpStrm^.Status <> stOk then
        begin
          MessageBox (#3'Could not open help file.', nil, mfError + mfOkButton);
          Dispose (HFile, Done);
        end
        else
        begin
          W := New (PHelpWindow,Init (HFile, GetHelpCtx));
          if ValidView (W) <> nil then
          begin
            DisableCommands ([cmHelp]);
            ExecView (W);
            Dispose (W, Done);
            EnableCommands ([cmHelp])
          end;
          ClearEvent (Event)
        end;
        AppOptions := AppOptions and not appHelpInUse
      end;
    evMouseDown:
      if Event.Buttons <> 1 then
        Event.What := evNothing
  end
end;

function TCyberFont.GetPalette: PPalette;

const

  CNewColor = CAppColor+CHelpColor+CAniColor+CGraphColor+CSysColor;
  CNewBlackWhite = CAppBlackWhite+CHelpBlackWhite+CAniColor+CGraphColor+CSysColor;
  CNewMonochrome = CAppMonochrome+CHelpMonochrome+CAniColor+CGraphColor+CSysColor;
  P: array[apColor..apMonochrome] of string[Length (CNewColor)] =
  (CNewColor, CNewBlackWhite, CNewMonochrome);

begin {add additional entries to the normal application palettes}
  GetPalette := @P[AppPalette];
end;

procedure TCyberFont.HandleEvent (var Event: TEvent);

procedure LoadFontFile;

var

  F : PathStr;

begin
  F := SelectFile ('Load Font','*.CGF',true);
  if F <> '' then
    LoadChrFile (F,FontTable1)
end;

procedure SaveFontFile;

var

  F : PathStr;

begin
  F := SelectFile ('Save Font','*.CGF',false);
  if F <> '' then
    SaveChrFile (F)
end;

procedure LoadPCXFile;

var

  F : PathStr;

begin
  F := SelectFile ('Load PCX','*.PCX',true);
  if F <> '' then
  begin
    HideMouse; {no screen writes during font mem access}
    if PCXToChrTable (F,appGraphWinX,appGraphWinY,DefChrHeight,vgaChrTableLoc[FontTable2]) then
    begin
      ShowMouse;
      GraphicsWin (F)
    end
    else
    begin
      ShowMouse;
      MessageBox (#3'Problem reading PCX file.',nil,mfOkButton+mfError)
    end
  end
end;

procedure SavePCXFile;

var

  F : PathStr;

begin
  F := SelectFile ('Save PCX','*.PCX',false);
  if F <> '' then
  begin
    HideMouse; {no screen writes during font mem access}
    if not ChrTableToPCX (F,appGraphWinX,appGraphWinY,DefChrHeight,vgaChrTableLoc[FontTable2]) then
    begin
      ShowMouse;
      MessageBox (#3'Problem writing PCX file.',nil,mfOkButton+mfError);
    end
    else
      ShowMouse
  end
end;

procedure ChangeDir;

var

  D: PChDirDialog;

begin
  D := New (PChDirDialog,Init (cdNormal,101));
  D^.HelpCtx := hcFCChDirDBox;
  ExecuteDialog (D,nil)
end;

procedure ShellToDos;

var

  SaveFont : vgaChrTablePtr;

begin
  SaveFont := SaveFontTable (FontTable1,DefChrHeight,0,vgaMaxChrs); {save current font}
  if (not LowMemory) and (SaveFont <> nil) then
  begin
    SetVideoMode (StartUpMode);  {reset custom setup using bios}
    DosShell
  end
  else
    OutOfMemory;
  if SaveFont <> nil then
  begin {restore font}
    LoadFontTable (SaveFont,FontTable1,DefChrHeight,0,vgaMaxChrs);
    FreeMem (SaveFont,DefChrHeight*vgaMaxChrs);
    SetCustomScreen;
    ShowMouse
  end
end;

procedure ViewTextFile (FileName : PathStr);

var

  T : PTextWindow;
  R : TRect;

begin
  GetExtent (R);
  R.Grow (-5,-4);
  T := New(PTextWindow, Init(R, FileName));
  T^.Options := T^.Options or ofCentered;
  T^.HelpCtx := hcViewDoc;
  InsertWindow (T)
end;

procedure DelayTicks (T : word);

var

  Ticks : word;
  CurTime : longint;
  BiosTimer : longint absolute $40:$6c;

begin
  Ticks := 0;
  CurTime := BiosTimer;
  repeat
    if CurTime <> BiosTimer then
    begin
      CurTime := BiosTimer;
      Inc (Ticks)
    end
  until Ticks = T;
end;

procedure ClearGraphWin;

var

  I : integer;
  ChrTablePtr : vgaChrTablePtr;

begin
  GraphicsWin ('');
  ChrTablePtr := vgaChrTableLoc[FontTable2];
  HIdeMouse;
  AccessFontMem;
  for I := 0 to vgaChrTableSize-1 do {clear font table mem}
    ChrTablePtr^[I] := 0;
  AccessScreenMem;
  ShowMouse
end;

procedure Lines1;

var

  I : integer;

begin
  GraphicsWin ('Lines 1');
  HideMouse;
  AccessFontMem;
  for I := 0 to 31 do
  begin
    DrawTableLine (0,0,I*8+7,127,
    appGraphWinX,DefChrHeight,vgaChrTableLoc[FontTable2],true);
    DrawTableLine (255,0,255-(I*8+7),127,
    appGraphWinX,DefChrHeight,vgaChrTableLoc[FontTable2],true)
  end;
  AccessScreenMem;
  ShowMouse
end;

procedure Lines2;

var

  I : integer;

begin
  GraphicsWin ('Lines 2');
  HideMouse;
  AccessFontMem;
  for I := 1 to 50 do
    DrawTableLine (Random (256),Random (128),Random (256),Random (128),
    appGraphWinX,DefChrHeight,vgaChrTableLoc[FontTable2],true);
  AccessScreenMem;
  ShowMouse
end;

procedure Ellipses1;

var

  I : integer;

begin
  GraphicsWin ('Ellipses 1');
  HideMouse;
  AccessFontMem;
  for I := 1 to 20 do
  begin
    DrawTableEllipse (I*4,I*3,I*2,I*3,
    appGraphWinX,DefChrHeight,vgaChrTableLoc[FontTable2],true);
    DrawTableEllipse (255-I*4,I*3,I*2,I*3,
    appGraphWinX,DefChrHeight,vgaChrTableLoc[FontTable2],true)
  end;
  AccessScreenMem;
  ShowMouse
end;

procedure Ellipses2;

var

  I : integer;

begin
  GraphicsWin ('Ellipses 2');
  HideMouse;
  AccessFontMem;
  for I := 0 to 31  do
    DrawTableEllipse (127,63,I*3,I*2,appGraphWinX,DefChrHeight,
    vgaChrTableLoc[FontTable2],true);
  AccessScreenMem;
  ShowMouse
end;

procedure Ellipses3;

var

  I : integer;

begin
  GraphicsWin ('Ellipses 3');
  HideMouse;
  AccessFontMem;
  for I := 1 to 12 do
    DrawTableEllipse (Random (192)+32,Random (64)+32,Random (30)+2,Random (30)+2,
    appGraphWinX,DefChrHeight,vgaChrTableLoc[FontTable2],true);
  AccessScreenMem;
  ShowMouse
end;

procedure DrawTableRect (X1,Y1,X2,Y2 : integer; PixOn : boolean);

begin
  DrawTableLine (X1,Y1,X2,Y1,
  appGraphWinX,DefChrHeight,vgaChrTableLoc[FontTable2],PixOn);
  DrawTableLine (X1,Y2,X2,Y2,
  appGraphWinX,DefChrHeight,vgaChrTableLoc[FontTable2],PixOn);
  DrawTableLine (X1,Y1,X1,Y2,
  appGraphWinX,DefChrHeight,vgaChrTableLoc[FontTable2],PixOn);
  DrawTableLine (X2,Y1,X2,Y2,
  appGraphWinX,DefChrHeight,vgaChrTableLoc[FontTable2],PixOn);
end;

procedure Rectangles1;

var

  I : integer;


begin
  GraphicsWin ('Rectangles 1');
  HideMouse;
  AccessFontMem;
  for I := 0 to 31 do
    DrawTableRect (127-I*3,63-I*2,127+I*3,63+I*2,true);
  AccessScreenMem;
  ShowMouse
end;

procedure Rectangles2;

var

  I : integer;

begin
  GraphicsWin ('Rectangles 2');
  HideMouse;
  AccessFontMem;
  for I := 1 to 8 do
    DrawTableRect (Random (128),Random (64),Random (128)+128,Random (64)+64,true);
  AccessScreenMem;
  ShowMouse
end;

procedure AsciiTab;

var

  P : PAsciiChart;

begin
  P := New (PAsciiChart,Init);
  P^.Options := P^.Options or ofCentered;
  P^.HelpCtx := hcAsciiTable;
  InsertWindow (P)
end;

procedure InvadersDialog;

var

  P : PAniDlg;

begin
  P := New (PAniDlg,Init ('Invaders'));
  P^.MoveTo (Random (40)+1,Random (11)+1);
  P^.HelpCtx := hcInvaders;
  InsertWindow (P)
end;

procedure UfoDialog;

var

  P : PUfoDlg;

begin
  P := New (PUfoDlg,Init ('UFO Bomber'));
  P^.MoveTo (Random (40)+1,Random (11)+1);
  P^.HelpCtx := hcUFOBomber;
  InsertWindow (P)
end;

procedure ShipDialog;

var

  P : PShipDlg;

begin
  P := New (PShipDlg,Init ('Base Ship'));
  P^.MoveTo (Random (40)+1,Random (11)+1);
  P^.HelpCtx := hcBaseShip;
  InsertWindow (P)
end;

procedure RestoreDefFont;

begin
  if (DefFont <> nil) and {restore default font loaded by config}
  (DefChrHeight = BiosGetChrHeight) then
    LoadFontTable (DefFont,FontTable1,DefChrHeight,0,vgaMaxChrs)
end;

procedure ScreenOptions;

var

  D : PScrOptsDlg;

begin
  with ScrData do
  begin
    SMode := AppOptions and appScrOpts; {use only screen options}
    FontMapVal (GetSeqCont (vgaSeqChrMapSel),byte (FntTbl1),byte (FntTbl2));
    D := New (PScrOptsDlg,Init);
    D^.Options := D^.Options or ofCentered;
    D^.HelpCtx := hcScreen;
    if ExecuteDialog (D,@ScrData) <> cmCancel then
    begin
      AppOptions := (AppOptions and not appScrOpts)
      or SMode; {clear all scr opts bits and set bits returned from dialog}
      FontTable1 := FntTbl1;
      FontTable2 := FntTbl2;
      FrameDelay := Delay;
      SetCustomScreen {set screen with new settings}
    end
  end
end;

procedure Colors;

{custom color items}
function DlgColorItems (Palette: Word; const Next: PColorItem) : PColorItem;

const

  COffset : array[dpBlueDialog..dpGrayDialog] of Byte = (64, 96, 32);

var

  Offset : Byte;

begin
  Offset := COffset[Palette];
  DlgColorItems :=
    ColorItem ('Frame passive',     Offset,
    ColorItem ('Frame active',      Offset + 1,
    ColorItem ('Frame icons',       Offset + 2,
    ColorItem ('Scroll bar page',   Offset + 3,
    ColorItem ('Scroll bar icons',  Offset + 4,
    ColorItem ('Static text',       Offset + 5,

    ColorItem ('Label normal',      Offset + 6,
    ColorItem ('Label selected',    Offset + 7,
    ColorItem ('Label shortcut',    Offset + 8,

    ColorItem ('Button normal',     Offset + 9,
    ColorItem ('Button default',    Offset + 10,
    ColorItem ('Button selected',   Offset + 11,
    ColorItem ('Button disabled',   Offset + 12,
    ColorItem ('Button shortcut',   Offset + 13,
    ColorItem ('Button shadow',     Offset + 14,

    ColorItem ('Cluster normal',    Offset + 15,
    ColorItem ('Cluster selected',  Offset + 16,
    ColorItem ('Cluster shortcut',  Offset + 17,

    ColorItem ('Input normal',      Offset + 18,
    ColorItem ('Input selected',    Offset + 19,
    ColorItem ('Input arrow',       Offset + 20,

    ColorItem ('History button',    Offset + 21,
    ColorItem ('History sides',     Offset + 22,
    ColorItem ('History bar page',  Offset + 23,
    ColorItem ('History bar icons', Offset + 24,

    ColorItem ('List normal',       Offset + 25,
    ColorItem ('List focused',      Offset + 26,
    ColorItem ('List selected',     Offset + 27,
    ColorItem ('List divider',      Offset + 28,

    ColorItem('Information pane',  Offset + 29,
    Next))))))))))))))))))))))))))))));
end;

function HelpColorItems(const Next: PColorItem): PColorItem;

begin
  HelpColorItems :=
    ColorItem ('Frame passive',     128,
    ColorItem ('Frame active',      129,
    ColorItem ('Frame icons',       130,
    ColorItem ('Scroll bar page',   131,
    ColorItem ('Scroll bar icons',  132,
    ColorItem ('Normal text',       133,
    ColorItem ('Key word',          134,
    ColorItem ('Select key word',   135,
    Next))))))))
end;

function AniColorItems (const Next: PColorItem) : PColorItem;

begin
  AniColorItems :=
    ColorItem ('Background',       136,
    ColorItem ('Invaders',         137,
    ColorItem ('UFO',              138,
    ColorItem ('UFO bomb',         139,
    ColorItem ('UFO bomb explode', 140,
    ColorItem ('Base ship',        141,
    ColorItem ('Base ship shot',   142,
    ColorItem ('PCX graphics',     143,
    Next))))))))
end;

function SysColorItems (const Next: PColorItem) : PColorItem;

begin
  SysColorItems :=
    ColorItem ('Shadow',       144,
    ColorItem ('System error', 145,
    ColorItem ('Index error',  146,
    Next)))
end;

var

  D : PColorDialog;

begin
  D := New (PColorDialog,Init ('',
  ColorGroup ('Desktop',     DesktopColorItems(nil),
  ColorGroup ('Menus',       MenuColorItems(nil),
  ColorGroup ('Gray Windows',WindowColorItems(wpGrayWindow,nil),
  ColorGroup ('Blue Windows',WindowColorItems(wpBlueWindow,nil),
  ColorGroup ('Cyan Windows',WindowColorItems(wpCyanWindow,nil),
  ColorGroup ('Gray Dialogs',DlgColorItems(dpGrayDialog,nil),
  ColorGroup ('Blue Dialogs',DlgColorItems(dpBlueDialog,nil),
  ColorGroup ('Cyan Dialogs',DlgColorItems(dpCyanDialog,nil),
  ColorGroup ('Help',        HelpColorItems(nil),
  ColorGroup ('Animation',   AniColorItems(nil),
  ColorGroup ('System',      SysColorItems(nil),
  nil)))))))))))));
  D^.HelpCtx := hcOCColorsDBox;
  if ExecuteDialog (D,Application^.GetPalette) <> cmCancel then
  begin
    DoneMemory; {dispose all group buffers}
    ReDraw;     {redraw application with new palette}
    ShadowAttr := GetColor (144);   {tv shadow color}
    SysColorAttr := (GetColor (145) shl 8) or GetColor (145); {tv system error color}
    ErrorAttr := GetColor (146)     {tv palette index error color}
  end
end;

procedure AdjustPalette;

var

  D : PPalDlg;

begin
  D := New (PPalDlg,Init);
  D^.Options := D^.Options or ofCentered;
  D^.HelpCtx := hcAdjustPalette;
  if ExecuteDialog (D,nil) <> cmCancel then
    GetDACBlock (@DacPalette,0,256)
end;

procedure LoadConfigFile;

var

  F : PathStr;

begin
  F := SelectFile ('Load Config Stream','*.CFG',true);
  if F <> '' then
    RestoreDeskTop (F)
end;

procedure SaveConfigFile;

var

  F : PathStr;

begin
  F := SelectFile ('Save Config Stream','*.CFG',false);
  if F <> '' then
    SaveDeskTop (F)
end;

procedure TileableOnTop (P : PView); far;

begin {force all oftileable windows to top}
  if (P^.Options and ofTileable = ofTileable) then
    P^.MakeFirst
end;

begin
  if (Event.What = evCommand) and
  ((Event.Command = cmCascade) or
  (Event.Command = cmTile)) then {seperate oftileable windows from nontileable ones}
    Desktop^.ForEach (@TileableOnTop);
  inherited HandleEvent (Event);
  case Event.What of
    evCommand:
      begin
        case Event.Command of {process commands}
          cmLoadFont    : LoadFontFile;
          cmSaveFont    : SaveFontFIle;
          cmLoadPCX     : LoadPCXFile;
          cmSavePCX     : SavePCXFile;
          cmChangeDir   : ChangeDir;
          cmShellToDos  : ShellToDos;
          cmViewDoc     : ViewTextFile (appDocName);
          cmAbout       : AboutBox;
          cmLines1      : Lines1;
          cmLines2      : Lines2;
          cmEllipses1    : Ellipses1;
          cmEllipses2    : Ellipses2;
          cmEllipses3    : Ellipses3;
          cmRectangles1 : Rectangles1;
          cmRectangles2 : Rectangles2;
          cmClrGraphWin : ClearGraphWin;
          cmAsciiTab    : AsciiTab;
          cmInvaders    : InvadersDialog;
          cmUfo         : UfoDialog;
          cmShip        : ShipDialog;
          cmCloseAll    : ClearDeskTop;
          cmRestoreDef  : RestoreDefFont;
          cmScreenOpts  : ScreenOptions;
          cmColors      : Colors;
          cmAdjPal      : AdjustPalette;
          cmSaveConfig  : SaveConfigFile;
          cmLoadConfig  : LoadConfigFile
        else
          Exit
        end;
        ClearEvent (Event)
      end
  end
end;

procedure TCyberFont.InitDeskTop;

begin {set defaults}
  inherited InitDeskTop;
  DeskTop^.Background^.Pattern := '▒';
  Page := vgaPageLoc[1];
  PageOfs := vgaPageOfsLoc[1];
  DefChrHeight := BiosGetChrHeight;
  GetDACBlock (@DacPalette,0,256) {save current vga palette}
end;

procedure TCyberFont.InitMenuBar;

var

  R : TRect;

begin
  GetExtent (R);
  R.B.Y := R.A.Y+1;
  MenuBar := New (PMenuBar,Init (R,NewMenu (
    NewSubMenu ('~F~ile',hcFile,NewMenu (
    NewSubMenu ('~F~ont',hcFile,NewMenu (
      NewItem ('~L~oad...','',kbNoKey,cmLoadFont,hcLoadFont,
      NewItem ('~S~ave...','',kbNoKey,cmSaveFont,hcSaveFont,
      nil))),
    NewSubMenu ('~P~CX',hcFile,NewMenu (
      NewItem ('~L~oad...','',kbNoKey,cmLoadPCX,hcLoadPCX,
      NewItem ('~S~ave...','',kbNoKey,cmSavePCX,hcSavePCX,
      nil))),
      NewLine (
      NewItem ('~C~hange dir...','',kbNoKey,cmChangeDir,hcChangeDir,
      NewItem ('~D~os shell','F9',kbF9,cmShellToDos,hcDosShell,
      NewItem ('~V~iew doc','',kbNoKey,cmViewDoc,hcViewDoc,
      NewItem ('~A~bout','',kbNoKey,cmAbout,hcAbout,
      NewLine (
      NewItem ('E~x~it','Alt-X',kbAltX,cmQuit,hcExit,
      nil)))))))))),
    NewSubMenu ('~G~raphics',hcGraphics,NewMenu (
      NewSubMenu ('~L~ines',hcLines,NewMenu (
        NewItem ('Lines ~1~','',kbNoKey,cmLines1,hcLines,
        NewItem ('Lines ~2~','',kbNoKey,cmLines2,hcLines,
        nil))),
      NewSubMenu ('~E~llipses',hcEllipses,NewMenu (
        NewItem ('Ellipses ~1~','',kbNoKey,cmEllipses1,hcEllipses,
        NewItem ('Ellipses ~2~','',kbNoKey,cmEllipses2,hcEllipses,
        NewItem ('Ellipses ~3~','',kbNoKey,cmEllipses3,hcEllipses,
        nil)))),
      NewSubMenu ('~R~ectangles',hcRectangles,NewMenu (
        NewItem ('Rectangles ~1~','',kbNoKey,cmRectangles1,hcRectangles,
        NewItem ('Rectangles ~2~','',kbNoKey,cmRectangles2,hcRectangles,
        nil))),
      NewItem ('Clear ~g~raphics window','',kbNoKey,cmClrGraphWin,hcClearGraphWin,
      nil))))),
    NewSubMenu ('~A~nimation',hcAnimation,NewMenu (
      NewItem ('~A~SCII chart','',kbNoKey,cmAsciiTab,hcAsciiTable,
      NewItem ('~I~nvaders','F4',kbF4,cmInvaders,hcInvaders,
      NewItem ('~U~FO bomber','',kbNoKey,cmUfo,hcUFOBomber,
      NewItem ('~B~ase ship','',kbNoKey,cmShip,hcBaseShip,
      nil))))),
    NewSubMenu('~W~indow',hcWindows,NewMenu(
      StdWindowMenuItems(
      nil)),
    NewSubMenu ('~O~ptions',hcOptions,NewMenu (
      NewItem ('~D~efault font','Alt-D',kbNoKey,cmRestoreDef,hcDefaultFont,
      NewItem ('Scree~n~...','Alt-S',kbNoKey,cmScreenOpts,hcScreen,
      NewItem ('~C~olors...','',kbNoKey,cmColors,hcOColors,
      NewItem ('~A~djust Palette...','',kbNoKey,cmAdjPal,hcAdjustPalette,
      NewLine (
      NewItem ('~L~oad config','',kbNoKey,cmLoadConfig,hcLoadConfig,
      NewItem ('~S~ave config','',kbNoKey,cmSaveConfig,hcSaveConfig,
      nil)))))))),nil))))))))
end;

procedure TCyberFont.InitStatusLine;

var

  R : TRect;

begin
  GetExtent (R);
  R.A.Y := R.B.Y-1;
  StatusLine := New (PStatusLine,Init(R,
    NewStatusDef (0,$FFFF,
      NewStatusKey ('~F1~ Help', kbF1, cmHelp,
      NewStatusKey ('~Alt-F3~ Close',kbAltF3,cmClose,
      NewStatusKey ('~Alt-D~ Default font',kbAltD,cmRestoreDef,
      NewStatusKey ('~Alt-S~ Screen',kbAltS,cmScreenOpts,
      NewStatusKey ('~Alt-X~ Exit',kbAltX,cmQuit,
      NewStatusKey ('',kbCtrlF5,cmResize,
      NewStatusKey ('',kbF10,cmMenu,
      nil))))))),nil)))
end;

procedure TCyberFont.OutOfMemory;

begin
  MessageBox (#3'Not enough memory available to complete operation.  Try closing some windows!',
  nil,mfError+mfOkButton)
end;

procedure TCyberFont.LoadDesktop (var S : TStream);

var

  Pal : PString;

begin
  Pal := S.ReadStr;
  if Pal <> nil then
  begin
    Application^.GetPalette^ := Pal^;
    DoneMemory;
    DisposeStr (Pal)
  end
end;

procedure TCyberFont.StoreDesktop(var S: TStream);

var

  Pal: PString;

begin
  Pal := @Application^.GetPalette^;
  S.WriteStr (Pal)
end;

var

  CFApp : TCyberFont;

begin
  if VGACardActive then
  begin
    CFApp.Init;
    CFApp.Run;
    CFApp.Done
  end
  else
    PrintStr (#13#10'VGA display required to run CyberFont!'#13#10);
end.