{$S-,R-,I-,V-,B-}

  {*********************************************************}
  {*                   TPEDIT.PAS 4.03                     *}
  {*        Copyright (c) TurboPower Software 1987.        *}
  {* Portions copyright (c) Sunny Hill Software 1985, 1986 *}
  {*     and used under license to TurboPower Software     *}
  {*                 All rights reserved.                  *}
  {*********************************************************}

unit TpEdit;
  {-Line editor and keyboard input routines}

interface

uses
  TpCrt,
  TpString;

type
  CharSet = set of Char;
  RStype =
  (RSnone,                 {Not a command}
    RSchar,                {A character to enter the string}
    RSctrlChar,            {Accept control character}
    RSenter,               {Accept current string and quit}
    RSquit,                {Restore default string and quit}
    RSrestore,             {Restore default and continue}
    RShome,                {Cursor to begin of line}
    RSend,
    RSF10,
    RSUp,
    RSDown,                 {Cursor to end of line}
    RSleft,                {Cursor left by one character}
    RSright,               {Cursor right by one character}
    RSwordLeft,            {Cursor left one word}
    RSwordRight,           {Cursor right one word}
    RSback,                {Backspace one character}
    RSdel,                 {Delete current character}
    RSdelEol,              {Delete from cursor to end of line}
    RSdelBol,              {Delete from beginning of line to cursor}
    RSdelLine,             {Delete entire line}
    RSdelWord,             {Delete word to right of cursor}
    RSins                  {Toggle insert mode}
    );
const
  {the following govern the behavior of ReadString and the numeric reads}
  ForceUpper : Boolean = False; {force chars to uppercase?}
  CursorToEnd : Boolean = True; {start cursor at end of string? else at start}
  TrimBlanks : Boolean = True; {trim leading/trailing blanks? -- forced on
                                temporarily for the numeric reads}
  InsertByDefault : Boolean = True; {default to insert mode?}

  {the following govern the behavior of ReadCharacter and YesOrNo}
  ShowReadChar : Boolean = False; {display the character pressed?}
  HideCursorInReadChar : Boolean = False; {cursor hidden?}
  EditSize : Byte = 0; {if NOT zero, this overrides MaxLen as edit field width}
  ClearFirstChar : Boolean = True; {clear string if first char entered is ASCII}
var
  RScommandPtr : Pointer; {pointer to routine to translate keystrokes into a
                           ReadString command}
  RSChWord : Word;        {char/scan code for last keyboard entry}

procedure ReadString(Prompt : string;
                     Row, Col, MaxLen : Byte;
                     PromptAttr, StringAttr, CtrlAttr : Byte;
                     var Escaped ,UpArr,DownArr,F10: Boolean;
                     var S : string);
  {-Prompt for and receive a string}

procedure ReadLongInt(Prompt : string;
                      Row, Col, MaxLen : Byte;
                      PromptAttr, StringAttr : Byte;
                      LLo, LHi : LongInt;
                      var Escaped ,UpArr,DownArr,F10: Boolean;
                      var L : LongInt);
  {-Prompt for and receive a long integer argument in the range LLo to LHi}

procedure ReadInteger(Prompt : string;
                      Row, Col, MaxLen : Byte;
                      PromptAttr, StringAttr : Byte;
                      NLo, NHi : Integer;
                      var Escaped,UpArr,DownArr,F10 : Boolean;
                      var N : Integer);
  {-Prompt for and receive an integer argument in the range NLo to NHi}

procedure ReadWord(Prompt : string;
                   Row, Col, MaxLen : Byte;
                   PromptAttr, StringAttr : Byte;
                   WLo, WHi : Word;
                   var Escaped,UpArr,DownArr,F10 : Boolean;
                   var W : Word);
  {-Prompt for and receive a word argument in the range WLo to WHi}

procedure ReadReal(Prompt : string;
                   Row, Col, MaxLen : Byte;
                   PromptAttr, StringAttr : Byte;
                   DecimalPlaces : Byte;
                   RLo, RHi : Real;
                   var Escaped ,UpArr,DownArr,F10: Boolean;
                   var R : Real);
  {-Prompt for and receive a real argument in the range RLo to RHi}

procedure ReadCharacter(Prompt : string;
                        Row, Col : Byte;
                        PromptAttr : Byte;
                        Accept : CharSet;
                        var Ch : Char);
  {-Display a prompt and wait for a key in Accept}

function YesOrNo(Prompt : string;
                 Row, Col : Byte;
                 PromptAttr : Byte;
                 Default : Char) : Boolean;
  {-Return true for yes, false for no}

  {==========================================================================}

implementation

type
  String80 = string[80];
const
  NumError : string[32] = 'Invalid number. Press any key...';

  {$F+}
  function RScommand(ChWord : Word) : RStype;
    {-Translate keystrokes into a ReadString command}
  var
    RSC : RStype;
  begin
    case Char(Lo(ChWord)) of
      #0 : case Hi(ChWord) of
             0 : RSC := RSquit; {^Break}
             68 : RSC:=RSF10;
             71 : RSC := RShome; {Home}
             79 : RSC := RSend; {End}
             72 : RSC := RSUp;
             80 : RSC := RSDown;
             75 : RSC := RSleft; {Left}
             77 : RSC := RSright; {Right}
             82 : RSC := RSins; {Ins}
             83 : RSC := RSdel; {Del}
             115 : RSC := RSwordLeft; {^Left}
             116 : RSC := RSwordRight; {^Right}
             117 : RSC := RSdelEol; {^End}
             119 : RSC := RSdelBol; {^Home}
           else
             RSC := RSnone;
           end;
      ^M : RSC := RSenter;
      #27 : RSC := RSquit;
      #127,
      ^H : RSC := RSback;
      ^R : RSC := RSrestore;
      ^S : RSC := RSleft;
      ^D : RSC := RSright;
      ^A : RSC := RSwordLeft;
      ^F : RSC := RSwordRight;
      ^G : RSC := RSdel;
      ^T : RSC := RSdelWord;
      ^Y : RSC := RSdelLine;
      ^X : RSC := RSdelLine;
      ^P : RSC := RSctrlChar;
      ^Q :
        {WordStar ^Q, get second char}
        case Upcase(Char(Lo(ReadKeyWord))) of
          ^S, 'S' : RSC := RShome;
          ^D, 'D' : RSC := RSend;
          ^Y, 'Y' : RSC := RSdelEol;
          ^L, 'L' : RSC := RSrestore;
        else RSC := RSnone;
        end;
      #32..#255 : RSC := RSchar; {#127 already handled}
    else
      RSC := RSnone;
    end;
    RScommand := RSC;
  end;
  {$F-}

  function CallRScommand(ChWord : Word) : RStype;
    {-Call routine pointed to by RScommandPtr}
    inline(
      $FF/$1E/>RScommandPtr); {call dword ptr [>RScommandPtr]}

  procedure ReadString(Prompt : string;
                       Row, Col, MaxLen : Byte;
                       PromptAttr, StringAttr, CtrlAttr : Byte;
                       var Escaped ,UpArr,DownArr,F10 : Boolean;
                       var S : string);
    {-Prompt for and receive a string}
  var
    Ch : Char absolute RSChWord;
    St : string;
    StLen : Byte absolute St;
    CursorSL : Word;
    CursorXY : Word;
    StCol : Byte;
    Sp : Byte;
    DelEnd : Byte;
    Inserting : Boolean;
    FirstChar : Boolean;
    SaveBreak : Boolean;
    Done : Boolean;
    RSC : RStype;
    StOffset : Byte;
    EditLen : Byte;

    function TrimSpaces(S : string) : string;
      {-Return a string with leading and trailing blanks removed}
    begin
      while (Length(S) > 0) and (S[1] = ' ') do
        Delete(S, 1, 1);
      while (Length(S) > 0) and (S[Length(S)] = ' ') do
        Dec(S[0]);
      TrimSpaces := S;
    end;

    procedure ToggleInsertMode;
      {-Toggle between insert and overtype mode}
    begin
      {toggle insert flag}
      Inserting := not Inserting;

      {use fat cursor if inserting}
      if Inserting then
        FatCursor
      else
        NormalCursor;
    end;

    procedure DrawString;
      {-Draw the string}
    var
      A, I, SaveStLen : Byte;
      C : Char;
    begin
      {pad the end of the string with blanks}
      FillChar(St[Succ(StLen)], MaxLen-StLen, ' ');

      {make sure padding is drawn}
      SaveStLen := StLen;
      StLen := EditLen;

      {draw the string and restore the length byte}
      for I := 1 to StLen do begin
        C := St[StOffset+I];
        if C < ' ' then begin
          C := Chr(Ord(C) or $40);
          A := CtrlAttr;
        end
        else
          A := StringAttr;
        FastWrite(C, Row, StCol+Pred(I), A);
      end;
      StLen := SaveStLen;
    end;

  begin
    {Determine if EditSize is appropriate here}
    if (EditSize = 0) or (EditSize >= MaxLen) then
      EditLen := MaxLen
    else
      EditLen := EditSize;

    {Store cursor position and shape}
    GetCursorState(CursorXY, CursorSL);

    {Save break checking state}
    SaveBreak := CheckBreak;
    CheckBreak := False;
    UpArr:=False;
    DownArr:=false;
    Escaped := False;
    StOffset := 0;

    {Write prompt}
    FastWrite(Prompt, Row, Col, PromptAttr);
    StCol := Col+Length(Prompt);

    {Get the default string}
    St := S;
    if StLen > MaxLen then
      StLen := MaxLen;
    if CursorToEnd then
      Sp := Succ(StLen)
    else
      Sp := 1;
    FirstChar := True;

    {default to insert mode on if InsertByDefault is true}
    Inserting := not InsertByDefault;
    ToggleInsertMode;

    {Loop reading keys}
    Done := False;
    repeat

      {Position cursor and redraw string}
      if Sp > MaxLen then
        Sp := Succ(MaxLen);
      if Sp > Succ(EditLen)+StOffset then
        StOffset := Sp-Succ(EditLen)
      else if Sp < Succ(StOffset) then
        StOffset := pred(Sp);
      DrawString;
      GoToXYAbs(StCol+Pred(Sp)-StOffset, Row);

      RSChWord := ReadKeyWord;
      if ForceUpper then
        Ch := Upcase(Ch);
      RSC := CallRScommand(RSChWord);

      {deal with control characters if desired}
      if RSC = RSctrlChar then
        {don't allow control characters if attributes are the same}
        if (CtrlAttr = StringAttr) then
          RSC := RSnone
        else begin
          BlockCursor;
          RSChWord := ReadKeyWord;
          if ForceUpper then
            Ch := Upcase(Ch);
          RSC := RSchar;
          if Inserting then
            FatCursor
          else
            NormalCursor;
        end;

      {allow editing of the existing string}
      if FirstChar then begin
        FirstChar := False;

        if ClearFirstChar then
          {if first key is a character, clear the input string}
          if (RSC = RSchar) then begin
            StLen := 0;
            Sp := 1;
          end;
      end;

      case RSC of
        RSchar :             {A character to enter the string}
          if not Inserting then begin
            {overtype mode}
            if Sp <= MaxLen then begin
              St[Sp] := Ch;
              if Sp > StLen then
                StLen := Sp;
              Inc(Sp);
            end;
          end
          else
            {insert mode}
            if StLen < MaxLen then begin
              Insert(Ch, St, Sp);
              Inc(Sp);
            end;

        RSenter :            {Accept current string and quit}
          Done := True;

        RSquit :             {Restore default string and quit}
               begin
            St := S;
            if CursorToEnd then
              Sp := Succ(StLen)
            else
              Sp := 1;
            if StLen > MaxLen then
              StLen := MaxLen;
            Done := True;
            Escaped := True;
          end;

        RSF10:            {Accept current string and quit}
         begin
          Done := True;
          F10:=true;
          end;

        RShome :             {Cursor to begin of line}
          Sp := 1;

        RSend :              {Cursor to end of line}
          Sp := Succ(StLen);

        RSdelEol :           {Delete from cursor to end of line}
          St := Copy(St, 1, Pred(Sp));

        RSdelBol :           {Delete from beginning of line to the cursor}
          begin
            Delete(St, 1, Pred(Sp));
            Sp := 1;
          end;

        RSdelLine :          {Delete entire line}
          begin
            StLen := 0;
            Sp := 1;
          end;

        RSrestore :          {Restore default and continue}
          begin
            St := S;
            if StLen > MaxLen then
              StLen := MaxLen;
            if CursorToEnd then
              Sp := Succ(StLen)
            else
              Sp := 1;
          end;

        RSleft :             {Cursor left by one character}
          if Sp > 1 then
            Dec(Sp);

        RSright :            {Cursor right by one character}
          if Sp <= StLen then
            Inc(Sp);

        RSUp :
               begin
            St := S;
            if CursorToEnd then
              Sp := Succ(StLen)
            else
              Sp := 1;
            if StLen > MaxLen then
              StLen := MaxLen;
            Done := True;
            UpArr:= True;
          end;

        RSDown :
              begin
            St := S;
            if CursorToEnd then
              Sp := Succ(StLen)
            else
              Sp := 1;
            if StLen > MaxLen then
              StLen := MaxLen;
            Done := True;
            DownArr := True;
          end;



        RSwordLeft :         {Cursor left one word}
          if Sp > 1 then begin
            Dec(Sp);
            while (Sp >= 1) and ((Sp > StLen) or (St[Sp] = ' ')) do
              Dec(Sp);
            while (Sp >= 1) and (St[Sp] <> ' ') do
              Dec(Sp);
            Inc(Sp);
          end;

        RSwordRight :        {Cursor right one word}
          if Sp <= StLen then begin
            Inc(Sp);
            while (Sp <= StLen) and (St[Sp] <> ' ') do
              Inc(Sp);
            while (Sp <= StLen) and (St[Sp] = ' ') do
              Inc(Sp);
          end;

        RSdel :              {Delete current character}
          if Sp <= StLen then
            Delete(St, Sp, 1);

        RSback :             {Backspace one character}
          if Sp > 1 then begin
            Dec(Sp);
            Delete(St, Sp, 1);
            if StOffset > 0 then
              {String horizontally scrolled}
              if StOffset+EditLen >= StLen then
                {The rightmost portion of the string is displayed, so scroll}
                dec(StOffset);
          end;

        RSdelWord :          {Delete word to right of cursor}
          if Sp <= StLen then begin
            {start deleting at the cursor}
            DelEnd := Sp;

            {delete all of the current word, if any}
            if St[Sp] <> ' ' then
              while (St[DelEnd] <> ' ') and (DelEnd <= StLen) do
                Inc(DelEnd);

            {delete any spaces prior to the next word, if any}
            while (St[DelEnd] = ' ') and (DelEnd <= StLen) do
              Inc(DelEnd);

            Delete(St, Sp, DelEnd-Sp);
          end;

        RSins :              {Toggle insert mode}
          ToggleInsertMode;
      end;
    until Done;

    {draw the string one last time}
    if Sp > Succ(EditLen)+StOffset then
      StOffset := Sp-Succ(EditLen)
    else if Sp < Succ(StOffset) then
      StOffset := pred(Sp);
    DrawString;

    {trim leading and trailing blanks if desired}
    if TrimBlanks then
      S := TrimSpaces(St)
    else
      S := St;

    {restore break checking status}
    CheckBreak := SaveBreak;

    {Restore cursor position and shape}
    RestoreCursorState(CursorXY, CursorSL);
  end;

  procedure ReadLongInt(Prompt : string;
                        Row, Col, MaxLen : Byte;
                        PromptAttr, StringAttr : Byte;
                        LLo, LHi : LongInt;
                        var Escaped,UpArr,DownArr,F10 : Boolean;
                        var L : LongInt);
    {-Prompt for and receive a long integer argument in the range LLo to LHi}
  var
    S : String80;
    Code, MaxWidth : Word;
    SaveTrimBlanks : Boolean;
    LTemp : LongInt;
  label
    ExitPoint;
  begin
    {Set default value}
    Str(L, S);

    {force blank trimming}
    SaveTrimBlanks := TrimBlanks;
    TrimBlanks := True;

    repeat
      {read the string and convert back to longint}
      ReadString(Prompt, Row, Col, MaxLen, PromptAttr, StringAttr, StringAttr,
        Escaped,UpArr,DownArr,F10,S);

      {if ESCaping, redisplay the number}
      if Escaped then begin
        Str(L, S);
        FastWrite(Pad(S, MaxLen), Row, Col+Length(Prompt), StringAttr);
        goto ExitPoint;
      end;

      {don't range check if both bounds are 0}
      Val(S, LTemp, Code);
      if not((LLo = 0) and (LHi = 0)) then
        {set error condition if answer not in valid range}
        if (LTemp < LLo) or (LTemp > LHi) then
          Code := 1;

      {validate entry}
      MaxWidth := Succ(Length(Prompt)+MaxLen);
      if Code <> 0 then
        {display an error message if possible}
        if MaxWidth >= SizeOf(NumError) then begin
          FastWrite(Pad(NumError, MaxWidth), Row, Col, StringAttr);
          RSChWord := ReadKeyWord;
        end
        else
          {if not, beep}
          Write(^G);
    until (Code = 0);
    L := LTemp;

ExitPoint:
    {restore blank trimming state}
    TrimBlanks := SaveTrimBlanks;
  end;

  procedure ReadInteger(Prompt : string;
                        Row, Col, MaxLen : Byte;
                        PromptAttr, StringAttr : Byte;
                        NLo, NHi : Integer;
                        var Escaped,UpArr,DownArr,F10 : Boolean;
                        var N : Integer);
    {-Prompt for and receive an integer argument in the range NLo to NHi}
  var
    L : LongInt;
  begin
    L := LongInt(N);
    if (NLo = 0) and (NHi = 0) then begin
      NLo := -32768;
      NHi := MaxInt;
    end;
    ReadLongInt(Prompt, Row, Col, MaxLen, PromptAttr, StringAttr,
      LongInt(NLo), LongInt(NHi), Escaped,UpArr,DownArr,F10,L);
    N := Integer(L);
  end;

  procedure ReadWord(Prompt : string;
                     Row, Col, MaxLen : Byte;
                     PromptAttr, StringAttr : Byte;
                     WLo, WHi : Word;
                     var Escaped,UpArr,DownArr,F10 : Boolean;
                     var W : Word);
    {-Prompt for and receive a word argument in the range WLo to WHi}
  var
    L : LongInt;
  begin
    L := LongInt(W);
    if (WLo = 0) and (WHi = 0) then begin
      WLo := 0;
      WHi := 65535;
    end;
    ReadLongInt(Prompt, Row, Col, MaxLen, PromptAttr, StringAttr,
      LongInt(WLo), LongInt(WHi), Escaped,UpArr,DownArr,F10,L);
    W := Word(L);
  end;

  procedure ReadReal(Prompt : string;
                     Row, Col, MaxLen : Byte;
                     PromptAttr, StringAttr : Byte;
                     DecimalPlaces : Byte;
                     RLo, RHi : Real;
                     var Escaped,UpArr,DownArr,F10 : Boolean;
                     var R : Real);
    {-Prompt for and receive a real argument in the range RLo to RHi}
  var
    S : String80;
    Code, MaxWidth : Word;
    SaveTrimBlanks : Boolean;
    RTemp : Real;
  label
    ExitPoint;
  begin
    {Save original value}
    RTemp := R;

    {Set default value}
    Str(R:0:DecimalPlaces, S);

    {force blank trimming}
    SaveTrimBlanks := TrimBlanks;
    TrimBlanks := True;

    repeat
      {read the string and convert back to real}
      ReadString(Prompt, Row, Col, MaxLen, PromptAttr, StringAttr, StringAttr,
        Escaped,UpArr,DownArr,F10,S);

      {if ESCaping, redisplay the number}
      if Escaped then begin
        Str(R:0:DecimalPlaces, S);
        FastWrite(Pad(S, MaxLen), Row, Col+Length(Prompt), StringAttr);
        goto ExitPoint;
      end;

      {don't range check if both bounds are 0}
      Val(S, RTemp, Code);
      if not((RLo = 0) and (RHi = 0)) then
        {set error condition if answer not in valid range}
        if (RTemp < RLo) or (RTemp > RHi) then
          Code := 1;

      {validate entry}
      MaxWidth := Succ(Length(Prompt)+MaxLen);
      if Code <> 0 then
        {display an error message if possible}
        if MaxWidth >= SizeOf(NumError) then begin
          FastWrite(Pad(NumError, MaxWidth), Row, Col, StringAttr);
          RSChWord := ReadKeyWord;
        end
        else
          {if not, beep}
          Write(^G);
    until (Code = 0);
    R := RTemp;

ExitPoint:
    {restore blank trimming state}
    TrimBlanks := SaveTrimBlanks;
  end;

  procedure ReadCharacter(Prompt : string;
                          Row, Col : Byte;
                          PromptAttr : Byte;
                          Accept : CharSet;
                          var Ch : Char);
    {-Display a prompt and wait for a key in Accept}
  var
    CursorSL : Word;
    CursorXY : Word;
    C : Char absolute RSChWord;
    SaveBreak : Boolean;
  begin
    {Store cursor position and shape}
    GetCursorState(CursorXY, CursorSL);

    {save break checking state}
    SaveBreak := CheckBreak;
    CheckBreak := False;

    {Write prompt - extra blank is a spot for the character to be read}
    FastWrite(Prompt+' ', Row, Col, PromptAttr);

    {Display and position cursor}
    Inc(Col, Length(Prompt));
    if HideCursorInReadChar then
      HiddenCursor
    else begin
      NormalCursor;
      GoToXYAbs(Col, Row);
    end;

    {read keys until valid response is given}
    repeat
      RSChWord := ReadKeyWord;
      if C = #0 then
        {extended scan code--return high byte and set high bit}
        Ch := Char(Hi(RSChWord) and $80)
      else begin
        Ch := Upcase(C);
        if ShowReadChar and (Ch in Accept) then
          FastWrite(Ch, Row, Col, PromptAttr);
      end;
    until (Ch in Accept);

    {restore break checking status}
    CheckBreak := SaveBreak;

    {Restore cursor position and shape}
    RestoreCursorState(CursorXY, CursorSL);
  end;

  function YesOrNo(Prompt : string;
                   Row, Col : Byte;
                   PromptAttr : Byte;
                   Default : Char) : Boolean;
    {-Return true for yes, false for no}
  var
    Ch : Char;
    SaveShow : Boolean;
  begin
    SaveShow := ShowReadChar;
    ShowReadChar := False;
    case Upcase(Default) of
     'N', 'O' :
        begin
          {a default answer was specified, <Enter> accepts it}
          Prompt := Prompt+' ['+Upcase(Default)+'] ';
          ReadCharacter(Prompt, Row, Col, PromptAttr, ['N', 'O',^M], Ch);
          if Ch = ^M then
            Ch := Upcase(Default);
        end;
    else
      {no default answer, just prompt and wait for valid key}
      ReadCharacter(Prompt, Row, Col, PromptAttr, ['N','O'], Ch)
    end;
    ShowReadChar := SaveShow;
    if ShowReadChar then
      FastWrite(Ch, Row, Col+Length(Prompt), PromptAttr);
    YesOrNo := (Ch = 'N');
  end;

begin
  {initialize procedure pointer}
  RScommandPtr := @RScommand;
end.
