Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/ULDIAL.ZIP/ULROOT.PAS

Pascal/Delphi Source File | 1990-06-25 | 12.7 KB | 421 lines

(***********************************************************************
     General Ojbects as Enhancements to Turbo Power OOP Professional
                  New Communications Technology, Inc.
                             Version 1.0
                          by John Poindexter
                             June 1, 1990
************************************************************************)
{$I ULDEFINE.INC}

{$IFNDEF roDEBUG}
{$A-,B-,E+,F+,I+,N-,O+,R-,S-,V-}
{$ELSE}
{$A-,B-,E+,F+,I+,N-,O+,R+,S+,V-}
{$ENDIF}

Unit ULRoot;

Interface

Uses OpRoot, OpCrt, OpColor, OpMouse, OpInline, OpString, OpCmd,
     OpFrame, OpWindow, OpPick, OpField, OpEntry, OpKey;

const
  ucULRoot  = 200;
  ucULDial  = 201;
  ucULData  = 202;
  ucULDbase = 203;

  { Error Codes and Messages }
  ecTooManyKeys         = 3001;
  ecNoLists             = 3002;
  ecKeyTooLong          = 3003;
  ecInvalidDbaseNum     = 3004;
  ecInvalidIndex        = 3005;
  ecNoVRecBuf           = 3006;
  ecRebuildReq          = 3007;
  ecTooManyVar          = 3008;
  ecDuplicateKeys       = 3009;
  ecNoChoice            = 3010;

  emTooManyKeys         : string[13] = 'Too many keys';
  emNoLists             : string[24] = 'Desc or Key Lists failed';
  emKeyTooLong          : string[15] = 'Key is too long';
  emInvalidDbaseNum     : string[31] = 'Requested Dbase not initialized';
  emInvalidIndex        : string[33] = 'Invalid index for data descriptor';
  emNoVRecBuf           : string[34] = 'VRec buffer too small or no memory';
  emRebuildReq          : string[38] = 'Index is damaged. Select Ok to rebuild';
  emTooManyVar          : string[36] = 'May only use 1 variable length field';
{ emESNotInitialized    : string[28] = 'Entry Screen not initialized';}
  emNoChoice            : string[23] = 'DialogBox has no choice';
  emISAM                : string[4]  = 'ISAM';
  emStatusHandlerFail   : string[20] = 'Status Handler failed';
  emPossibleRecovery    : string[35] = 'Recovery may be possible with Retry';

  mmAnyKeytoContinue    : string[27] = ' Press any key to continue ';

  SafetyBuffer : string[20] = '12345678901234567890';

  ULColorSet : ColorSet = (
    TextColor       : BlackonLtGray; TextMono       : $07;
    CtrlColor       : WhiteonBlue;   CtrlMono       : $07;
    FrameColor      : YellowonBlue;  FrameMono      : $0F;
    HeaderColor     : YellowonBlue;  HeaderMono     : $0F;
    ShadowColor     : BlackonBlack;  ShadowMono     : $07;
    HighlightColor  : WhiteonRed;    HighlightMono  : $70;
    PromptColor     : BlackonLtGray; PromptMono     : $07;
    SelPromptColor  : BlackonLtGray; SelPromptMono  : $07;
    ProPromptColor  : BlueonLtGray;  ProPromptMono  : $07;
    FieldColor      : BlackonLtGray; FieldMono      : $0F;
    SelFieldColor   : WhiteonBlue;   SelFieldMono   : $70;
    ProFieldColor   : BlueonLtGray;  ProFieldMono   : $07;
    ScrollBarColor  : YellowonBlue;  ScrollBarMono  : $07;
    SliderColor     : YellowonBlue;  SliderMono     : $07;
    HotSpotColor    : BlackonCyan;   HotSpotMono    : $07;
    BlockColor      : WhiteonBlue;   BlockMono      : $0F;
    MarkerColor     : YellowonLtGray;MarkerMono     : $70;
    DelimColor      : BlackonLtGray; DelimMono      : $0F;
    SelDelimColor   : WhiteonBlue;   SelDelimMono   : $70;
    ProDelimColor   : BlueonLtGray;  ProDelimMono   : $07;
    SelItemColor    : WhiteonRed;    SelItemMono    : $70;
    ProItemColor    : BrownonLtGray; ProItemMono    : $01;
    HighItemColor   : WhiteonRed;    HighItemMono   : $0F;
    AltItemColor    : BlueonLtGray;  AltItemMono    : $0F;
    AltSelItemColor : LtBlueonLtGray;AltSelItemMono : $70;
    FlexAHelpColor  : WhiteonLtGray; FlexAHelpMono  : $0F;
    FlexBHelpColor  : YellowOnRed;   FlexBHelpMono  : $01;
    FlexCHelpColor  : GreenonBlack;  FlexCHelpMono  : $70;
    UnselXrefColor  : YellowonBlack; UnselXrefMono  : $09;
    SelXrefColor    : WhiteonRed;    SelXrefMono    : $70;
    MouseColor      : WhiteonRed;    MouseMono      : $70
  );

  WindowStep : byte = 1;

var
  ULRootColorSet : ColorSet;
  HeadFootAttr : byte;

type

(************************************************************************
  The IndexDblList object desends from DoubleList and adds a GET method
  to return a pointer to the nth node.
************************************************************************)

  IndexDblListPtr = ^IndexDblList;
  IndexDblList = object(DoubleList)
    function Get(Index: word): DoubleNodePtr; virtual;
  end;

(************************************************************************
  The MStringArray descends from StringArray and adds a data field and
  methods for determining and getting the max string length in the array.
  For this to function you must use AddMString vice AddString.
************************************************************************)

  MStringArrayPtr = ^MStringArray;
  MStringArray = object(StringArray)
    msMaxLen : byte;
    constructor Init(Num, Amount: word);
    function AddMString(St : string): word;
    function GetMaxLen: byte;
  end;

(************************************************************************
  Global Routines
************************************************************************)

procedure MoveCmdWindow(WP: CommandWindowPtr);
procedure ResizeCmdWindow(WP: CommandWindowPtr);
procedure ToggleZoom(WP: CommandWindowPtr);
function IncPtr(P: pointer; W: word): pointer;
function GetGoodCoord(first, wide, maxwide: byte): byte;
function Extend(S : String; Len : Byte) : String;
procedure SimpStatus(UnitCode:byte; var Code: word; Msg:string);
function Center1(OuterWidth, InnerWidth: word): word;
function Center2(FirstCoord, InnerWidth: word): word;
procedure InitCrt;
procedure RestoreCrt;
procedure Abort;
procedure WriteFooter(Prompt : String);
function SizeOfObject(TypOf: pointer): word;
procedure PromoteAncestor(Ancestor, TypOf: pointer);

(***********************************************************************)
Implementation
(***********************************************************************)

{$IFDEF UseAdjustableWindows}

procedure MoveCmdWindow(WP: CommandWindowPtr);
  {-Move any window interactively}
var
  Finished : Boolean;
begin
  if WP^.IsZoomed then
    Exit;
  WriteFooter(' Use cursor keys to move, {Enter} to accept');
  Finished := False;
  with WP^ do
    repeat
      case ReadKeyWord of
        $4700 : MoveWindow(-WindowStep, -WindowStep); {Home}
        $4800 : MoveWindow(0, -WindowStep);           {Up arrow}
        $4900 : MoveWindow(WindowStep, -WindowStep);  {PgUp}
        $4B00 : MoveWindow(-WindowStep, 0);           {Left Arrow}
        $4D00 : MoveWindow(WindowStep, 0);            {Right Arrow}
        $4F00 : MoveWindow(-WindowStep, WindowStep);  {End}
        $5000 : MoveWindow(0, WindowStep);            {Down arrow}
        $5100 : MoveWindow(WindowStep, WindowStep);   {PgDn}
        $1C0D : Finished := True;                     {Enter}
      end;

      if ClassifyError(GetLastError) = etFatal then
        Abort;
    until Finished;

  WriteFooter('');
end;

procedure ResizeCmdWindow(WP: CommandWindowPtr);
  {-Resize any window interactively}
var
  Finished : Boolean;
begin
  if WP^.IsZoomed then
    Exit;
  WriteFooter(' Use cursor keys to resize, {Enter} to accept');
  Finished := False;
  with WP^ do
    repeat
      case ReadKeyWord of
        $4700 : ResizeWindow(-WindowStep, -WindowStep); {Home}
        $4800 : ResizeWindow(0, -WindowStep);           {Up}
        $4900 : ResizeWindow(WindowStep, -WindowStep);  {PgUp}
        $4B00 : ResizeWindow(-WindowStep, 0);           {Left}
        $4D00 : ResizeWindow(WindowStep, 0);            {Right}
        $4F00 : ResizeWindow(-WindowStep, WindowStep);  {End}
        $5000 : ResizeWindow(0, WindowStep);            {Down}
        $5100 : ResizeWindow(WindowStep, WindowStep);   {PgDn}
        $1C0D : Finished := True;                       {Enter}
      end;

      if ClassifyError(GetLastError) = etFatal then
        Abort;
    until Finished;

  WriteFooter('');
end;

procedure ToggleZoom(WP: CommandWindowPtr);
  {-Toggle zoom status of any window}
begin
  with WP^ do begin
    if IsZoomed then
      Unzoom
    else
      Zoom;

    if ClassifyError(GetLastError) = etFatal then
      Abort;
  end;
end;
{$ENDIF}

function IncPtr(P: pointer; W: word): pointer;
begin
  IncPtr := AddWordToPtr(Normalized(P), W)
end;

function GetGoodCoord(first, wide, maxwide: byte): byte;
  {adjusts first coordinate if necessary so that a display will fit on screen}
var
  i,j : integer;
begin
  i := first - 1 + wide;
  if i > Succ(maxwide) then
  begin
    i := i - Succ(maxwide);
    j := first - i;
    if j < 2 then GetGoodCoord := 2
    else GetGoodCoord := j;
  end
  else GetGoodCoord := first;
end;

function Extend(S : String; Len : Byte) : String;
  {-Pad or truncate string to specified length}
var
  SLen : Byte absolute S;
begin
  if SLen >= Len then begin
    SLen := Len;
    Extend := S;
  end
  else
    Extend := Pad(S, Len);
end;

const
  SavedState : boolean = false;

var
  (* Various Crt parameters that are saved for later restoration *)
  SaveAttr : byte;
  SaveChar : char;
  SaveXY, SaveScanLines : word;
  SaveMode : byte;
  SaveDir : string[64];
  SaveBreak, SaveEOF : boolean;
  {$IFDEF UseMouse}
  MouseState : boolean;
  {$ENDIF}

(* Initializes Crt and Save parameters *)
procedure InitCrt;
begin
  GetDir(0,SaveDir);
  GetCursorState(SaveXY, SaveScanlines);
  SaveBreak := CheckBreak;
  SaveEOF := CheckEOF;
  ReInitCrt;
  SaveMode := LastMode;
  SaveAttr := ReadAttrAtCursor;
  SaveChar := ReadCharAtCursor;
  SavedState := true;
  {$IFDEF UseMouse}
  if MouseInstalled then HideMousePrim(MouseState);
  {$ENDIF}
end;

(* Restores Global Parameters to their original *)
procedure RestoreCrt;
begin
  {$IFDEF UseMouse}
  if MouseInstalled then ShowMousePrim(MouseState);
  {$ENDIF}
  ChDir(SaveDir);
  RestoreCursorState(SaveXY, SaveScanlines);
  CheckBreak := SaveBreak;
  CheckEOF := SaveEOF;
  TextMode(SaveMode);
  TextAttr := SaveAttr;
  TextChar := SaveChar;
  ClrScr;
end;

(* Centering Functions *)
function Center1(OuterWidth, InnerWidth: word): word;
begin
  Center1 := (OuterWidth - InnerWidth) div 2 + 1;
end;

function Center2(FirstCoord, InnerWidth: word): word;
begin
  Center2 := FirstCoord + InnerWidth - 1;
end;

(* Simple Status and Error Handler *)
procedure SimpStatus(UnitCode:byte; var Code: word; Msg:string);
begin
  RingBell;
  WriteLn(Msg, 'Unit: ',UnitCode,' Error: ',Code);
end;

(* MStringArray Methods *)
constructor MStringArray.Init(Num, Amount: word);
begin
  StringArray.Init(Num, Amount);
  msMaxLen := 0;
end;

function MStringArray.AddMString(St : string): word;
var
  Len : byte absolute St;
  Index : word;
begin
  Index := AddString(St);
  if Index <> 0 then msMaxLen := MaxWord(msMaxLen, Len);
  AddMString := Index;
end;

function MStringArray.GetMaxLen: byte;
begin
  GetMaxLen := msMaxLen;
end;

(* IndexDblList Methods *)
function IndexDblList.Get(Index: word): DoubleNodePtr;
var i : word;
    p : DoubleNodePtr;
begin
  if Index > Size then
  begin
    Get := nil;
    Exit;
  end;
  p := Head;
  for i := 2 to Index do p := Next(p);
  Get := p;
end;

(*********************)

procedure Abort;
  {-Abort the program with an out-of-memory error message}
begin
  if SavedState then RestoreCrt
  else
  begin
    NormalCursor;
    ClrScr;
  end;
  WriteLn('Insufficient memory available to continue.');
  Halt(1);
end;

procedure WriteFooter(Prompt : String);
  {-Write a footer on the menu line}
{$IFDEF UseMouse}
var
  SaveMouse : Boolean;
{$ENDIF}
begin
  {$IFDEF UseMouse}
  HideMousePrim(SaveMouse);
  {$ENDIF}

  FastWrite(Extend(Prompt, ScreenWidth), ScreenHeight, 1, HeadFootAttr);
  GotoXYabs(Length(Prompt)+2, ScreenHeight);

  {$IFDEF UseMouse}
  ShowMousePrim(SaveMouse);
  {$ENDIF}
end;

function SizeOfObject(TypOf: pointer): word;
  { TypOf must have been returned by the TypeOf function which returns the
    address of the VMT. The first word of the VMT is the size of the instance.}
begin
  SizeOfObject := word(TypOf^);
end;

procedure PromoteAncestor(Ancestor, TypOf: pointer);
  { This only works if the VMT link is the first two bytes of the ancestor
    as in descendants of Root and TypOf has been returned by
    TypeOf(Descendant). Otherwise it most probably will cause a crash! }
var
  VMTOfs : word;
begin
  VMTOfs := Word(PtrDiff(Ptr(DSeg,0),TypOf));
  Move(VMTOfs, Ancestor^, 2);  {fixup VMT link}
end;

(*******************************)
begin
  ULRootColorSet := ULColorSet;
  with ULRootColorSet do
  HeadFootAttr := ColorMono(HighLightColor, HighLightMono);
End.