Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TURBO_TK.ZIP/IOTTT.PAS

Pascal/Delphi Source File | 1988-02-01 | 20.1 KB | 639 lines

{S-,R-,V-,D-,T-}
{\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\}
{         TechnoJocks Turbo Toolkit v4.00            Released: Feb 1, 1988    }
{                                                                             }
{         Module: IOTTT   --   screen input/editing routines                  }
{                                                                             }
{                       Copyright R. D. Ainsbury (c) 1986                     }
{\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\}

unit IOTTT;

interface

uses CRT,FastTTT,DOS,WinTTT,KeyTTT;

CONST
MaxInputFields = 40;       {alter as necessary}

TYPE
Str_Field_Defn = record
                      Upfield   : byte;
                      Downfield : byte;
                      Leftfield : byte;
                      Rightfield: byte;
                      X         : byte;
                      Y         : byte;
                      InString  : ^string;
                      StrLength : byte;
                      Format    : string;
                      Message   : string;
                      MsgX      : byte;
                      MsgY      : byte;
                      CursorX   : byte;
                      CursorInit: byte;
                      StrLocX   : byte;
                end;
Str_Field_Ptr = ^Str_Field_Defn;
InputZone = record
             HiF  : byte;
             HiB  : byte;
             LoF  : byte;
             LoB  : byte;
             MsgF : byte;
             MsgB : byte;
             TotalFields: byte;
             CurrentField : byte;
             IOEsc : boolean;
             IO_FieldsSet : boolean;
             Displayed   : boolean;
             IO_Beepon : boolean;
             IO_Putunderline : boolean;
             IO_Insert : boolean;
            end;
CONST
   IO_Settings : InputZone= (HiF:white;
                             HiB:blue;
                             LoF:blue;
                             LoB:lightgray;
                             MsgF:yellow;
                             MsgB:red;
                             TotalFields:MaxInputFields;
                             CurrentField : 1;
                             IOEsc : false;
                             IO_FieldsSet : false;
                             Displayed    : false;
                             IO_BeepOn    : true;
                             IO_PutUnderline: true;
                             IO_Insert : false);

var
  FieldDefn : array[0..MaxInputFields] of Str_Field_Ptr;
  IO_UserHook : pointer;

Procedure IO_Setfields(No_of_fields:byte);
Procedure IO_SetColors(HiFore,Hiback,LoFore,LoBack,MsgFore,MsgBack:byte);
Procedure IO_DefineMsg(DefID,DefX,DefY : byte; DefString : string);
Procedure IO_DefineStr(DefID,DefU,DefD,DefL,DefR,DefX,DefY:byte;
                         Var DefString : string;
                         DefFormat : string);
Procedure IO_DisplayFields;
Procedure IO_AllowEsc(OK:boolean);
Procedure IO_SoundBeeper(OK:boolean);
Procedure IO_ResetFields;
Procedure IO_Edit(var Return_code : integer);

implementation

Const
   FmtChars  : set of char = ['!','#','@','*'];
   IOUp       = #200;
   IODown     = #208;
   IORight    = #205;
   IOLeft     = #203;
   IODel      = #211;
   IOTotErase = #146;    {Alt-E}
   IOErase    = #160;    {Alt-D}
   IOFinish   = #207;    {End}   {maybe change to F10}
   IOEsc      = #27;
   IOTab      = #9;
   IOShiftTab = #143;
   IOEnter    = #13;
   IOIns      = #210;
   IOBackSp   = #8;
   IORightFld = #244;
   IOLeftFld  = #243;
   IOHelp     = #187;

Procedure CallFromIO(Ch: char; FieldID:integer;var ReturnStr:string);
          Inline($FF/$1E/IO_UserHook);

Function Int_to_Str(Number:Integer):string;
var Temp : string;
begin
    Str(Number,temp);
    Int_to_Str := temp;
end;

function Real_to_str(Number:real;Decimals:byte):string;
var Temp : string;
begin
    Str(Number:20:Decimals,Temp);
    repeat
         If copy(Temp,1,1) = ' ' then delete(Temp,1,1);
    until copy(temp,1,1) <> ' ';
    Real_to_Str := Temp;
end;

Function  Str_to_Int(Str:string):integer;
var temp,code : integer;
begin
    If length(Str) = 0 then
       Str_to_Int := 0
    else
    begin
       val(Str,temp,code);
       if code = 0 then
          Str_to_Int := temp
       else
          Str_to_Int := 0;
    end;
end;

Procedure IOError(Code:byte;value:real);    {fatal error -- msg and halt}
var Message:string;
begin
    {Clrscr;}
    Case Code of
    1 : Message := 'Fatal Error 1: Invalid value of '+Real_to_Str(value,0)
                   +' in IO_SetFields with a MaxInputFields of '
                   +Real_to_Str(MaxInputFields,0);
    2 : Message := 'Fatal Error 2 : Insufficient Memory on Heap. Available '
                   +Real_to_Str(MaxAvail,0)+'. Required '
                   +Real_to_Str(value,0);
    3 : Message := 'Fatal Error 3 : Define IO_Setfields before IO_DefineStr';
    4 : Message := 'Fatal Error 4 : IO_DefineStr ID: '
                   +Real_to_Str(value,0)+' out of range';
    5 : Message := 'Fatal Error 5 : Invalid exit field defined in IO_DefinStr ID: '
                   +Real_to_Str(value,0);
    6 : message := 'Fatal Error 6 : Invalid X or Y value defined in IO_DefineStr ID: '
                   +Real_to_Str(value,0);
    7 : Message := 'Fatal Error 7 : Define IO_Setfields before IO_DefineMsg';
    8 : Message := 'Fatal Error 8 : IO_DefineMsg ID: '+Real_to_Str(value,0)
                   +' out of range';
    9 : message := 'Fatal Error 9 : Invalid X or Y value defined in IO_DefineMsg ID: '
                   +Real_to_Str(value,0);
    10 : Message := 'Fatal Error 10 : Only use IO_ResetFields after IO_Setfields';
    11 : Message := 'Fatal Error 11 : IO_Setfields already operative,'
                    +' reset with IO_Resetfields';
    else Message := 'Aborting';
    end; {case}
    WriteAT(1,12,black,lightgray,Message);
    Repeat Until keypressed;
    Halt;
end;    {proc IOError}

Procedure Ding;
begin
    If IO_Settings.IO_BeepOn then
       sound(750);delay(150);nosound;
end;    {proc Ding}

Procedure InsertMode;       {change cursor style when in insert mode}
begin
    IO_Settings.IO_Insert := not IO_Settings.IO_Insert;
    If IO_Settings.IO_Insert then
       HalfCursor
    else
       OnCursor;
end;

Procedure IO_Setfields(No_of_fields:byte);
var
  I:integer;
  Room_needed : integer;
begin
    If IO_Settings.IO_FieldsSet then IOError(11,0);       {already set}
    If No_of_Fields in [1..MaxInputFields] then
    begin
        Room_needed := sizeof(FieldDefn[0]^);
        For I := 0 to No_of_fields do
        begin
            If MaxAvail >= Room_needed then
            begin
                GetMem(FieldDefn[I],Room_Needed);
                with FieldDefn[I]^ do
                begin
                    Upfield     := 0;
                    Downfield   := 0;
                    Leftfield   := 0;
                    Rightfield  := 0;
                    X           := 0;
                    Y           := 0;
                    StrLength   := 0;
                    Format      := '';
                    Message     := '';
                    MsgX        := 81;     {zero means auto-center}
                    MsgY        := 0;
                    CursorX     := 0;
                    CursorInit  := 0;
                    StrLocX     := 1;
                end;   {With}
            end
            else  {not enough heap space}
                IOError(2,Room_needed); {end MemAvail If clause}
        end;
        IO_Settings.TotalFields := No_of_Fields;
        IO_Settings.IO_FieldsSet := true;
    end
    else  {Invalid No_of_fields}
       IOError(1,No_of_fields);
end;  {Proc IO_SetFields}

Procedure IO_SetColors(HiFore,Hiback,LoFore,LoBack,MsgFore,MsgBack:byte);
begin
    With IO_Settings do
    begin
        HiF := HiFore;
        HiB := HiBack;
        LoF := LoFore;
        LoB := LoBack;
        MsgF := MsgFore;
        MsgB := MsgBack;
    end;
end;    {Proc IO_SetColors}

Procedure IO_DefineMsg(DefID,DefX,DefY : byte; DefString : string);
begin
    If not IO_Settings.IO_FieldsSet then IOError(7,0);
    If (DefID < 1) or (DefID > IO_Settings.TotalFields) then IOError(8,DefID);
    If (DefX < 0) or (DefX > 80) or (DefY < 1) or (DefY > 25) then IOError(9,DefID);
    With FieldDefn[Defid]^ do
    begin
        MsgX := DefX;
        MsgY := DefY;
        Message := DefString;
    end;
end;  {proc IO_DefineMsg}

Procedure IO_DefineStr(DefID,DefU,DefD,DefL,DefR,DefX,DefY:byte;
                         Var DefString : string;
                         DefFormat : string);

             Function Max_string_length : byte;
             var I,Counter : byte;
             begin
                 Counter := 0;
                 For I := 1 to length(DefFormat) do
                     if (DefFormat[I] in FmtChars) then
                        Counter := succ(counter);
                 Max_string_length := Counter;
             end;  {sub func Max_String_Length}

             Function  Pos_of_First_Input_Char: byte;
             var Counter : byte;
             begin
                 Counter := 0;
                 Repeat
                      Counter := succ(Counter);
                 Until DefFormat[Counter] in FmtChars;
                 Pos_of_First_Input_Char := FieldDefn[DefID]^.X + counter - 1;
             end;
begin
    If not IO_Settings.IO_FieldsSet then IOError(3,0);
    If (DefID < 1) or (DefID>IO_Settings.TotalFields) then IOError(4,Defid);
    If  (DefU < 0)  or (DefU > IO_Settings.TotalFields)
    or (DefD < 0)  or (DefD > IO_Settings.TotalFields)
    or (DefL < 0)  or (DefL > IO_Settings.TotalFields)
    or (DefR < 0)  or (DefR > IO_Settings.TotalFields)
                       then             IOError(5,Defid);
    If  (DefX < 1) or (DefX > 80)
    or (DefY < 1) or (DefY > 25)
                       then             IOError(6,Defid);
    With FieldDefn[DefID]^ do
    begin
        Upfield    := DefU;
        Downfield  := DefD;
        Leftfield  := DefL;
        Rightfield := DefR;
        X          := DefX;
        Y          := DefY;
        InString   := ptr(seg(defstring),ofs(defstring));
        StrLength  := Max_String_length;
        Format     := DefFormat;
        CursorX    := Pos_of_First_Input_Char;
        CursorInit := Pos_of_First_Input_Char;
    end;
end; {proc IO_DefineStr}

Function IO_FmtStr(Str,Fmt:string):string;
var
TempStr : string;
I,J : byte;
begin
    J := 0;
    For I := 1 to length(Fmt) do
    begin
        If not (Fmt[I] in FmtChars) then
        begin
            TempStr[I] := Fmt[I] ;  {force any none format charcters into string}
             J := succ(J);
        end
        else    {format character}
        begin
            If I - J <= length(Str) then
               TempStr[I] := Str[I - J]
            else
               TempStr[I] := '_';    {pad with underlines}
        end;
    end;
    TempStr[0] := char(length(Fmt));  {set initial byte to string length}
    IO_FmtStr := Tempstr;
end;  {Func FmtStr}

Procedure Hilight(ID:byte);      {display cell in bright colors}
begin
    with FieldDefn[ID]^ do
         WriteAT(X,Y,IO_Settings.HiF,IO_Settings.HiB,
                 IO_FmtStr(InString^,Format));
end;

Procedure LoLight(ID:byte);      {display cell in dim colors}
begin
    with FieldDefn[ID]^ do
         WriteAT(X,Y,IO_Settings.LoF,IO_Settings.LoB,
                 IO_FmtStr(InString^,Format));
end;

Procedure IO_DisplayFields;
var I : integer;
begin
    For I :=  1 to IO_Settings.TotalFields do
        LoLight(I);
    IO_Settings.Displayed  := true;
end;

Procedure IO_AllowEsc(OK:boolean);
begin
    IO_Settings.IOEsc := OK;
end;    {proc IO_AllowEsc}

Procedure IO_SoundBeeper(OK:boolean);
begin
    IO_Settings.IO_BeepOn := OK;
end;    {proc IO_SoundBeeper}

Procedure IO_ResetFields;
var I : integer;
begin
    If not IO_Settings.IO_FieldsSet then IOError(10,0);
    IO_UserHook := nil;
    For I := 0 to IO_Settings.TotalFields do
        FreeMem(FieldDefn[I],sizeof(FieldDefn[I]^));
    With IO_Settings do
    begin
        IO_FieldsSet := false;
        TotalFields := 0;
        IOEsc := false;
        Displayed := false;
        IO_Beepon := true;
        IO_PutUnderline := true;
        IO_Insert := false;
        CurrentField := 1;
    end; {with}
    IO_UserHook  := nil;
end; { proc IO_ResetFields }

{
****************************
*      Main Procedure      *
****************************
}

Procedure IO_Edit(var Return_code : integer);
const
    finished : boolean = false;
var
    OldLine : array[1..160] of byte;

    Procedure DisplayMessage(ID:byte);
    begin
        With FieldDefn[ID]^ do
        begin
            If MsgX = 0 then   {Center the message}
               MsgX := (80 - length(Message)) div 2;
            PartSave(MsgX,MsgY,MsgX+length(Message),MsgY,OldLine);
            WriteAT(MsgX,MsgY,IO_Settings.MsgF,IO_Settings.MsgB,Message);
        end; {sub sub proc DisplayMessage}
    end;

    Procedure RemoveMessage(ID:byte);
    var I,LocC : integer;
    begin
        With FieldDefn[ID]^ do
             PartRestore(MsgX,MsgY,MsgX+length(Message),MsgY,OldLine);
    end; {sub sub proc RemoveMessage}

  Procedure Change_Fields(ID:byte);
  begin
      LoLight(IO_Settings.CurrentField);
      If FieldDefn[IO_Settings.CurrentField]^.MsgX <= 80 then
         RemoveMessage(IO_Settings.CurrentField);
      If ID = 0 then
      begin
          Finished := true;
          Return_Code := 0;
      end
      else
      begin
          IO_Settings.CurrentField := ID;
          If IO_Settings.IO_Insert = true then      {switch insert off}
             InsertMode;
          HiLight(IO_Settings.CurrentField);
         If FieldDefn[IO_Settings.CurrentField]^.MsgX <= 80 then
            DisplayMessage(IO_Settings.CurrentField);
         With FieldDefn[IO_Settings.CurrentField]^ do
              GotoXY(CursorX,Y);
         Ding;
     end;  {If ID = 0};
  end;  {proc change fields}

  Procedure Erase_Field(ID:byte);
  begin
      with FieldDefn[ID]^ do
      begin
          Instring^ := '';
          CursorX   := CursorInit;
          StrLocX := 1;
      end;
  end;

  Procedure Global_Erase;
  var I : integer;
  begin
  {MayBe paint an are you sure window}
      For I :=  1 to IO_Settings.TotalFields do
          Erase_Field(I);
      IO_DisplayFields;
      IO_Settings.CurrentField := 1;
  end;

  Procedure Cursor_Right;
  begin
      With FieldDefn[IO_Settings.CurrentField]^ do
      begin
          If (StrLocX <= length(InString^)) and (StrLocX < StrLength) then
          begin
              StrLocX := succ(StrLocX);
              Repeat
                   CursorX := succ(CursorX);
              Until Format[CursorX + 1 - X] in FmtChars;
          end;
          GotoXY(CursorX,Y);
      end; {with}
  end; {Proc Cursor_Right}


  Procedure Cursor_Left;
  begin
      With FieldDefn[IO_Settings.CurrentField]^ do
      begin
          If StrLocX > 1 then
          begin
              StrLocX := pred(StrLocX);
              Repeat
                   CursorX := CursorX - 1;
              Until Format[CursorX + 1 - X] in FmtChars;
          end;
      end;  {with}
  end;  {Proc Cursor_left}

  Procedure Delete_Char;
  var
    Temp : boolean;
    I : integer;
  begin
      Temp := false;                                 {insert a space if there are}
      with FieldDefn[IO_Settings.CurrentField]^ do   {non format characters}
      begin
          For I := 1 to length(Format) do
              If not (Format[I] in FmtChars) then
                 Temp := true;
          Delete(InString^,StrLocX,1);
          If Temp = true then
             Insert(' ',Instring^,StrlocX);
      end;  {with}
  end;  {Delete_Chars}

  Procedure Backspaced;
  begin
      with FieldDefn[IO_Settings.CurrentField]^ do
      begin
          If StrLocX > 1 then
          begin
              Cursor_Left;
              Delete(InString^,StrLocX,1);
          end;
      end;  {with}
  end;  { Proc Backspaced }

  Procedure Activity;
  var
    K : char;
    ReturnStr: string;
    Prior_CursorX : byte;
  begin
      K := Getkey;

      If IO_UserHook <> nil then
      begin
         ReturnStr := '';
         CallFromIO(K,IO_Settings.CurrentField,ReturnStr);
         If ReturnStr <> '' then
            with FieldDefn[IO_Settings.CurrentField]^ do
            begin
                InString^ := copy(ReturnStr,1,StrLength);
                CursorX := X;
                StrLocX := 1;
                Repeat
                     Prior_CursorX := CursorX;
                     Cursor_Right;
                Until CursorX = Prior_CursorX;
           end;
      end;
      Case K of
      #132,   {mouse right but}
      IOEsc : If IO_Settings.IOEsc then
              begin
                  Finished := true;
                  Return_Code := 1;
              end
              else Ding;
      IOFinish : begin
                     Finished := true;
                     Return_code := 0;
                 end;
      #32..#126 :  with FieldDefn[IO_settings.CurrentField]^ do
                   begin
                       If Format[CursorX - X + 1] = '!' then K := upcase(K);
                       If ((K in ['0'..'9','.','-','e','E']) and (Format[CursorX - X + 1] = '#'))
                       or ((K in ['a'..'z','A'..'Z',' ',',','.',';',':']) and
                                                 (Format[CursorX - X + 1] = '@'))
                       or (Format[CursorX - X + 1] = '*')
                       or (Format[CursorX - X + 1] = '!') then
                       begin
                           If IO_Settings.IO_Insert then          {in insert mode}
                           begin
                               If length(Instring^) < StrLength then
                               begin
                                   Insert(K,Instring^,StrLocX);
                                   Cursor_Right;
                               end
                               else Ding;
                           end
                           else                        {in overlay mode}
                           begin
                               Delete(Instring^,StrLocX,1);
                               Insert(K,Instring^,StrLocX);
                               Cursor_Right;
                           end; {If insert}
                       end
                       else Ding; {end if K in statement}
                   end;  {with}
      #133,    {mouse left but}
      #131,      {mouse right}
      IORightFld,
      IOTab,
      IOEnter : Change_Fields(FieldDefn[IO_Settings.CurrentField]^.RightField);

      #130,      {mouse left}
      IOLeftFld,
      IOShiftTab :Change_Fields(FieldDefn[IO_Settings.CurrentField]^.LeftField);

      IOBackSp : Backspaced;

      IODel    : Delete_Char;

      IOLeft   : Cursor_Left;

      IORight  : Cursor_Right;

      #128,    {mouse up}
      IOUp     : Change_Fields(FieldDefn[IO_Settings.CurrentField]^.UpField);

      #129,    {mouse down}
      IODown   : Change_Fields(FieldDefn[IO_Settings.CurrentField]^.DownField);

      IOErase    : Erase_Field(IO_Settings.CurrentField);

      IOTotErase : Global_Erase;

      IOIns      : InsertMode;


      else Ding;
      end; {case}
      HiLight(IO_Settings.CurrentField);
      With FieldDefn[IO_Settings.CurrentField]^ do
      GotoXY(CursorX,Y);
  end;    {Proc Activity}


begin   {IO_Edit}
    If IO_Settings.Displayed = false then IO_DisplayFields;
    Hilight(IO_Settings.CurrentField);
    If FieldDefn[IO_Settings.CurrentField]^.MsgX <= 80 then
       DisplayMessage(IO_Settings.CurrentField);
    GotoXY(FieldDefn[IO_Settings.CurrentField]^.CursorX,
           FieldDefn[IO_Settings.CurrentField]^.Y);
    Finished := false;
    repeat
         Activity
    until Finished;
end;   {IO_Edit}

begin  {Initial Auto proc}
    IO_UserHook := nil;
    If BaseOfScreen = $B000 then
       IO_SetColors(black,lightgray,lightgray,black,white,black);
end.