Power-Programmierung/CD1.mdf/pascal/library/dos/io/io_22/io22demo.pas

Pascal/Delphi Source File | 1987-05-24 | 15.4 KB | 470 lines

program IO22DEMO ;
  { This program demonstrates Turbo Pascal console I/O routines for an
    elegant user interface.
      Original version          --  4/18/86.
      Added day of week display -- 10/ 9/86.
      Version 2.2 enhancements  --  5/24/87.

    PUBLIC DOMAIN, NO COPYRIGHT
      William Meacham
      1004 Elm Street
      Austin, Tx  78703

    NOTES FOR CP/M:
      *  Comment out IBM version of proc KEYIN in file IO22.INC
         and un-comment CP/M version of proc KEYIN.
      *  Change text of instruction screen below.  As written, it is for IBM.
         For CP/M, DEL is destructive backspace and Backspace is
         non-destructive character-left.
      *  Comment out call to Lowvideo at beginning of main routine, below.
      *  Compile to COM file with End address of $8000. }

{$c-,v-}
{$i io22.inc }                      { Console I/O (user interface) routines }
{$i date22.inc }                    { Date routines }

var
    choice           : integer ;    { to get menu choice }
    quitnow          : boolean ;    { to get user Y/N input }

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

procedure title_screen ;

label 99 ;

const
    dly = 500 ;

var
    ch : char ;
    i  : integer ;

    begin
        clrscr;
        write_str ('------------------',31,6) ;
        write_str ('                  ',31,7) ;
        write_str ('   Demonstration  ',31,8) ;
        write_str ('        of        ',31,9) ;
        write_str ('   Turbo Pascal   ',31,10) ;
        write_str ('  User Interface  ',31,11) ;
        write_str ('                  ',31,12) ;
        write_str ('------------------',31,13) ;
        write_str ('    Reliance Software Services',23,18) ;
        write_str ('1004 Elm Street, Austin, Tx  78703',23,19) ;
        write_str ('   Public Domain - No Copyright',23,21) ;
        write_str ('PRESS SPACE BAR TO CONTINUE',26,24) ;
        fld := 0 ;
        i := 0 ;
        while i < maxint do
          begin
            if keypressed then
              begin
                keyin(ch) ;
                if (ch = #$20) or (ch = #$1B) then
                  begin
                    i := maxint ;
                    if ch = #$1B then
                        fld := maxint ;
                    goto 99
                  end
              end ;
            if i mod 337 = 0 then
              begin
                write_str ('*',31,6) ;
                gotoxy (54,24) ;
                delay (dly) ;
                write_str ('-',31,6) ;
                gotoxy (54,24)
              end ;
            if i mod 523 = 0 then
              begin
                write_str ('*',45,8) ;
                gotoxy (54,24) ;
                delay (dly) ;
                write_str ('o',45,8) ;
                gotoxy (54,24)
              end ;
            if i mod 1024 = 0 then
              begin
                write_str ('*',35,11) ;
                gotoxy (54,24) ;
                delay (dly) ;
                write_str ('e',35,11) ;
                gotoxy (54,24)
              end ;
            if i mod 1118 = 0 then
              begin
                write_str ('*',48,13) ;
                gotoxy (54,24) ;
                delay (dly) ;
                write_str ('-',48,13) ;
                gotoxy (54,24)
              end ;
            i := succ(i) ;
            if i = maxint then
                i := 0 ;
99:
          end ; { while i < maxint }

        if fld = maxint then
          begin
            gotoxy (1,23) ;
            halt
          end
    end ; { proc title_screen }

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

procedure display_menu ;
begin
    clrscr ;
    write_str('USER INTERFACE DEMONSTRATION',26,3) ;
    write_str('MAIN MENU',36,4) ;
    write_str('Please select:',26,6) ;
    write_str('1    Display instructions',26,8) ;
    write_str('2    Data entry and display demo for',26,10) ;
    write_str('Strings, Integers, Reals and Booleans',31,11) ;
    write_str('3    Data entry and display demo for Dates',26,13) ;
    write_str('ESC  Exit the program',26,15) ;
    write_str('==>',26,17)
end ; { proc display_menu }

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

procedure display_instructions ;
begin
    clrscr;
    writeln('                                   Labelled     Arrow   Ctrl     Function') ;
    writeln('     COMMAND                         key         key    key      key (IBM)') ;
    writeln('     --------------------------    --------     -----   ----     ---------') ;
    writeln('  *  DELETE character at cursor      Del                  G         F1') ;
    writeln('  *  DELETE character to left      Backspace') ;
    writeln('  *  DELETE entire entry                                  Y         F2') ;
    writeln ;
    writeln('  *  MOVE LEFT one character                    left      S         F5') ;
    writeln('  *  MOVE RIGHT one character                   right     D         F6') ;
    writeln ;
    writeln('  *  MOVE FORWARD to next field     Enter       down      X         F4') ;
    writeln('  *  MOVE BACK to previous field                 up       E         F3') ;
    writeln ;
    writeln('  *  PAGE FORWARD to next screen                PgDn      C         F8') ;
    writeln('  *  PAGE BACK to previous screen               PgUp      R         F7') ;
    writeln ;
    writeln('  *  CANCEL data entry               Esc') ;
    writeln ;
    writeln('  *  TO ENTER DATA:   Type the data & press Enter or a field or page key.') ;
    writeln('  *  TO ENTER YES/NO: Type "Y" or "N;" don''t press Enter.') ;
    writeln('  *  TO ENTER A DATE: Type the month, 2 digits, the day, 2 digits,') ;
    writeln('                      and the year, 2 or 4 digits, and press Enter.') ;
    hard_pause ;
    fld := 1 { reset FLD for calling proc }
end ; { proc display_instructions }

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

procedure io_demo ;
  { demonstrate I/O of strings, integers, reals and booleans }

var
    first, last, addr1, addr2, city,
          state, zip : str_type ;   { for string demo }
    i1, i2, i3, itot : integer ;    { for integer demo }
    r1, r2, r3, rtot : real ;       { for real demo }
    b1, b2, b3, b4   : boolean ;    { for boolean demo }

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

procedure init_io_vars ;
  { Initializes global variables }
    begin
        first := '' ;
        last  := '' ;
        addr1 := '' ;
        addr2 := '' ;
        city  := '' ;
        state := '' ;
        zip   := '' ;
        i1 := 0 ;
        i2 := 0 ;
        i3 := 0 ;
        itot := 0 ;
        r1 := 0 ;
        r2 := 0 ;
        r3 := 0 ;
        rtot := 0 ;
        b1 := false ;
        b2 := false ;
        b3 := false ;
        b4 := false
    end ; { proc init_io_vars }

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

procedure strings ;
  { This procedure demonstrates reading and writing strings. }

    var
        i  : integer ; { For loop control }
        ok : boolean ; { Whether zip code is numeric }

    begin
        clrscr ;
        write ('SCREEN ', scrn, ' -- STRINGS') ;
        write_str ('First name:',9,8) ;
        write_str (first,21,8 ) ;
        write_str ('Last name:',9,9) ;
        write_str (last,21,9) ;
        write_str ('Address 1:',9,10) ;
        write_str (addr1,21,10) ;
        write_str ('Address 2:',9,11) ;
        write_str (addr2,21,11) ;
        write_str ('City:',9,12) ;
        write_str (city,21,12) ;
        write_str ('State:',9,13) ;
        write_str (state,21,13) ;
        write_str ('Zip:',9,14) ;
        write_str (zip,21,14) ;
        fld := 1 ;
        repeat
                case fld of
                  1: read_str (first, 15, 21, 8) ;
                  2: read_str (last, 10, 21, 9) ;
                  3: read_str (addr1, 15, 21, 10) ;
                  4: read_str (addr2, 15, 21, 11) ;
                  5: read_str (city, 15, 21, 12) ;
                  6: read_str (state, 2, 21, 13) ;
                  7: begin
                       repeat
                           read_str (zip, 5, 21, 14) ;
                           ok := true ;
                           if not (zip = '') then
                               begin
                                   if length (zip) < 5 then
                                           ok := false
                                   else
                                           for i:= 1 to 5 do
                                               if (zip[i] <'0')
                                               or (zip[i] >'9') then
                                                   ok := false
                               end ;
                           if not ok then
                             begin
                               show_msg ('MUST BE NUMERIC OR NOT ENTERED') ;
                               zip := '' ;
                               fld := 7
                             end
                       until ok ;
                     end ; { 7: }
                end ; { case }
        until (fld < 1) or (fld > 7) ;
        do_scrn_ctl
    end ; { proc strings }

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

procedure integers ;
  { This procedure demonstrates reading & writing integers. }

    procedure sum_int ;
        begin
            itot := i1 + i2 + i3 ;
            write_int (itot, 5, 13, 12)
        end ;

    begin { integers }
        clrscr ;
        write ('SCREEN ', scrn, ' -- INTEGERS') ;
        write_str ('==>', 9, 8) ;
        write_int (i1,4,14,8) ;
        write_str ('==>', 9, 9) ;
        write_int (i2,4,14,9) ;
        write_str ('==>', 9, 10) ;
        write_int (i3,4,14,10) ;
        write_str ('TOTAL', 7, 12) ;
        write_int (itot,5,13,12) ;
        fld := 1 ;
        repeat
                case fld of
                  1: begin
                       read_int (i1, 4, 14, 8) ;
                       sum_int ;
                     end ;
                  2: begin
                       read_int (i2, 4, 14, 9) ;
                       sum_int ;
                     end ;
                  3: begin
                       read_int (i3, 4, 14, 10) ;
                       sum_int ;
                     end ;
                  4: pause ;
                end ; { case }
        until (fld < 1) or (fld > 4 ) ;
        do_scrn_ctl
    end ; { proc integers }

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

procedure reals ;
  { This procedure demonstrates reading & writing reals. }

    const
        tot  = 11 ;
        frac = 3  ;

    procedure sum_real ;
        begin
            rtot := r1 + r2 + r3 ;
            write_real (rtot, tot+1, frac, 13, 12)
        end ;

    begin { proc reals }
        clrscr ;
        write ('SCREEN ', scrn, ' -- REALS') ;
        write_str ('==>', 9, 8) ;
        write_real (r1,tot,frac,14,8) ;
        write_str ('==>', 9, 9) ;
        write_real (r2,tot,frac,14,9) ;
        write_str ('==>', 9, 10) ;
        write_real (r3,tot,frac,14,10) ;
        write_str ('TOTAL', 7, 12) ;
        write_real (rtot,12,3,13,12) ;
        fld := 1 ;
        repeat
                case fld of
                  1: begin
                       read_real (r1, tot,frac, 14, 8) ;
                       sum_real ;
                     end ;
                  2: begin
                       read_real (r2, tot,frac, 14, 9) ;
                       sum_real ;
                     end ;
                  3: begin
                       read_real (r3, tot,frac, 14, 10) ;
                       sum_real ;
                     end ;
                  4: pause ;
                end ; { CASE }
        until (fld < 1) or (fld > 4 ) ;
        do_scrn_ctl
    end ; { proc reals }

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

procedure booleans ;
  { This procedure demonstrates reading & writing booleans }
    begin
        clrscr;
        write ('SCREEN ', scrn, ' -- BOOLEANS') ;
        write_str ('TYPE OF CO-BORROWER.  Type "Y" for all that apply.',3,8) ;
        write_str ('"No" will be assumed if you just press <RETURN>.',3,9) ;
        write_str ('1 - Another person will be jointly obligated with borrower',5,10) ;
        write_str ('2 - Borrower is relying on income of another person',5,11) ;
        write_str ('3 - Married, living in a community property state',5,12) ;
        write_bool (b1, 71, 10) ;
        write_bool (b2, 71, 11) ;
        write_bool (b3, 71, 12) ;
        write_str ('Epimenides the Cretan says, "All Cretans are liars!"  Is he lying?',3,14) ;
        write_bool (b4, 71, 14) ;
        fld := 1 ;
        repeat
            case fld of
              1: read_bool (b1, 71, 10) ;
              2: read_bool (b2, 71, 11) ;
              3: read_bool (b3, 71, 12) ;
              4: read_bool (b4, 71, 14) ;
              5: pause ;
            end ; { case }
        until (fld <1) or (fld > 5) ;
        do_scrn_ctl
    end ; { booleans }

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

procedure final_screen ;
  { The final screen -- demonstrates proc Read_YN }
    var
        more : boolean ;
    begin
        clrscr ;
        write_str ('End of demonstration.',20, 10) ;
        write_str ('Do it again?',20, 12) ;
        read_yn (more, 34, 12) ;
        if more then
            scrn := 1
        else
            scrn := succ(scrn)
    end ; { proc final_screen }

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

begin { ----- proc io_demo ----- }
    scrn := 1 ;
    init_io_vars ;
    repeat
        case scrn of
          1 : strings  ;
          2 : integers ;
          3 : reals ;
          4 : booleans ;
          5 : final_screen
        end ; { case }
        if scrn < 1 then
              scrn := 1           { no going backward from first screen }
        else if scrn > 6 then
              scrn := 5           { trap ESC }
    until scrn > 5 ;
    fld := 1 ;                    { reset FLD for calling proc }
end ; { proc io_demo }

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

{$i datedemo.inc -- procedure date_demo }

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

begin { --- program IO22DEMO --- }
    lowvideo ;
    title_screen ;
    repeat
        display_menu ;
        repeat
            fld := 1 ;
            choice := 0 ;
            read_int (choice,1, 31,17) ;
            if fld < 1 then choice := 0 ;
            if fld = maxint then
              begin
                write_str (' ',31,17) ;
                write_str ('QUIT NOW? (Y/N)',26,19) ;
                read_yn (quitnow,42,19) ;
                if not quitnow then
                  begin
                    fld := 1 ;
                    choice := 0 ;
                    clrline (26,19)
                  end
              end ;
        until (choice in [1 .. 3]) or (fld = maxint) ;
        if not (fld = maxint) then
            case choice of
              1: display_instructions ;
              2: io_demo ;
              3: date_demo ;
            else
                 beep
            end  { case }
    until fld = maxint ;
    clrscr ;
    write_str ('Thank you for trying the Reliance User Interface Demonstration',12,5) ;
    write_str ('Program.  Please send me your comments and suggestions.',12,6) ;
    write_str ('Bill Meacham',30,10) ;
    write_str ('Reliance Software Services',24,11) ;
    write_str ('1004 Elm Street',29,12) ;
    write_str ('Austin, Tx  78703',28,13) ;
    writeln ; writeln
end.