Between Heaven & Hell 2/BetweenHeavenHell.cdr/300/216/io20.inc

Text File | 1986-05-02 | 22KB | 661 lines

{ IO20.INC -- Global I/O procedures to include in programs generally
  Version 2.0 includes prev_page and next_page, changes where pause text
  is displayed -- WPM -- 2/26/86.
  Cosmetic improvements -- 4/16/86 }

{ ------------------------------------------------------------ }

const
    prev_fld  = $0B ;  { ^K -- up_arrow on Kaypro II '83 }
    next_fld  = $0A ;  { ^J -- linefeed, down_arrow }
    backspace = $08 ;  { ^H -- Backspace key }
    del_fld   = $19 ;  { ^Y }
    prev_page = $12 ;  { ^R }
    next_page = $03 ;  { ^C }
    escape    = $1B ;
    carr_rtn  = $0D ;
    del       = $7F ;
    filler    = $2E ;  { . }

type
    str_type = string[80] ;

    intset = set of $00 .. $ff ;

const  { Turbo typed constants -- initialized variables }
    terminating : intset = [carr_rtn, next_fld, prev_fld, next_page,
                            prev_page, escape] ;
    adjusting   : intset = [backspace, del_fld, del] ;

var
    fld, scrn   : integer ; {For field & screen cursor control}

{ ------------------------------------------------------------ }

{ procedure gotoxy (col,row) ; -- Built-in proc in Turbo to place
  cursor on screen.  Upper left is (1,1) not (0,0)! }

{ procedure clrscr ; -- Built-in proc in Turbo to clear screen. }

{ procedure clreol ; -- built-in proc in Turbo to clear to end of line }

{ ------------------------------------------------------------ }

procedure clrline (col,row : integer) ;
    begin
        gotoxy (col,row) ;
        clreol
    end ;

{ ------------------------------------------------------------ }

procedure clreos ;
    begin
        write (chr($17))   {Clear to end of screen on Kaypro & ADM-3A}
    end ;

{ ------------------------------------------------------------ }

procedure beep ;
    begin
        write (chr(7))
    end ;

{ ------------------------------------------------------------ }

procedure do_fld_ctl (key : integer) ;
  { Adjusts global FLD based on value of key, the ordinal value of last key pressed }
  { global
        fld : integer -- for field cursor control }
    begin
        case key of
          carr_rtn, next_fld : fld := succ(fld) ;
          prev_fld           : fld := pred(fld) ;
          next_page          : fld := 999 ;
          prev_page          : fld := -999 ;
          escape             : fld := maxint ;
        end  { case }
    end ;  { proc do_fld_ctl }

{ ------------------------------------------------------------ }

procedure do_scrn_ctl ;
  { Checks value of FLD and adjusts value of SCRN accordingly }
  { Global
        fld, scrn : integer -- For field and screen cursor control }
    begin
        if fld < 1 then
                scrn := pred(scrn)
        else if fld = maxint then
                scrn := maxint
        else
                scrn := succ(scrn)
    end ;

{ ------------------------------------------------------------ }

procedure write_str (st:str_type ; col,row:integer) ;
    begin
        gotoxy (col,row) ;
        write (st)
    end ;

{ ------------------------------------------------------------ }

procedure write_int (int:integer ; width,col,row:integer) ;
    begin
        gotoxy (col,row) ;
        write (int:width)
    end ;

{ ------------------------------------------------------------ }

procedure write_bool (bool:boolean ; col, row:integer) ;
    begin
        gotoxy (col,row) ;
        if bool then write ('YES') else write ('NO ')
    end ;

{ ------------------------------------------------------------ }

procedure write_real (r:real ; width,frac,col,row:integer) ;
    begin
        gotoxy (col,row) ;
        write (r:width:frac)
    end ;

{ ------------------------------------------------------------ }

{ This is for Kaypro CP/M -- comment it out to use IBM }
(*
procedure keyin (var ch:char) ;
{ Reads a single character from keyboard without echoing it back.
  Modified to trap WordStar commands, 4/29/85 }
    begin
        read (kbd, ch) ;
        if ch = ^S then
            ch := chr(backspace)
        else if ch = ^E then
            ch := chr(prev_fld)
        else if ch = ^X then
            ch := chr(next_fld)
    end ;
*)
{ ------------------------------------------------------------ }

{ This is for IBM PC-DOS -- comment it out for CP/M }

procedure keyin (var ch:char) ;
{ Reads a single character from keyboard without echoing it back.
  Maps function key scan codes to single keyboard keys.
  Modified for IBM -- from Turbo 3.0 manual, page 360 -- 5/29/85
  Modified for IO20 -- 2/26/86 }

    var
        func : boolean ;     { Whether function key or not }
           c : char ;        { Character read }
         key : integer ;     { ORD of character returned }

    begin
        func := false ;
        read (kbd,c) ;                       { Get first char }
        if  (ord(c) = escape)                { If there is }
        and keypressed then                  { a second ... }
          begin
            read (kbd,c) ;                   { Get 2nd char }
            func := true
          end ;
        key := ord(c) ;

        if func then                         { Translate func. keys }
            case key of
              61,72 : key := prev_fld ;   { F3, up-arrow }
              62,80 : key := next_fld ;   { F4, down-arrow }
              65,73 : key := prev_page ;  { F7, PgUp }
              66,81 : key := next_page ;  { F8, PgDn }
              59,83,75 : key := backspace ;  { F1, DEL, left-arrow }
              60    : key := del_fld ;    { F2 }
            else      key := 00 ;
            end  { case }
        else  { not a function key }
            case key of
              $13   : key := backspace ;  { ^S -- Like WordStar }
              $05   : key := prev_fld ;   { ^E }
              $18   : key := next_fld ;   { ^X }
            end ;  { case }

        ch := chr(key)                       { finally, return the character }
    end ;

{ ------------------------------------------------------------ }

function purgech (instr : str_type ; inchar : char) : str_type ;
    {Purges all instances of the character from the string}
    var
        n      : integer ;  {Loop counter}
        outstr : str_type ; {Result string}

    begin
        outstr := '' ;
        for n := 1 to length (instr) do
                if not (instr[n] = inchar) then
                        outstr := concat (outstr, instr[n]) ;
        purgech := outstr
    end ;

{ ------------------------------------------------------------ }

function stripch (instr:str_type ; inchar:char) : str_type ;
    {Strips leading instances of the character from the string}
    begin
        while not (length(instr) = 0)
        and (instr[1] = inchar) do
                delete (instr, 1, 1) ;
        stripch := instr
    end ;

{ ------------------------------------------------------------ }

function chopch (instr:str_type ; inchar:char) : str_type ;
    {Chops trailing instances of the character from the string}
    begin
        while not (length(instr) = 0)
        and (instr[length(instr)] = inchar) do
                delete (instr, length(instr), 1) ;
        chopch := instr
    end ;

{ ------------------------------------------------------------ }

procedure adjust_str (var st : str_type ; key, maxlen, col, row : integer ) ;
  { deletes a character or the whole entry }
    var
        i : integer ;
    begin
      case key of
        del_fld   : begin
                      st := '' ;
                      gotoxy (col, row) ;
                      for i := 1 to maxlen do
                          write (chr(filler)) ;
                      gotoxy (col, row)
                    end ;
        backspace,
        del       : if length(st) = 0 then
                        beep
                    else
                      begin
                        write (chr(backspace), chr(filler), chr(backspace)) ;
                        delete (st, length(st), 1)
                      end
      end  { case }
    end ; { proc adjust_str }

{ ------------------------------------------------------------ }

procedure read_str (var st:str_type ; maxlen, col, row:integer) ;

  { Read String.  This procedure gets input from the keyboard one
    character at a time and edits on the fly, rejecting invalid
    characters.  COL and ROW tell where to begin the data input
    field, and MAXLEN is the maximum length of the string to be
    returned. }

    var
        ch          : char ;
        i,key       : integer ;

    procedure add_to_str ;
        begin
            if length(st) = maxlen then
                    beep
            else
                begin
                    st  := concat(st, ch) ;     {concatenate char. onto str.}
                    write (ch)
                end
        end ; { proc add_to_str }

    begin {--- read_str ---}
        write_str (st, col, row) ;
        for i := (length(st)+1) to maxlen do
                write (chr(filler)) ;
        gotoxy ((col + length(st)), row) ;
        repeat
            keyin (ch) ;
            key := ord(ch) ;
            if key in [$20 .. $7e] then
                add_to_str
            else if key in adjusting then
                adjust_str (st,key,maxlen,col,row)
            else if key in terminating then
                do_fld_ctl (key)
            else
              beep ;
        until key in terminating ;
        write ('':maxlen - length(st))
end ; { proc read_str }

{ ------------------------------------------------------------ }

procedure read_int (var int:integer ; maxlen, col, row:integer) ;

  { Read Integer.  This procedure gets input from the keyboard
    one character at a time and edits on the fly, rejecting
    invalid characters.  COL and ROW tell where to begin the data
    input field, and MAXLEN is the maximum length of the integer
    to be returned. }

    var
        ch          : char ;
        i,key       : integer ;
        st          : string[5] ;
        maxst       : string[5] ;
        code        : integer ;

    procedure add_to_str ;
        begin
            if length(st) = maxlen then
                    beep
            else
                begin
                    st  := concat(st, ch) ;     {concatenate char. onto str.}
                    write (ch)
                end
        end ; { proc add_to_str }

    begin {--- read_int ---}
        str (maxint:5, maxst) ;                    {Make integer into string}
        str (int:maxlen, st) ;
        st := purgech (st, ' ') ;
        st := stripch (st, '0') ;
        write_str (st, col, row) ;
        for i := (length(st)+1) to maxlen do
                write (chr(filler)) ;
        gotoxy ((col + length(st)), row) ;
        repeat
            keyin (ch) ;
            key := ord(ch) ;
            if key = $2d then                 { minus sign }
              begin
                if  length(st) = 0 then
                    add_to_str
                end
            else if key in [$30 .. $39] then  {digits 0 - 9}
              begin
                add_to_str ;
                if (length(st) = 5)
                and (st > maxst) then
                    adjust_str (st,del,maxlen,col,row)
              end
            else if key in adjusting then
                adjust_str (st,key,maxlen,col,row)
            else if key in terminating then
                do_fld_ctl (key)
            else
              beep ;
        until key in terminating ;

        if st = '' then
            begin
                int := 0 ;
                code := 0
            end
        else
                val (st, int, code) ;              {Make string into integer}
        gotoxy (col, row) ;
        if code = 0 then  {Conversion worked OK}
                write (int:maxlen)
        else
            begin
                write ('** CONVERSION ERROR ', code) ;
                halt
            end
end ; { proc read_int }

{ ------------------------------------------------------------ }

function equal (r1,r2 : real) : boolean ;
  { tests functional equality of two real numbers -- 4/30/85 }
    begin
        equal := abs(r1 - r2) < 1.0e-5
    end ;  { function equal }

{ ------------------------------------------------------------ }

function greater (r1,r2 : real) : boolean ;
  { tests functional inequality of two real numbers -- 5/1/85 }
    begin
        greater := (r1 - r2) > 1.0e-5
    end ;  { function greater }

{ ------------------------------------------------------------ }

procedure read_real (var r:real ; maxlen,frac,col,row:integer) ;

  { Read Real.  This procedure gets input from the keyboard
    one character at a time and edits on the fly, rejecting
    invalid characters.  COL and ROW tell where to begin the data
    input field; MAXLEN is the maximum length of the string
    representation of the real number, including sign and decimal
    point; FRAC is the fractional part, the number of digits to
    right of the decimal point.

    Note -- In Turbo the maximum number of significant digits in
    decimal (not scientific) representation is 11.  It is the
    programmer's responsibility to limit input and computed output
    to 11 significant digits.  }

    var
        ch          : char ;    {Input character}
        i,key       : integer ; {Loop control ; ORD of CH}
        st          : string[13] ; {String representation of real number}
        code        : integer ; {Result of VAL conversion}
        rlen        : integer ; {Current length of ST to right of dec. pt.}
        llen        : integer ; {Current length to left, including dec. pt.}
        maxl        : integer ; {Max allowable to left, including dec. pt.}

    procedure compute_length ;
        begin
            if pos ('.', st) = 0 then     { If no dec. pt. ... }
              begin
                llen := length(st) ;      {the whole string is Left}
                rlen := 0                 {and none is Right}
              end
            else    {There is a decimal point ...}
              begin
                llen := pos ('.', st) ;   {Left is all up to dec. pt.}
                rlen := length(st) - llen {Right is the rest}
              end
        end ; { proc compute_length }

    procedure add_to_str ;
        procedure add_it ;
            begin
                st  := concat(st, ch) ;
                write (ch)
            end ;
        begin { add_to_str }
            if ch = '.' then      { Decimal point: if not one already, add it }
              begin
                if pos('.', st) = 0 then
                    add_it
                else
                    beep
              end
                                  { else it's not a decimal point }
            else if pos('.',st) = 0 then
            { There's no dec pt in string, so digit goes on left. }
              begin
                if llen = (maxl - 1) then
                    beep  { Only a dec pt is allowed in pos MAXL }
                else
                    add_it
              end
            else  { There is a dec pt in string, so digit goes on right }
              begin
                if rlen = frac then
                    beep
                else
                    add_it
              end
        end ; { proc add_to_str }

    begin {--- read_real ---}
                              {Initialize}
        maxl  := maxlen - frac ;
                              {Set up string representation of real and }
                              {determine length of left & right portions}
        str(r:maxlen:frac,st) ;           {Make real into string}
        st := purgech (st, ' ') ;         {Purge all blanks}
        st := stripch (st, '0') ;         {Strip leading zeroes}
        if not (pos('.', st) = 0) then    {If there is a dec. pt ... }
            begin
                st := chopch (st, '0') ;  {Chop trailing zeroes}
                st := chopch (st, '.')    {and trailing dec. pt.}
            end ;

                              {Write string on console}
        write_str (st, col, row) ;
        for i := (length(st)+1) to maxlen do
                write (chr(filler)) ;
        gotoxy ((col + length(st)), row) ;

                              {Get input a character at a time & edit it}
        repeat
                compute_length ;
                keyin (ch) ;
                key := ord(ch) ;
                if ch = '-' then
                  begin
                    if length(st) = 0 then
                        add_to_str
                    else
                        beep
                  end
                else if (ch = '.')
                     or (ch in ['0' .. '9']) then
                    add_to_str
                else if key in adjusting then
                    adjust_str (st,key,maxlen,col,row)
                else if key in terminating then
                    do_fld_ctl (key)
                else
                    beep
        until key in terminating ;

                              {Done getting input, now convert back to real}
        if (st = '')                             {If null string ... }
        or (st = '.')
        or (st = '-')
        or (st = '-.') then
            begin
                r := 0.0 ;                       {Make real zero}
                code := 0
            end
        else    {Not a null string}
                val (st, r, code) ;              {Make string into real}
        gotoxy (col, row) ;
        if code = 0 then  {Conversion worked OK}
                write (r:maxlen:frac)            {Write the real on screen}
        else
            begin
                write ('** CONVERSION ERROR ', code) ;
                halt
            end
end ; { proc read_real }

{ ------------------------------------------------------------ }

procedure read_yn (var bool:boolean; col,row:integer) ;
  { Inputs "Y" OR "N" to boolean at column and row specified,
    prints "YES" or "NO."

    Note -- use this when the screen control will not return
    to the question and the boolean IS NOT defined before the
    user answers the question.  Does not affect global FLD. }

    var ch:char ;
    begin
        gotoxy (col,row) ;
        write ('   ') ;
        gotoxy (col,row) ;
        repeat
                keyin (ch)
        until (ch in ['Y', 'y', 'N', 'n']) ;
        if (ch = 'Y') or (ch = 'y') then
            begin
                write ('YES') ;
                bool := true
            end
        else
            begin
                write ('NO ') ;
                bool := false
            end
    end ; { proc read_yn }

{ ------------------------------------------------------------ }

procedure read_bool (var bool:boolean; col,row:integer) ;
  { Displays boolean at column and row specified, inputs "Y"
    or "N" to set new value of boolean, prints "YES" or "NO."

    Note -- use this when the screen control may return to the
    question and the boolean IS defined before the user answers
    the question.  Does affect global FLD. }

    var
        ch         : char ;
        key        : integer ;

    begin
        write_bool (bool, col, row) ;
        gotoxy (col, row) ;
        repeat
            keyin (ch) ;
            key := ord(ch) ;
            if key in [$59, $79] then           { 'Y', 'y' }
                begin
                    bool := true ;
                    key := next_fld ;
                    do_fld_ctl(key)
                end
            else if key in [$4E, $6E] then      { 'N', 'n' }
                begin
                    bool := false ;
                    key := next_fld ;
                    do_fld_ctl(key)
                end
            else if key in terminating then
                do_fld_ctl(key)
            else
                beep ;
        until key in terminating ;
        write_bool (bool, col, row)
    end ; { proc read_bool }

{ ------------------------------------------------------------ }

procedure pause ;
    {Prints message on bottom line, waits for user response}
    var
        ch   : char ;
        key : integer ;
    begin
        clrline (1,24) ;
        write_str ('PRESS SPACE BAR TO CONTINUE OR UP-ARROW TO GO BACK',14,24) ;
        repeat
                keyin (ch) ;
                key := ord(ch) ;
                case key of
                  $20      : fld := succ(fld) ;
                  prev_fld : fld := pred(fld) ;
                  prev_page : fld := -999 ;
                  escape   : fld := maxint ;
                end ;
        until key in [$20, prev_fld, prev_page, escape] ;
        clrline (1,24)
    end ; { proc pause }

{ ------------------------------------------------------------ }

procedure hard_pause ;
  { Like Pause, but only accepts space bar or Escape and only goes forward }
    var
        ch   : char ;
        key : integer ;
    begin
        clrline (1,24) ;
        write_str ('PRESS SPACE BAR TO CONTINUE',26,24) ;
        repeat
                keyin (ch) ;
                key := ord(ch) ;
                case key of
                  $20      : fld := succ(fld) ;
                  escape   : fld := maxint ;
                end ;
        until key in [$20, escape] ;
        clrline (1,24)
    end ; { proc hard_pause }

{ ------------------------------------------------------------ }

procedure show_msg (msg : str_type) ;
  { Beeps, displays message centered on line 23, pauses }

    var
        savefld : integer ;

    begin
        savefld := fld ;
        beep ;
        clrline (1,23) ;
        write_str (msg,((80-length(msg)) div 2),23) ;
        hard_pause ;
        clrline (1,23) ;
        fld := savefld ;
    end ; { proc show_msg }

{ ----- EOF IO20.INC ----------------------------------------- }