Shareware Supreme Volume 6 #1/swsii.zip/swsii/215/DDJ11A92.ZIP/TVTIME.ASC

Text File | 1992-10-29 | 11KB | 450 lines

_EXTENDING TURBO VISION_
by Scott Nichol

[LISTING ONE]


{***********************************************************************}
{   BIOSTICK.PAS                                                        }
{                                                                       }
{   Support for BIOS tick counter.  The new BIOS tick event is of class }
{   evMetaBroadcast, command cmBiosTick.  The Event.InfoLong field      }
{   contains the tick counter value at the time of the event.  The      }
{   current value can be obtained using the GetBiosTicks function.      }
{   Because this event is generated on a cooperative rather than        }
{   preemptive basis, there may not be an event generated for every     }
{   tick of the counter.  Nor should any assumptions be made about the  }
{   accuracy of the periodicity of the event: the nominal periodicity   }
{   of 55 milliseconds will only be obtained when no other events are   }
{   generated and cmBiosTick handling takes under 55 milliseconds.      }
{***********************************************************************}

{$R-,S-}

unit
  BiosTick;

interface

uses
  Drivers;

procedure GetBiosTickEvent(var Event: TEvent);
function GetBiosTicks: LongInt;

implementation

uses
  Cmds;

var
  BiosTicks: LongInt absolute $40:$6c;

procedure GetBiosTickEvent(var Event: TEvent);
const
  OldTicks: LongInt = 0;
begin
  if BiosTicks <> OldTicks then begin
    OldTicks := BiosTicks;
    with Event do begin
      What := evMetaBroadcast;
      Command := cmBiosTick;
      InfoLong := OldTicks;
    end;
  end else
    Event.What := evNothing;
end;

function GetBiosTicks: LongInt;
begin
  GetBiosTicks := BiosTicks;
end;

end.

[LISTING TWO]

{***********************************************************************}
{   TICKVIEW.PAS                                                        }
{                                                                       }
{   Views to be driven by cmBiosTick.  The heap and clock views were    }
{   inspired by the Gadgets unit provided by Borland in the TVDEMOS     }
{   subdirectory of Turbo Pascal 6.0.                                   }
{***********************************************************************}

unit TickView;

{$R-,S-,V-}

interface

uses
  Drivers, Objects, Views, App;

type
  PTickView = ^TTickView;
  TTickView = object(TView)
    Display: Boolean;
    constructor Init(var Bounds: TRect);
    procedure Draw; virtual;
    procedure HandleEvent(var Event: TEvent); virtual;
    function DoDraw: Boolean; virtual;
    procedure DrawInfo(var S: String); virtual;
    procedure ToggleDisplay; virtual;
  end;

  PHeapView = ^THeapView;
  THeapView = object(TTickView)
    OldMem: LongInt;
    constructor Init(var Bounds: TRect);
    function DoDraw: Boolean; virtual;
    procedure DrawInfo(var S: String); virtual;
  end;

  PClockView = ^TClockView;
  TClockView = object(TTickView)
    OldTime: LongInt;
    TimeStr: String[8];
    constructor Init(var Bounds: TRect);
    function DoDraw: Boolean; virtual;
    procedure DrawInfo(var S: String); virtual;
  end;

implementation

uses
  Dos,
  BiosTick, Cmds;

{------ TTickView (abstract) ------}

constructor TTickView.Init(var Bounds: TRect);
begin
  TView.Init(Bounds);
  EventMask := EventMask or evMetaBroadcast;
  Display := True;
end;

procedure TTickView.Draw;
var
  S: String;
  B: TDrawBuffer;
  C: Byte;
begin
  C := GetColor(2);
  MoveChar(B, ' ', C, Size.X);
  DrawInfo(S);
  if Display then
    MoveStr(B, S, C);
  WriteLine(0, 0, Size.X, 1, B);
end;

procedure TTickView.HandleEvent(var Event: TEvent);
begin
  TView.HandleEvent(Event);
  if Event.What = evMetaBroadcast then
    case Event.Command of
    cmBiosTick:
      if DoDraw then DrawView;
    end;
end;

function TTickView.DoDraw: Boolean;
begin
  Abstract;
end;

procedure TTickView.DrawInfo(var S: String);
begin
  Abstract;
end;

procedure TTickView.ToggleDisplay;
begin
  Display := not Display;
  DrawView;
end;

{----------- THeapView ------------}

constructor THeapView.Init(var Bounds: TRect);
begin
  TTickView.Init(Bounds);
  OldMem := 0;
end;

function THeapView.DoDraw: Boolean;
begin
  DoDraw := OldMem <> MemAvail;
end;

procedure THeapView.DrawInfo(var S: String);
begin
  OldMem := MemAvail;
  Str(OldMem: Size.X, S);
end;

{---------- TClockView ------------}

constructor TClockView.Init(var Bounds: TRect);
begin
  TTickView.Init(Bounds);
  OldTime := 0;
end;

function TClockView.DoDraw: Boolean;
begin
  DoDraw := (GetBiosTicks - OldTime) >= 18;
end;

procedure TClockView.DrawInfo(var S: String);
var
  Hour, Minute, Second, Sec100: Word;
  Param: record
    Hr, Min, Sec: LongInt;
  end;
begin
  OldTime := GetBiosTicks;
  GetTime(Hour, Minute, Second, Sec100);
  with Param do begin
    Hr := Hour;
    Min := Minute;
    Sec := Second;
  end;
  FormatStr(S, '%02d:%02d:%02d', Param);
end;

end.





[EXTRA LISTING #1]

{***********************************************************************}
{   TVTIME.PAS                                                          }
{                                                                       }
{   A short program to demonstrate the addition of a new TV event class }
{   that can be broadcast outside of the event chain focus.  It uses a  }
{   specific command based on the BIOS timer tick counter.              }
{                                                                       }
{   Copyright (c) 1992 Charles Scott Nichol.  All rights reserved.      }
{***********************************************************************}

{$R-,S-,X+}

program
  TVTime;

uses
  App, Dialogs, Drivers, Menus, MsgBox, Objects, Views,
  BiosTick, Cmds, TickView;

type
  TTimeApp = object(TApplication)
    MetaSupport: Boolean;
    Clock: PClockView;
    Heap: PHeapView;
    constructor Init;
    procedure GetEvent(var Event: TEvent); virtual;
    procedure HandleEvent(var Event: TEvent); virtual;
    procedure InitDeskTop; virtual;
    procedure InitMenuBar; virtual;
    procedure InitStatusLine; virtual;
    procedure OutOfMemory; virtual;
  end;

const
  cmAbout = 100;
  cmToggleClock = 101;
  cmToggleHeap = 102;
  cmToggleMeta = 103;

{----------- TTimeApp ------------}

constructor TTimeApp.Init;
var
  R: TRect;
begin
  TApplication.Init;

  MetaSupport := True;

  GetExtent(R);
  R.A.X := R.B.X - 8; R.B.Y := R.A.Y + 1;  {End of top line}
  Clock := New(PClockView, Init(R));
  if ValidView(Clock) = nil then
    Fail;
  Insert(Clock);

  GetExtent(R);
  R.A.X := R.B.X - 8; R.A.Y := R.B.Y - 1;  {End of bottom line}
  Heap := New(PHeapView, Init(R));
  if ValidView(Heap) = nil then begin
    Dispose(Clock);
    Fail;
  end;
  Insert(Heap);
end;

procedure TTimeApp.GetEvent(var Event: TEvent);
begin
  TApplication.GetEvent(Event);
  if Event.What = evNothing then begin
    GetBiosTickEvent(Event);               {Hook to add the BIOS tick event}
    if Event.What = evNothing then begin
      Event.What := evMetaBroadcast;
      Event.Command := cmIdle;             {Alternative to .Idle method}
    end;
    if MetaSupport and (Event.What = evMetaBroadcast) then begin
      if TopView <> @Self then begin       {We are not the current modal view}
        HandleEvent(Event);                {Force meta broadcast of event}
        ClearEvent(Event);                 {Prevent redundant processing}
      end;
    end;
  end;
end;

procedure TTimeApp.HandleEvent(var Event: TEvent);

  procedure About;
  const
    S1 = #3'Bios Tick Time/Heap Display Demo';
    S2 = #13#3'Copyright (c) 1992 Charles Scott Nichol';
    S3 = #13#3'All rights reserved';
    S4 = #13#3'Meta support is ';
  var
    D: PDialog;
    R: TRect;
    S5: String[15];
  begin
    R.Assign(0,0,49,10);
    D := New(PDialog, Init(R, 'About'));
    if MetaSupport then
      S5 := 'enabled'
    else
      S5 := 'disabled';
    with D^ do begin
      Options := Options or ofCentered;
      R.Assign(3, 2, Size.X - 2, Size.Y - 4);
      Insert(New(PStaticText, Init(R, S1+S2+S3+S4+S5)));
      R.Assign(19, 7, 29, 9);
      Insert(New(PButton, Init(R, 'O~k~', cmOK, bfDefault)));
      SelectNext(False);
    end;
    if ValidView(D) <> nil then begin
      DeskTop^.ExecView(D);
      Dispose(D, Done);
    end;
  end;

  procedure ToggleMeta;
  begin
    MetaSupport := not MetaSupport;
  end;

begin
  TApplication.HandleEvent(Event);
  if Event.What = evCommand then begin
    case Event.Command of
    cmAbout:
      About;
    cmToggleClock:
      Clock^.ToggleDisplay;
    cmToggleHeap:
      Heap^.ToggleDisplay;
    cmToggleMeta:
      ToggleMeta;
    end;
    ClearEvent(Event);
  end;
end;

procedure TTimeApp.InitDeskTop;
var
  R: TRect;
begin
  GetExtent(R);
  R.Grow(0,-1);            {Leave room for menu bar and status line}
  DeskTop := New(PDeskTop, Init(R));
end;

procedure TTimeApp.InitMenuBar;
var
  R: TRect;
begin
  GetExtent(R);
  R.B.Y := R.A.Y + 1;      {Top line only}
  MenuBar := New(PMenuBar, Init(R, NewMenu(
    NewSubMenu('~'#240'~', hcNoContext, NewMenu(
      NewItem('~A~bout', '', kbNoKey, cmAbout, hcNoContext,
      NewItem('Toggle ~C~lock Display', '', kbNoKey, cmToggleClock, hcNoContext,
      NewItem('Toggle ~H~eap Display', '', kbNoKey, cmToggleHeap, hcNoContext,
      NewLine(
      NewItem('E~x~it', '', kbNoKey, cmQuit, hcNoContext, nil)))))),
    nil))));
end;

procedure TTimeApp.InitStatusLine;
var
  R: TRect;
begin
  GetExtent(R);
  R.A.Y := R.B.Y - 1;      {Bottom line only}
  StatusLine := New(PStatusLine, Init(R,
    NewStatusDef(0, $FFFF,
      NewStatusKey('~Alt-X~ Exit', kbAltX, cmQuit,
      NewStatusKey('~Alt-M~ Toggle Meta Support', kbAltM, cmToggleMeta,
      NewStatusKey('~F10~ Menu', kbF10, cmMenu, nil))),
    nil)));
end;

procedure TTimeApp.OutOfMemory;
begin
  MessageBox(#3'Insufficient memory to complete operation', nil,
    mfError + mfOkButton);
end;

{----------- Program ------------}

var
  TimeApp: TTimeApp;
begin
  if TimeApp.Init then begin
    TimeApp.Run;
    TimeApp.Done;
  end;
end.


[EXTRA LISTING #2]

{***********************************************************************}
{   CMDS.PAS                                                            }
{                                                                       }
{   Constants for event and commands added.                             }
{                                                                       }
{   Copyright (c) 1992 Charles Scott Nichol.  All rights reserved.      }
{***********************************************************************}

unit
  Cmds;

interface

const
  evMetaBroadcast = $400;  {Use an unallocated bit from Event.What}

const
  cmBiosTick = 1000;       {These commands are for evMetaBroadcast}
  cmIdle = 1001;

implementation

end.