Power-Programmierung/CD1.mdf/pascal/library/dos/io/io_22/io22.inc

Text File | 1987-05-24 | 26.8 KB | 801 lines

{ IO22.INC -- Global I/O procedures to include in programs generally
  by Bill Meacham
  Ver 2.0 -- includes prev_page and next_page, changes where pause text
             is displayed -- 2/26/86.
             Cosmetic improvements -- 4/16/86.
  Ver 2.l -- Add function Pad -- 10/12/86.
  Ver 2.2 -- Add ability to move cursor within input line -- 5/24/87. }

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

const
                       { ASCII values of cursor control keys, like WordStar. }
                       { Note -- Backspace and Delete are different in CP/M  }
                       {         and PC-DOS.  Proc KEYIN translates them.    }
    prev_char = $13 ;  { ^S }
    next_char = $04 ;  { ^D }
    prev_fld  = $05 ;  { ^E }
    next_fld  = $18 ;  { ^X }
    prev_page = $12 ;  { ^R }
    next_page = $03 ;  { ^C }
    del_char  = $07 ;  { ^G }
    del_left  = $08 ;  { ^H (Backspace) }
    del_fld   = $19 ;  { ^Y }
    del       = $7F ;  { Delete }
    escape    = $1B ;
    carr_rtn  = $0D ;
    space     = $20 ;
    filler    = $2E ;  { . }

type
    str_type = string[80] ;

    registers = record
        ax,bx,cx,dx,bp,si,di,ds,es,flags : integer ;
    end ;

    intset = set of $00 .. $FF ;

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

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 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 set_bool (var bool : boolean) ;
  { Sets boolean to be undefined, neither true nor false.
    Boolean is stored as one byte:
        $80 = undefined
        $01 = true
        $00 = false.
    Note : Turbo interprets $80 as true because it is greater than zero! }

    var
        b : byte absolute bool ;
    begin
        b := $80
    end ;  { proc set_bool }

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

function defined (bool : boolean) : boolean ;
  { Determines whether the boolean is defined or not }
    var
        b : byte absolute bool ;
    begin
        defined := not (b = $80)
    end ;  { function defined }

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

procedure write_bool (bool:boolean ; col, row:integer) ;
    begin
        gotoxy (col,row) ;
        if not defined(bool) then
            write ('___')
        else 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.
  Maps Kaypro arrow keys to WordStar cursor keys. }
    begin
        read (kbd, ch) ;
        if ch = ^H then              { make Backspace non-destructive }
            ch := chr(prev_char)
        else if ch = ^L then
            ch := chr(next_char)
        else if ch = ^K then
            ch := chr(prev_fld)
        else if ch = ^J then
            ch := chr(next_fld)
        else if ord(ch) = del then
            ch := chr(del_left)     { make Delete key delete to left }
    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.
  From Turbo 3.0 manual, page 360 -- 5/29/85
  Modified for IO20 -- 2/26/86
  Modified for IO22 -- 5/24/87 }

    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 function keys }
            case key of
              63,75 : key := prev_char ;  { F5, left-arrow }
              64,77 : key := next_char ;  { F6, right-arrow }
              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 : key := del_char ;   { F1, DEL }
              60    : key := del_fld ;    { F2 }
            else      key := 00 ;
            end  { case }
        else  { not a function key }
            case key of                   { CP/M-like control keys }
              $0B   : key := prev_fld ;   { ^K }
              $0A   : key := next_fld ;   { ^J }
              $0C   : key := next_char ;  { ^L }
            end ;  { case }

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

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

function build_str (ch : char ; n : integer) : str_type ;
  { returns a string of length n of the character ch }
    var
        st : str_type ;
    begin
        if n < 0 then
            n := 0 ;
        st[0] := chr(n) ;
        fillchar (st[1],n,ch) ;
        build_str := st
    end ;  { function build_str) ;

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

function pad (st : str_type ; ch : char ; i : integer) : str_type ;
{ Pad string with ch to length of i.  Do not let i exceed 80 (length of str_type! }
  var
    l : integer ;
  begin
    l := length(st) ;
    if l < i then
      begin
        fillchar (st[l+1],i-l,ch) ;
        st[0] := chr(i)
      end ;
    pad := st
  end;

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

procedure adjust_str (var st : str_type ;
                      var  p : integer ;  { position of char to left of cursor }
                         key,             { ord of adjusting character }
            maxlen, col, row : integer ) ;
  { Adjusts position of cursor within string, deletes characters, etc. }
    begin
      case key of
        prev_char : if p > 0 then
                        p := pred(p) ;
        next_char : if p < length(st) then
                        p := succ(p) ;
        del_left  : if p > 0 then
                      begin
                        delete (st,p,1) ;
                        write (^H,copy(st,p,maxlen),chr(filler)) ;
                        p := pred(p)
                      end ;
        del_char  : if p < length(st) then
                      begin
                        delete (st,p+1,1) ;
                        write (copy(st,p+1,maxlen),chr(filler))
                      end ;
        del_fld   : begin
                      st := '' ;
                      p := 0  ;
                      write_str (build_str(chr(filler),maxlen),col,row)
                    end
      end  { case }
    end ; { proc adjust_str }

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

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 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.

    Revised 6/04/85 -- WPM }

    var
        ch   : char ;     { character from keyboard }
        key,              { ord(ch) }
        p    : integer ;  { position of char to left of cursor }

    procedure add_to_str ;
        begin
          if not (length(st) = maxlen) then
            begin
              p := p + 1 ;
              insert (ch,st,p) ;
              write (copy(st,p,maxlen))
            end
        end ; {--- of add_to_str ---}

    begin {--- read_str ---}
        write_str (st, col, row) ;
        write (build_str(chr(filler),maxlen - length(st))) ;
        p := length(st) ;
        repeat
            gotoxy (col + p, row) ;
            keyin (ch) ;
            key := ord(ch) ;
            if key in [$20 .. $7E] then  { printable character }
                add_to_str
            else if key in adjusting then
                adjust_str (st,p,key,maxlen,col,row)
            else if key in terminating then
                do_fld_ctl (key)
            else
                beep
        until key in terminating ;
        gotoxy (col + length(st), row) ;
        write ('':maxlen - length(st))
    end ; {--- of 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.

    Revised 6/04/85 -- WPM }

    const
        maxst : string[5] = '32767' ;  { string representation of maxint }

    var
        ch    : char ;       { character from keyboard }
        key,                 { ord(ch) }
        p     : integer ;    { position of char to left of cursor }
        st    : string[5] ;  { string representation of integer }
        code  : integer ;    { result of string to integer conversion }

    procedure add_to_str ;
        begin
          if not (length(st) = maxlen) then
            begin
              p := p + 1 ;
              insert (ch,st,p) ;
              write (copy(st,p,maxlen))
            end
        end ; {--- of add_to_str---}

    begin {--- read_int ---}
        str (int:maxlen, st) ;          { convert integer into string }
        st := purgech (st, ' ') ;
        st := stripch (st, '0') ;
        write_str (st, col, row) ;
        write (build_str(chr(filler),maxlen - length(st))) ;
        p := length(st) ;
        repeat
            gotoxy (col + p, row) ;
            keyin (ch) ;
            key := ord(ch) ;
            if key = $2D then                 { minus sign }
              begin
                if  (pos('-',st) = 0)
                and (length(st) < maxlen)
                and (p = 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
                  begin
                    delete (st,p,1) ;
                    write (^H,copy(st,p,maxlen),chr(filler)) ;
                    p := p - 1
                  end
              end
            else if key in adjusting then
                adjust_str (st,p,key,maxlen,col,row)
            else if key in terminating then
                do_fld_ctl (key)
        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 ; {--- of 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.  In TurboBCD,
    the maximum number of significant digits is 18.  It is the
    programmer's responsibility to limit input and computed output
    to the maximum significant digits.

    Revised 6/04/85 -- WPM }

    var
        ch   : char ;       { Input character }
        key,                { ord(ch) }
        p    : integer ;    { position of char to left of cursor }
        st   : string[20] ; { String representation of real number -- }
                            { max digits plus minus sign plus decimal point }
        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. }
        posdec : integer ;  { position of decimal point in string }

  { +++++++++++++++++++++++++++++++++++++ }

    procedure compute_length ;
      { Compute length of left and right portions of string }
        begin
            posdec := pos('.',st) ;
            if posdec = 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 := posdec ;          { Left is all up to and incl. dec. pt. }
                    rlen := length(st) - llen { Right is the rest }
                end
        end ; { proc compute_length }

  { +++++++++++++++++++++++++++++++++++++ }

    procedure add_to_str ;

        procedure add_it ;
            begin
              p := p + 1 ;
              insert (ch,st,p) ;
              write (copy(st,p,maxlen))
            end ;

        begin {add_to_str}
            posdec := pos ('.',st) ;
            if ch = '.' then        { Decimal point; if room, add it }
              begin
                if  (posdec = 0)
                and (length(st) - p <= frac) then
                    add_it
              end
                                    { else it's not a decimal point }
                                    { see if digit fits in whole part }
            else if  (    (posdec = 0)
                      and (llen < maxl - 1)  { only dec. pt. allowed in pos. maxl }
                     )
                 or  (    (posdec > 0)
                      and (llen < maxl)
                      and (p < posdec)
                     ) then

                add_it

                                    { digit is candidate for fractional part }
            else if  (not(posdec = 0))
                 and (p >= posdec)
                 and (rlen < frac) then

                add_it

        end ; {--- of 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 ;
        compute_length ;

                              {Write string on console}

        write_str (st, col, row) ;
        write (build_str(chr(filler),maxlen - length(st))) ;
        p := length(st) ;

                              {Get input a character at a time & edit it}

        repeat
            gotoxy (col + p, row) ;
            compute_length ;
            if (    (posdec = 0)
                and (llen > maxl - 1)
               )
            or (    (not (posdec = 0))
                and (llen > maxl)
               )
            or (rlen > frac) then                   { if number is larger than }
              begin                                 { spec then delete it all }
                key := del_fld ;
                adjust_str (st,p,key,maxlen,col,row) ;
                gotoxy (col,row)
              end ;
            keyin (ch) ;
            key := ord(ch) ;
            if key = $2D  then                      { minus sign }
              begin
                if  (pos('-',st) = 0)
                and (p = 0)
                and (  (    (posdec = 0)
                        and (llen < maxl - 1)
                       )
                    or (    (not (posdec = 0))
                        and (llen < maxl)
                       )
                    ) then

                    add_to_str

              end
            else if key in [$2E, $30 .. $39] then   { decimal point, numeric digits }
                add_to_str
            else if key in adjusting then
                adjust_str (st,p,key,maxlen,col,row)
            else if key in terminating then
                do_fld_ctl (key) ;
        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 ; {--- of 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."
    Boolean is "forced;" user cannot cursor forward past undefined
    boolean.  Pressing "Y" or "N" terminates entry.

    Boolean is stored as one byte:
        $80 = undefined
        $01 = true
        $00 = false.
    Note : Turbo interprets $80 as true because it is greater than zero! }

    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
              begin
                if  (not defined(bool))
                and (key in [carr_rtn, next_fld, next_page]) then
                    key := $00
                else
                    do_fld_ctl (key)
              end
        until key in terminating ;
        write_bool (bool, col, row)
    end ; {--- of 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 IO22.INC ----------------------------------------- }