{start of file PROM200.INC ***************************************************}

{PROM.INC - IN TURBO PASCAL}
{Last revised: 05/16/86, 1600 hours, By Harry J Smith, Saratoga, CA}
{Utilities to PROMpt and get input from the operator}

{*****************************************************************************}
{
The following PROCEDUREs can be called externally:

PROCEDURE CHGLEN(VAR STRG: STRINGP; NEWLEN: INTEGER);
  Change the length of STRG to NEWLEN.

PROCEDURE GETCHR(NUMDELAYS: INTEGER; WITHBELLS: BOOLEAN; VALIDCHR: CHARSET);
  Detect or await typing of a key.

PROCEDURE GETYESNO(VAR VALUE : BOOLEAN);
  Get yes/no answer from operator.

PROCEDURE HELPPROM;
  Give operator a help message for using PROM.

PROCEDURE INITPROM;
  Initialize the PROM utility.

PROCEDURE JUSTIFY(SRCSTRG: STRINGP; VAR DSTSTRG: STRINGP;
          HOWJUST: DIRECTION; PADCHR: CHAR; NEWLEN: INTEGER);
  Left/right/center justify a string for the specified length using PADCHR.

PROCEDURE MAKESTRG(CH: CHAR; VAR STRG: STRINGP);
  Make a character into a string.

PROCEDURE PROM(RSPX, RSPY, RSPLEN: INTEGER; DEFAULT: STRINGP;
  Prompt the operator for an input.

PROCEDURE SCREENMSG(XPOS, YPOS: INTEGER; COMMAND: SCRCOMMAND;
          MESSAGE: STRINGP);
  Display a message at a specified cursor position.

Some of the utilities in this package are imitations of utilities in the
APPLE /// Pascal General Utilities, which are a modification of a collection 
of procedures and functions that were put into public domaine by the UCSD 
Pascal users group in 1980.
}
{*****************************************************************************}

{$R+ Range check Array Indexes}
{$U- Do NOT Allow User Interrupts, nomonal}
{$V- Allow any length SRTINGs passed to PROCEDURES}

CONST
  NULLSTRG = '';
  SPACE    = ' ';

TYPE
  DIRECTION  = (CENTER, LEFT, DOWN, RIGHT, UP);
  CHARSET    = SET OF CHAR;

  SCRCOMMAND = (NULLCMD, CLRLINE, CLRSCREEN);

  CTRLTYPE   = (NOTCTRL, DUPCHR, BACKSPACE, INSCHR,  BEGFLD, ENDFLD, DELCHR,
               CLRTOEND, ACCEPT, TRUNCATE,  RESTORE, ESCAPE, HELPER, STOPER);

  STRINGP   = STRING[255]; {DUMMY STRING USED FOR PASSING TO PROCEDURES}

VAR
  NULL, BELL, BS, LF, CR, HELPC, STOPC, ESC, FILLC : CHAR; {CONSTANTS}
  BACKGROUND, RSPCHR              : CHAR;
  CTRLCHR, NORMALCHR, NULLSET     : CHARSET;
  ESCTYPED, HELPTYPED, STOPTYPED  : BOOLEAN;
  CTRL : PACKED ARRAY[0..31] OF CTRLTYPE;

PROCEDURE HELPPROM; {HELP PROM}
BEGIN
  WRITELN(CHR(10)); {LINE FEED}
  WRITELN('^A  =>  Jump to beginning of field');
  WRITELN('^S  =>  Backspace, (and delete if inserting)');
  WRITELN('^D  =>  Retype the character at current position');
  WRITELN('^F  =>  Jump to end of field');
  WRITELN('^G  =>  Delete the character at current position');
  WRITELN('^K  =>  Accept the entire field as is');
  WRITELN('^Q  =>  Help with input key control, (changes default)');
  WRITELN('^R  =>  Restore field to default value');
  WRITELN('^T  =>  Clear field from current position to end');
  WRITELN(
    'CR  =>  <RETURN> Accept input, truncate if not at beginning or end');
  WRITELN('ESC =>  <ESCAPE> Clear and terminate input');
  WRITELN('^V  =>  Toggle insert mode');
  WRITELN('^X  =>  Exit to operating system');
  WRITELN;
END;

PROCEDURE GETYESNO(VAR VALUE : BOOLEAN); {Get yes/no answer from operator}
VAR CH : CHAR;  DONE : BOOLEAN;
BEGIN
  WRITE('Y', BS);
  REPEAT
    READ(KBD, CH);
    DONE:= CH IN ['Y', 'y', 'N', 'n', CR, STOPC, ESC];
    IF NOT DONE THEN WRITE(BELL);
  UNTIL DONE;
  STOPTYPED:= (CH = STOPC);
  ESCTYPED:=  (CH = ESC);
  VALUE:= CH IN ['Y', 'y', CR];
  IF VALUE THEN WRITELN('Yes')
  ELSE WRITELN('No');
END; {GETYESNO}

PROCEDURE GETCHR(NUMDELAYS: INTEGER; WITHBELLS: BOOLEAN; VALIDCHR: CHARSET);
{DETECTS OR AWAITS TYPING OF A KEY,
 OPTIONALLY ISSUING BELLS WHILE WAITING.
 RSPCHR IS NULL OR THE CHARACTER TYPED.
 IF NUMDELAYS < 0,
   GETCHR WILL WAIT UNTIL USER TYPES A VALID CHARACTER
   (ANY CHARACTER, IF VALIDCHR = NULLSET)
 IF NUMDELAYS = 0,
   KEYTPED WILL RETURN THE LAST CHARACTER TYPED
   PRIOR TO THE CALL
 IF NUMDELAYS > 0,
   GETCHR WILL WAIT THE SPECIFIED NUMBER OF DELAYS
   OR EXIT WHEN A KEY IS TYPED.
 }
VAR
  VALIDKEY : BOOLEAN;
BEGIN {GETCHR}
  VALIDKEY:= (VALIDCHR = NULLSET);
  {WRITE(CHR(5)); TURN ON CURSOR IF YOU CAN}
  REPEAT
    WHILE (NUMDELAYS <> 0) AND (NOT KEYPRESSED) DO BEGIN
      IF WITHBELLS THEN WRITE(BELL);
      DELAY(300); {WAIT A BIT}
      {DECREASE NUMDELAYS BY 1 IF POSITIVE}
      NUMDELAYS:= NUMDELAYS - ORD(NUMDELAYS > 0);
    END; {WHILE}
    IF  KEYPRESSED THEN
    {KEY WAS TYPED}
    BEGIN
      {GET THE CHARACTER WHICH WAS TYPED}
      READ(KBD, RSPCHR);
      {WRITE(CHR(5)); TURN ON CURSOR IF YOU CAN}
{     IF EOLN(KBD) THEN RSPCHR:= CR; This did not work with v 3.01a }
      IF NOT VALIDKEY THEN
        IF (RSPCHR IN VALIDCHR) THEN
          VALIDKEY:= TRUE
        ELSE
          WRITE(BELL);
    END ELSE
      RSPCHR:= NULL;
  UNTIL VALIDKEY;
  ESCTYPED:= (RSPCHR = ESC);
END; {GETCHR}

PROCEDURE CHGLEN(VAR STRG: STRINGP; NEWLEN: INTEGER);
{CHANGE THE LENGTH OF STRG TO NEWLEN.}
BEGIN {CHGLEN}
  {$R-}
  STRG[0]:= CHR(NEWLEN);
  {$R+}
END; {CHGLEN}

PROCEDURE MAKESTRG(CH: CHAR; VAR STRG: STRINGP);
{MAKE A CHARACTER INTO A STRING}
BEGIN {MAKESTRG}
  {MAKE THE LENGTH ONE CHARACTER}
  STRG:= ' ';
  STRG[1]:= CH;
END; {MAKESTRG}
         
PROCEDURE JUSTIFY(SRCSTRG: STRINGP; VAR DSTSTRG: STRINGP;
          HOWJUST: DIRECTION; PADCHR: CHAR; NEWLEN: INTEGER);
{LEFT/RIGHT/CENTER JUSTIFY A STRING FOR THE SPECIFIED LENGTH USING PADCHR}
VAR
  STPOS   : INTEGER;
  TMPSTRG : STRING[255];
BEGIN {JUSTIFY}
  TMPSTRG:= SRCSTRG;
  {IF SRCSTRG IS TOO LONG, SHORTEN IT}
  IF LENGTH(TMPSTRG) > NEWLEN THEN
    CHGLEN(TMPSTRG, NEWLEN);
  {MAKE THE DESTINATION STRING THE PROPER LENGTH}
  CHGLEN(DSTSTRG, NEWLEN);
  {FILL THE DESTINATION STRING WITH PADCHR}
  IF LENGTH(TMPSTRG) <> NEWLEN THEN
    FILLCHAR(DSTSTRG[1], NEWLEN, PADCHR);
  {DETERMINE WHERE IN THE DESTINATION STRING TO BEGIN
     MOVING THE SOURCE STRING}
  IF LENGTH(TMPSTRG) > 0 THEN
  BEGIN
    CASE HOWJUST OF
      LEFT:   STPOS:= 1;
      RIGHT:  STPOS:= NEWLEN - LENGTH(TMPSTRG) + 1;
      CENTER: STPOS:= (NEWLEN - LENGTH(TMPSTRG)) DIV 2 + 1;
    END; {CASE}
    {MOVE THE SOURCE STRING INTO THE DESTINATION STRING}
    MOVE{LEFT}(TMPSTRG[1], DSTSTRG[STPOS], LENGTH(TMPSTRG));
  END; {IF}
END; {JUSTIFY}

PROCEDURE INITCTRL;
{INITIALIZE THE PROMPT CONTROL CHARACTERS}
VAR
  TMPCHR : CHAR;

  PROCEDURE ADDTOCTRL(ASCIIVAL: INTEGER; CTRLKIND: CTRLTYPE);
  BEGIN {ADDTOCTRL}
    CTRL[ASCIIVAL]:= CTRLKIND;
    CTRLCHR:= CTRLCHR + [CHR(ASCIIVAL)];
  END; {ADDTOCTRL}

BEGIN {INITCTRL}
  CTRLCHR:= NULLSET;
  NORMALCHR:= NULLSET;
  FOR TMPCHR:= SPACE TO CHR(126) DO
    NORMALCHR:= NORMALCHR + [TMPCHR];
  ADDTOCTRL(21, DUPCHR);   {^U, RIGHT-ARROW}
  ADDTOCTRL(4,  DUPCHR);   {^D}
  ADDTOCTRL(8,  BACKSPACE);{^H, LEFT-ARROW}
  ADDTOCTRL(19, BACKSPACE);{^S}
  ADDTOCTRL(22, INSCHR);   {^V}
  ADDTOCTRL(1,  BEGFLD);   {^A}
  ADDTOCTRL(6,  ENDFLD);   {^F}
  ADDTOCTRL(7,  DELCHR);   {^G}
  ADDTOCTRL(20, CLRTOEND); {^T}
  ADDTOCTRL(11, ACCEPT);   {^K}
  ADDTOCTRL(18, RESTORE);  {^R}
  ADDTOCTRL(ORD(STOPC), STOPER);
  ADDTOCTRL(ORD(CR),  TRUNCATE);
  ADDTOCTRL(ORD(ESC), ESCAPE);
  ADDTOCTRL(ORD(HELPC), HELPER);
  CTRLCHR:= CTRLCHR + [CHR(127)];
END; {INITCTRL}

PROCEDURE SCREENMSG(XPOS, YPOS: INTEGER; COMMAND: SCRCOMMAND;
  MESSAGE: STRINGP);
BEGIN {SCREENMSG}
  GOTOXY(XPOS, YPOS);
  CASE COMMAND OF
    CLRLINE:   CLREOL;
    CLRSCREEN: WRITE(CHR(29)); {@ NEED TO FIX}
  END; {CASE}
  WRITE(MESSAGE);
END; {SCREENMSG}

PROCEDURE PROM(RSPX, RSPY, RSPLEN: INTEGER; DEFAULT: STRINGP;
VAR RESPONSE: STRINGP);
VAR
  INSERTING, TERMINATED, TMPBOOL : BOOLEAN;
  FMTLEN, INSPOS, RSPPOS : INTEGER;
  CTRLKIND : CTRLTYPE;
  VALIDCHR : CHARSET;
  TMPDEF   : STRING[255];

  PROCEDURE SHIFT(SHIFTDIR: DIRECTION);
  BEGIN {SHIFT}
    CASE SHIFTDIR OF
      LEFT: BEGIN
        IF RSPPOS < LENGTH(RESPONSE) THEN
          DELETE(RESPONSE, RSPPOS + ORD((CTRLKIND <> NOTCTRL)
            AND ((CTRLKIND <> BACKSPACE) OR  (RSPPOS = INSPOS))), 1);
          SCREENMSG(RSPX, RSPY, NULLCMD, RESPONSE);
          WRITE(FILLC);
      END; {CASE LEFT}
      RIGHT: BEGIN
        INSERT('^', RESPONSE, RSPPOS + 1);
        SCREENMSG(RSPX, RSPY, NULLCMD, RESPONSE);
      END; {CASE RIGHT}
    END; {CASE}
  END; {SHIFT}

  FUNCTION CHARAT(CHRPOS: INTEGER) : CHAR;
  {RETURNS THE CHARACTER AT POSITION CHRPOS IN RESPONSE}
  BEGIN {CHARAT}
    IF CHRPOS > LENGTH(RESPONSE) THEN
      CHARAT:= FILLC
    ELSE
      CHARAT:= RESPONSE[CHRPOS];
    END; {CHARAT}

    PROCEDURE DOINSCHR;
    LABEL EXIT;
    BEGIN {DOINSCHR}
      CASE INSERTING OF
        FALSE: BEGIN
          IF LENGTH(RESPONSE) < RSPLEN THEN
          BEGIN
            IF RSPLEN > (RSPPOS + 1) THEN
              SHIFT(RIGHT)
            ELSE
              WRITE('^');
            INSPOS:= RSPPOS;
            INSERTING:= TRUE;
          END
          ELSE
            WRITE(BELL);
        END; {CASE FALSE}
        TRUE: BEGIN
          IF RSPLEN > RSPPOS THEN
            IF (CTRLKIND = NOTCTRL) THEN
              RESPONSE[RSPPOS + 1]:= RSPCHR
            ELSE
              SHIFT(LEFT);
            INSERTING:= FALSE;
            TMPDEF:= RESPONSE;
        END; {CASE TRUE}
      END; {CASE}
EXIT:
  END; {DOINSCHR}

  PROCEDURE DONOTCTRL;
  LABEL EXIT;
  VAR
    ERROR : BOOLEAN;
  BEGIN {DONOTCTRL}
    {Little bell}
    ERROR:= FALSE;
    IF RSPPOS = RSPLEN THEN
    BEGIN
      IF INSERTING THEN DOINSCHR;
      ERROR:= TRUE;
    END;
    IF ERROR THEN
    BEGIN
      WRITE(BELL);
      GOTO EXIT; {EXIT(DONOTCTRL);}
    END; {IF}
    IF INSERTING THEN
      IF LENGTH(RESPONSE) = RSPLEN THEN
        DOINSCHR
      ELSE
        IF RSPLEN > (RSPPOS + 1) THEN
          SHIFT(RIGHT);
        GOTOXY(RSPX + RSPPOS, RSPY);
        IF RSPCHR IN NORMALCHR THEN
          WRITE(RSPCHR);
        RSPPOS:= RSPPOS + 1;
        IF RSPPOS > LENGTH(RESPONSE) THEN
          CHGLEN(RESPONSE, RSPPOS);
        RESPONSE[RSPPOS]:= RSPCHR;
EXIT:
  END; {DONOTCTRL}

  PROCEDURE DODUPCHR;
  BEGIN {DODUPCHR}
    IF RSPPOS < LENGTH(RESPONSE) THEN
      RSPPOS:= RSPPOS + 1
    ELSE
      WRITE(BELL);
    END; {DODUPCHR}

  PROCEDURE DOBACKSPACE;
  VAR
    TMPCHR : CHAR;
  BEGIN {DOBACKSPACE}
    IF RSPPOS = 0 THEN
      WRITE(BELL)
    ELSE
    BEGIN
      IF INSERTING THEN
        IF (RSPPOS = INSPOS) THEN
        BEGIN
          DOINSCHR;
          TMPCHR:= CHARAT(RSPPOS);
        END ELSE BEGIN
          SHIFT(LEFT);
          TMPCHR:= '^';
        END
      ELSE
        IF RSPPOS <= LENGTH(TMPDEF) THEN
        BEGIN
          TMPCHR:= TMPDEF[RSPPOS];
          RESPONSE[RSPPOS]:= TMPCHR;
        END ELSE BEGIN
          TMPCHR:= FILLC;
          DELETE(RESPONSE, RSPPOS, 1);
        END; {IF}
        RSPPOS:= RSPPOS - 1;
        GOTOXY(RSPX + RSPPOS, RSPY);
        WRITE(TMPCHR);
      END; {IF}
  END; {DOBACKSPACE}

  PROCEDURE CHGPOS(NEWPOS: INTEGER);
  BEGIN {CHGPOS}
    IF RSPPOS = NEWPOS THEN
      WRITE(BELL)
    ELSE
    BEGIN
      RSPPOS:= NEWPOS;
      TMPDEF:= RESPONSE;
    END; {IF}
  END; {CHGPOS}

  PROCEDURE DOBEGFLD;
  BEGIN {DOBEGFLD}
    CHGPOS(0);
  END; {DOBEGFLD}

  PROCEDURE DOENDFLD;
  BEGIN {DOENDFLD}
    CHGPOS(LENGTH(RESPONSE));
  END; {DOENDFLD}

  PROCEDURE DODELCHR;
  BEGIN {DODELCHR}
    IF RSPPOS < LENGTH(RESPONSE) THEN
    BEGIN
      SHIFT(LEFT);
      TMPDEF:= RESPONSE;
    END
    ELSE
      WRITE(BELL);
  END; {DODELCHR}

  PROCEDURE SETDEFAULT;
  BEGIN
    CHGLEN(RESPONSE, RSPPOS);
    JUSTIFY(RESPONSE, TMPDEF, LEFT, FILLC, RSPLEN);
    SCREENMSG(RSPX, RSPY, NULLCMD, TMPDEF);
    TMPDEF:= RESPONSE;
  END; {SETDEFAULT}

  PROCEDURE DOCLRTOEND;
  BEGIN {DOCLRTOEND}
    IF RSPPOS < LENGTH(RESPONSE) THEN
      SETDEFAULT
    ELSE
      WRITE(BELL);
  END; {DOCLRTOEND}

  PROCEDURE DOACCEPT;
  BEGIN {DOACCEPT}
    RSPPOS:= LENGTH(RESPONSE);
    TERMINATED:= TRUE;
  END; {DOACCEPT}

  PROCEDURE DOTRUNCATE;
  BEGIN {DOTRUNCATE}
    IF RSPPOS = 0 THEN
      RSPPOS:= LENGTH(RESPONSE);
    TERMINATED:= TRUE;
  END; {DOTRUNCATE}

  PROCEDURE INITDEFAULT;
  BEGIN
    RESPONSE:= DEFAULT;
    RSPPOS:= LENGTH(DEFAULT);
    SETDEFAULT;
    RSPPOS:= 0;
  END; {INITDEFAULT}

  PROCEDURE DORESTORE;
  BEGIN {DORESTORE}
    IF RESPONSE = DEFAULT THEN
      WRITE(BELL)
    ELSE
      INITDEFAULT;
  END; {DORESTORE}

  PROCEDURE DOESCAPE;
  BEGIN {DOESCAPE}
    RSPPOS:= 0;
    TERMINATED:= TRUE;
  END; {DOESCAPE}

  PROCEDURE DOHELP;
  BEGIN {DOHELP}
    HELPTYPED:= TRUE;
    DOACCEPT;
  END; {DOHELP}

  PROCEDURE DOSTOP;
  BEGIN {DOSTOP}
    STOPTYPED:= TRUE;
    TERMINATED:= TRUE;
  END; {DOSTOP}

  PROCEDURE DISPRSP(SRCSTRG: STRINGP; CLRAREA: BOOLEAN);
  BEGIN {DISPRSP}
    JUSTIFY(SRCSTRG, TMPDEF, LEFT, BACKGROUND, FMTLEN);
    IF CLRAREA THEN
        JUSTIFY(NULLSTRG, TMPDEF, LEFT, SPACE, LENGTH(TMPDEF));
    SCREENMSG(RSPX, RSPY, NULLCMD, TMPDEF);
  END; {DISPRSP}

BEGIN {PROM}
  INSERTING:= FALSE;
  TERMINATED:= FALSE;
  RSPCHR:= NULL;
  FMTLEN:= RSPLEN;
  DISPRSP(NULLSTRG, TRUE);
  VALIDCHR:= NORMALCHR + CTRLCHR;
  INITDEFAULT; {SET AND DISPLAY ORIGINAL DEFAULT}
  STOPTYPED:= FALSE;
  HELPTYPED:= FALSE;
  REPEAT
    GOTOXY(RSPX + RSPPOS, RSPY);
    GETCHR(0, FALSE, VALIDCHR);
    IF RSPCHR IN CTRLCHR THEN
    BEGIN
      IF RSPCHR = CHR(127) THEN RSPCHR:= BS;
      CTRLKIND:= CTRL[ORD(RSPCHR)];
      IF INSERTING THEN
        IF (CTRLKIND <> INSCHR) AND (CTRLKIND <> BACKSPACE) THEN
          DOINSCHR;
      CASE CTRLKIND OF DUPCHR: DODUPCHR;
        BACKSPACE: DOBACKSPACE;
        INSCHR:    DOINSCHR;
        BEGFLD:    DOBEGFLD;
        ENDFLD:    DOENDFLD;
        DELCHR:    DODELCHR;
        CLRTOEND:  DOCLRTOEND;
        ACCEPT:    DOACCEPT;
        TRUNCATE:  DOTRUNCATE;
        RESTORE:   DORESTORE;
        ESCAPE:    DOESCAPE;
        HELPER:    DOHELP;
        STOPER:    DOSTOP;
      END; {CASE}
    END ELSE BEGIN
      CTRLKIND:= NOTCTRL;
      DONOTCTRL;
    END; {IF}
  UNTIL TERMINATED;
  CHGLEN(RESPONSE, RSPPOS);
  DISPRSP(RESPONSE, FALSE);
END; {PROM}

PROCEDURE INITPROM;
BEGIN {PROMUTIL INITIALIZATION}
  NULL:= CHR(0);
  BELL:= CHR(7);
  BS:=   CHR(8);
  LF:=   CHR(10);
  CR:=   CHR(13);
  HELPC:=CHR(17); {Control-Q}
  STOPC:=CHR(24); {Control-X}
  ESC:=  CHR(27);
  FILLC:=CHR(95); {Underscore}
  BACKGROUND:= SPACE;
  NULLSET:= [];
  INITCTRL;
END; {PROMUTIL INITIALIZATION}

{end of file PROM200.INC *****************************************************}