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

Pascal/Delphi Source File | 1990-06-25 | 14.3 KB | 492 lines

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

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

Unit ULDial;

Interface

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

const

(* Status Handler Return Codes *)
  scOk      = 1;
  scCancel  = 2;
  scRetry   = 3;
  scTimeOut = 99;

type

(************************************************************************
  DialogPick is a descendant of PickList for use as a WindowField
************************************************************************)

  DialogPickPtr = ^DialogPick;
  DialogPick = object(PickList)
    dpChoices : MStringArrayPtr;
    constructor Init(X1,Y1,X2,Y2: byte; var Colors: ColorSet;
                    Options: longint; ItemWidth: byte;
                    NumItems: word; Orientation: pkGenlProc;
                    CommandHandler: pkGenlProc;
                    PickOptions: word; Choices: MStringArrayPtr);
    procedure ItemString(Item: word; Mode: pkMode; var IType: pkItemType;
                         var IString: string); virtual;
    procedure ProcessSelf; virtual;
  end;

(************************************************************************
  DialogBox displays text, a string entry field and provides choices
  for exiting.
************************************************************************)

  DialogBoxPtr = ^DialogBox;
  DialogBox = object(Root)
    dlX1,dlY1,dlX2,dlY2 : word;   {Coordinates of Entry Screen}
    dlHeader : string[78];
    dlHeaderPos : HeaderPosType;
    dlText : MStringArrayPtr;
    dlChoices : MStringArrayPtr;
    dlTNum, dlCNum : byte;
    dlEntry : EntryScreenPtr;
    dlPick : DialogPickPtr;
    dlPrompt : string;
    dlpRow, dlpCol, dlfRow, dlfCol: word;
    dlRows : word;
    dlPicture : string;
    dlfWidth : word;
    dlHelpIndex : word;
    dlEditSt: string;
    dlTimeOut : word;
    dlLastChoice : word;
    dlLastError: word;
    dlNumTextLines : byte;
    dlTotalTextChars : word;
    dlNumChoices : byte;
    dlTotalChoiceChars : word;
    constructor Init(NumTextLines, TotalTextChars,
                     NumChoices, TotalChoiceChars: word);
    destructor Done; virtual;
    procedure Clear;
    function GetLastError: word;
    procedure Process; virtual;
    procedure AddMessageString(Msg: string);
    procedure AddChoiceString(Choice: string);
    procedure AddStringEntryField(Prompt: string; pRow, pCol: word;
                                  Picture: string; fRow, fCol: word;
                                  fWidth: byte; HelpIndex: word;
                                  EditSt: string);
    function CreateBox: boolean; virtual;
    procedure AddHeader(S: string; Posn: HeaderPosType);
    function GetLastChoice: word;
    function GetEditedString: string;
    procedure SetTimeOut(Delay: word);
  end;

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

(* DialogPick Methods *)

constructor DialogPick.Init(X1,Y1,X2,Y2: byte; var Colors: ColorSet;
                            Options: longint; ItemWidth: byte;
                            NumItems: word; Orientation: pkGenlProc;
                            CommandHandler: pkGenlProc;
                            PickOptions: word; Choices: MStringArrayPtr);
begin
  if not PickList.InitAbstractDeluxe(X1,Y1,X2,Y2,Colors,Options,ItemWidth,
                                     NumItems,Orientation,CommandHandler,
                                     PickOptions) then Fail;
  dpChoices := Choices;
end;

procedure DialogPick.ItemString(Item: word; Mode: pkMode; var IType: pkItemType;
                               var IString: string);
begin
  if Mode = pkGetType then Exit;
  IString := dpChoices^.GetString(Item);
  Case Mode of
    pkDisplay : begin
                  Insert(^B, Istring, Length(Istring));
                  Insert(^B, Istring, 4);
                  Insert(^A, Istring, 4);
                  Insert(^A, Istring, 3);
                  Insert(^B, Istring, 3);
                  Insert(^B, Istring, 2);
                end;
    pkSearch  : IString := Copy(IString, 3, Length(IString)-4);
  end;
end;

procedure DialogPick.ProcessSelf;
begin
  PickList.ProcessSelf;
  if (GetLastCommand = ccSelect) or (GetLastcommand = ccMouseSel) then
    SetLastCommand(ccDone)
  else if GetLastCommand = ccUser0 then SetLastCommand(ccBackTab);
end;

(* DialogBox Methods

                   dlX1
               dlY1┌─────────────────────┐
                   │     X1        X2    │
                   │   Y1┌────┐┌────┐    │
                   │     └────┘└────┘    │
                   └─────────────────────┘dlY2
                                      dlX2
*)
constructor DialogBox.Init(NumTextLines, TotalTextChars,
                           NumChoices, TotalChoiceChars: word);
begin
  if not Root.Init then Fail;
  dlPrompt := '';
  dlpRow := 0;
  dlpCol := 0;
  dlPicture := '';
  dlfRow := 0;
  dlfCol := 0;
  dlRows := 0;
  dlfWidth := 0;
  dlHelpIndex := 0;
  dlEditSt := '';
  dlLastError := 0;
  dlTimeOut := 0;
  dlLastChoice := 0;
  dlHeader := '';
  dlEntry := nil;
  dlPick := nil;
  dlNumTextLines := NumTextLines;
  dlTotalTextChars := TotalTextChars;
  dlNumChoices := NumChoices;
  dlTotalChoiceChars := TotalChoiceChars;
  dlText := New(MStringArrayPtr,Init(NumTextLines, TotalTextChars));
  dlChoices := New(MStringArrayPtr,Init(NumChoices, TotalChoiceChars));
  if (dlText = nil) or (dlChoices = nil) then
  begin
    if dlText <> nil then Dispose(dlText, Done);
    if dlChoices <> nil then Dispose(dlChoices, Done);
    Root.Done;
    Fail;
  end;
end;

destructor DialogBox.Done;
begin
  if dlEntry <> nil then Dispose(dlEntry, Done); {this also destoys dlPick}
  if dlChoices <> nil then Dispose(dlChoices,Done);
  if dlText <> nil then Dispose(dlText,Done);
  PickCommands.AddCommand(ccUp, 1, Up, 0);  {restore normal commands}
  Root.Done;
end;

procedure DialogBox.Clear;
begin
  dlPrompt := '';
  dlpRow := 0;
  dlpCol := 0;
  dlPicture := '';
  dlfRow := 0;
  dlfCol := 0;
  dlRows := 0;
  dlfWidth := 0;
  dlHelpIndex := 0;
  dlEditSt := '';
  dlLastError := 0;
  dlTimeOut := 0;
  dlLastChoice := 0;
  dlHeader := '';
  if dlEntry <> nil then Dispose(dlEntry, Done); {this also destoys dlPick}
  dlEntry := nil;
  dlPick := nil;
  if dlChoices <> nil then Dispose(dlChoices,Done);
  if dlText <> nil then Dispose(dlText,Done);
  dlText := New(MStringArrayPtr,Init(dlNumTextLines, dlTotalTextChars));
  dlChoices := New(MStringArrayPtr,Init(dlNumChoices, dlTotalChoiceChars));
end;

function DialogBox.GetLastError;
begin
  GetLastError := dlLastError;
  dlLastError := 0;
end;

procedure DialogBox.Process;
var
  LastCommand : word;
  TimeOut : longint;
begin
  if not CreateBox then
  begin
    SimpStatus(ucULRoot, dlLastError, 'Creation DialogBox failed.');
    Done;
    Halt(1);
  end;
  if dlTimeOut <> 0 then
  with dlEntry^ do
  begin
    Draw;
    TimeOut := TimeMS + dlTimeOut;
    Repeat until KeyPressed or (TimeMS > TimeOut);
    if not KeyPressed then
    begin
      dlLastChoice := scTimeOut;
      Exit;
    end;
  end;
  with dlEntry^ do
  begin
    ClearErrors;
    Repeat
      Process;
      LastCommand := GetLastCommand;
    until (LastCommand = ccDone) or (LastCommand = ccError);
    Erase;
    if LastCommand = ccError then
    begin
      dlLastError := RawError;
      SimpStatus(ucULDial, dlLastError, 'DialogBox problem.');
      Done;
      Halt(1);
    end;
    dlLastChoice := dlPick^.GetLastChoice;
  end;
end;

procedure DialogBox.AddMessageString(Msg: string);
var
  status : word;
  Len : byte absolute Msg;
begin
  if Len > (ScreenWidth - 2) then Len := ScreenWidth-2;
  status := dlText^.AddMString(Msg);
  if status = 0 then dlLastError := ecOutOfMemory;
end;

procedure DialogBox.AddChoiceString(Choice: string);
var
  Status : word;
  Temp : string;
  Len : byte absolute temp;
  MaxLen : byte;
  i,j : byte;
begin
  i := 0;
  MaxLen := 0;
  Repeat
    Inc(i);
    Temp := ExtractWord(i,Choice,[' ']);
    MaxLen := MaxWord(MaxLen,Len);
  until Len = 0;
  Dec(i);
  for j := 1 to i do
  begin
    Temp := '│ '+Pad(ExtractWord(j,Choice,[' ']),MaxLen)+' │';
    status := dlChoices^.AddMString(temp);
  end;
  if status = 0 then dlLastError := ecOutOfMemory;
end;

procedure DialogBox.AddStringEntryField(Prompt: string; pRow, pCol: word;
                              Picture: string; fRow, fCol: word;
                              fWidth: byte; HelpIndex: word;
                              EditSt: string);
begin
  dlPrompt := Prompt;
  if pRow = fRow      then begin dlpRow := 1; dlfRow := 1; dlRows := 1; end
  else if pRow < fRow then begin dlpRow := 1; dlfRow := 2; dlRows := 2; end
  else                     begin dlpRow := 2; dlfRow := 1; dlRows := 2; end;
  dlpCol := pCol;
  dlfCol := fCol;
  dlPicture := Picture;
  dlfWidth := fWidth;
  dlHelpIndex := HelpIndex;
  dlEditSt := EditSt;
end;

function DialogBox.CreateBox: boolean;
const
  SelColorFlex : FlexAttrs = (0,0,0,0);
  SelMonoFlex  : FlexAttrs = (0,0,0,0);
  UnsColorFlex : FlexAttrs = (0,0,0,0);
  UnsMonoFlex  : FlexAttrs = (0,0,0,0);

var
  X1,Y1,X2 : word;  {coordinates of PickList}
  WWidth, Twidth, Cwidth, Pwidth : byte;
  status : word;
  i : byte;
  Line : string;
  Len : byte absolute Line;

  function BoxLine(Num,CWid,PWid: byte; ChL,ChR: char): string;
  var j : byte;
  begin
    Line := '';
    for j := 1 to Num do
    begin
      Line := Line+ChL+CharStr('─',Cwid-2)+ChR;
      if Len > Pwid then begin Len := (j-1)*Cwid; Exit; end;
    end;
    BoxLine := Line;
  end;

begin
  CreateBox := false;
  if (dlEntry <> nil) and (dlPick <> nil) then
  begin
    CreateBox := true;
    Exit;
  end;
  { Calculate whether Text or Choices are widest }
  WWidth := ScreenWidth - 2;
  Twidth := dlText^.GetMaxLen;
  if Twidth > WWidth then Twidth := WWidth;
  dlTNum := dlText^.NumStrings;
  if dlTNum > ScreenHeight-5-dlRows then dlTNum := ScreenHeight-5-dlRows;
  Cwidth := dlChoices^.GetMaxLen;
  dlCNum := dlChoices^.NumStrings;
  if (dlCNum = 0) then
  begin
    dlLastError := epFatal+ecNoChoice;
    Exit;
  end;
  Pwidth := dlCNum * Cwidth;
  if (Pwidth > Twidth) then
  begin
    if Pwidth > WWidth then Pwidth := WWidth
    else WWidth := Pwidth;
  end
  else WWidth := Twidth;
  { If there is a StringEntryField then, calculate widest.}
  if dlRows > 0 then
  begin
    if dlpRow = dlfRow then
    begin
      Twidth := dlfCol+dlfWidth-1;
      if Twidth > ScreenWidth-2 then Twidth := ScreenWidth-2;
    end
    else Twidth := MaxWord(dlpCol+Length(dlPrompt)-1, dlfCol+dlfWidth-1);
    WWidth := MaxWord(WWidth, Twidth);
    if Twidth < WWidth then
    begin
      Twidth := (WWidth - Twidth) div 2;
      dlpCol := dlpCol + Twidth;
      dlfCol := dlfCol + Twidth;
    end;
  end;
  X1 := Center1(ScreenWidth,Pwidth);
  X2 := Center2(X1,PWidth);
  dlX1 := Center1(ScreenWidth,WWidth);
  dlX2 := Center2(dlX1,WWidth);
  dlY1 := Center1(ScreenHeight,dlTNum+3+dlRows);
  dlY2 := Center2(dlY1,dlTNum+3+dlRows);
  Y1 := dlY2 - 1;
  dlPick := New(DialogPickPtr,Init(X1,Y1,X2,Y1,ULRootColorSet,
            wClear+wNoCoversBuffer, Cwidth, dlCNum, PickHorizontal,
            SingleChoice, DefPickOptions-pkStick, dlChoices));
  if dlPick = nil then Exit;
  with ULRootColorSet do
  begin
    UnsColorFlex[0] := TextColor;
    UnsMonoFlex[0]  := TextMono;
    UnsColorFlex[1] := FlexAHelpColor;
    UnsMonoFlex[1]  := FlexAHelpMono;
    UnsColorFlex[2] := TextColor;
    UnsMonoFlex[2]  := TextMono;
    SelColorFlex[0] := TextColor;
    SelMonoFlex[0]  := TextMono;
    SelColorFlex[1] := FlexAHelpColor;
    SelMonoFlex[1]  := FlexAHelpMono;
    SelColorFlex[2] := SelItemColor;
    SelMonoFlex[2]  := SelItemMono;
  end;
  with dlPick^ do
  begin
    SetPickFlex(pkNormal, True, SelColorFlex, SelMonoFlex);
    SetPickFlex(pkNormal, False, UnsColorFlex, UnsMonoFlex);
    SetErrorProc(SimpStatus);
    SetSearchMode(PickCharSearch);
  end;
  PickCommands.AddCommand(ccUser0, 1, Up, 0);
  dlEntry := New(EntryScreenPtr, InitCustom(dlX1,dlY1,dlX2,dlY2,
                 ULRootColorSet, wClear+wBordered));
  if dlEntry = nil then Exit;
  {$IFDEF UseMouse}
  if MouseInstalled then
  begin
    PickCommands.cpOptionsOn(cpEnableMouse);
    EntryCommands.cpOptionsOn(cpEnableMouse);
    MouseGotoXY(X1+1,Y1);
  end;
  {$ENDIF}
  with dlEntry^ do
  begin
    SetErrorProc(SimpStatus);
    if dlHeader <> '' then wFrame.AddHeader(dlHeader, dlHeaderPos);
    wFrame.AddShadow(shBR, shOverWrite);
    for i := 1 to dlTNum do
    begin
      Line := dlText^.GetStringPtr(i)^;
      if Len > WWidth then Len := WWidth;
      AddTextField(Center(Line,WWidth),i,1);
    end;
    Y1 := dlTNum+dlRows+1;
    X1 := X1-dlX1+1;
    AddTextField(BoxLine(dlCNum,Cwidth,Pwidth,'┌','┐'), Y1,X1);
    AddTextField(BoxLine(dlCNum,Cwidth,Pwidth,'└','┘'), Y1+2,X1);
    if dlRows > 0 then
    begin
      esFieldOptionsOff(efAutoAdvance);
      AddStringField(dlPrompt,dlTNum+dlpRow,dlpCol,dlPicture,
                     dlTNum+dlfRow,dlfCol,dlfWidth,
                     dlHelpIndex,dlEditSt);
    end;
    AddWindowField('',Y1+1,X1,Y1+1,X1, dlHelpIndex,dlPick^);
    dlLastError := RawError;
    if dlLastError <> 0 then Exit;
  end;
  CreateBox := true;
end;

procedure DialogBox.AddHeader(S: string; Posn: HeaderPosType);
begin
  dlHeaderPos := Posn;
  dlHeader := S;
end;

function DialogBox.GetLastChoice: word;
begin
  GetLastChoice := dlLastChoice;
end;

function DialogBox.GetEditedString: string;
begin
  GetEditedString := dlEditSt;
end;

procedure DialogBox.SetTimeOut(Delay: word);
begin
  dlTimeOut := Delay;
end;

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

{Initialization}
begin
end.