Power-Programmierung/CD1.mdf/pascal/library/dos/io/io_23/io23demo.pas

Pascal/Delphi Source File | 1988-02-11 | 19.0 KB | 603 lines

{$R-}    {Range checking off}
{$B-}    {Boolean short circuiting off}
{$S+}    {Stack checking on}
{$I+}    {I/O checking on}
{$N-}    {No numeric coprocessor}
{$M 16384,0,16384}

program IO23DEMO ;
  { 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.
      Ver. 2.3 -- Add screen stuff, set colors -- IBM only, not CP/M.
      Converted to Turbo Pascal 4.0 -- 12/2/87

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

{$v-}

Uses
  Crt, printer, Dos, io23unit, date23, dos23 ;

const
    config_fname     = 'IO23.CFG' ;            { Config file name }

type
    config_rec = record
      { Configuration record }
        bgc,                                   { 0 -- background color }
        txc    : integer ;                     { 1 -- text color }
        cfgint : array [2..63] of integer ;    { reserved for future use }
      end ;

var
    today       : datestring ;
    choice      : integer ;                    { to get menu choice }
    quitnow     : boolean ;                    { to get user Y/N input }
    config      : config_rec ;                 { Configuration record }
    config_file : file of config_rec ;         { Configuration file }

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

procedure title_screen ;

var
    ch : char ;
    i  : integer ;

    begin
        clrscr;
        write_str ('------------------',31,6) ;
        write_str ('                  ',31,7) ;
        rvson ;
        write_str ('   Demonstration  ',31,8) ;
        write_str ('        of        ',31,9) ;
        write_str ('   Turbo Pascal   ',31,10) ;
        write_str ('  User Interface  ',31,11) ;
        rvsoff ;
        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) ;
        fld := 0 ;
        hard_pause ;
        if fld = maxint then
          begin
            gotoxy (1,23) ;
            halt
          end
    end ; { proc title_screen }

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

procedure display_menu ;
begin
    clrscr ;
    write_str(today,35,1) ;
    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('4    Change colors',26,15) ;
    write_str('ESC  Exit the program',26,17) ;
    write_str('==>',26,19)
end ; { proc display_menu }

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

procedure display_instructions ;
begin
    clrscr;
    rvson ;
    write_str('                              Labelled     Arrow   Ctrl     Function ',6,1) ;
    write_str('COMMAND                         key         key    key      key (IBM)',6,2) ;
    rvsoff ;
    writeln ;
    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 ;
        rvson ;
        write ('SCREEN ', scrn, ' -- STRINGS') ;
        rvsoff ;
        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 ;
        rvson ;
        write ('SCREEN ', scrn, ' -- INTEGERS') ;
        rvsoff ;
        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 ;
        rvson ;
        write ('SCREEN ', scrn, ' -- REALS') ;
        rvsoff ;
        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;
        rvson ;
        write ('SCREEN ', scrn, ' -- BOOLEANS') ;
        rvsoff ;
        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 }

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

function exists (filename : str14) : boolean ;
  { test to see if file exists }
var
    infile : file ;
begin
    assign (infile,filename) ;
    {$i-} reset(infile) {$i+} ;
    if ioresult = 0 then
      begin
        exists := true ;
        close (infile)
      end
    else
        exists := false
end ; { function exists }

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

procedure set_colors ;

label 99 ;   { for ESC exit }

var
    n,
    savebgcolor,
    savetxcolor : integer ;
    color_ok    : boolean ;

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

procedure paint_color_screen ;
  begin
    clrscr ;
    write_str ('CHANGE COLORS',34,1) ;
    write_str ('Please enter your choice of colors or',22,3) ;
    write_str ('press ESC to cancel.',22,4) ;
    write_str ('DARK COLORS       BRIGHT COLORS',22,6) ;
    write_str ('--------------    -------------------',22,7) ;
    write_str ('0 - Black         8  - Dark Grey',22,8) ;
    write_str ('1 - Blue          9  - Bright Blue',22,9) ;
    write_str ('2 - Green         10 - Bright Green',22,10) ;
    write_str ('3 - Cyan          11 - Bright Cyan',22,11) ;
    write_str ('4 - Red           12 - Bright Red',22,12) ;
    write_str ('5 - Magenta       13 - Bright Magenta',22,13) ;
    write_str ('6 - Brown         14 - Yellow',22,14) ;
    write_str ('7 - Light Grey    15 - White',22,15) ;
    rvson ;
    write_str ('This is reverse video',22,17) ;
    rvsoff ;
    emphon ;
    write_str ('This is emphasized',22,18) ;
    emphoff ;
    write_str ('Background color (0-7):',28,20) ;
    write_int (bgcolor,1,52,20) ;
    write_str ('Text color (0-15):',28,21) ;
    write_int (txcolor,2,51,21)
  end ;

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

begin { proc set_colors }
    paint_color_screen ;
    if is_mono then
      begin
        show_msg ('YOU CANNOT CHANGE COLORS ON A MONOCHROME MONITOR') ;
        exit
      end ;

    savebgcolor := bgcolor ;                 { save entry values }
    savetxcolor := txcolor ;
    fld := 1 ;
    repeat
        case fld of
          1: read_int (bgcolor,1,52,20) ;
          2: read_int (txcolor,2,51,21) ;
          3: begin
               assigncolors ;
               paint_color_screen ;
               write_str ('Is this OK? (Y/N)',28,23) ;
               color_ok := false ;
               read_bool (color_ok,50,23) ;
               if not (fld = maxint) then
                   if fld > 3 then
                     begin
                       if color_ok then
                           fld := 4       { normal exit }
                       else
                           fld := 1
                     end ;
               clrline(28,23)
             end { 3 }
        end ; { case }
        if fld = maxint then goto 99 ;    { ESC exits }
        if fld < 1 then
            fld := 1
        else if not (bgcolor in [0..7]) then
          begin
            beep ;
            fld := 1
          end
        else if (not (txcolor in [0..15])) and (fld > 2) then
          begin
            beep ;
            fld := 2
          end
        else if (fld > 4) then
            fld := 3 ;
99:
    until fld > 3 ;
    if fld = maxint then                     { restore entry values }
      begin
        bgcolor := savebgcolor ;
        txcolor := savetxcolor ;
        assigncolors
      end
    else if not ((bgcolor = savebgcolor) and (txcolor = savetxcolor)) then
      begin
        config.bgc := bgcolor ;              { store defaults in config file }
        config.txc := txcolor ;
        for n := 2 to 63 do
            config.cfgint[n] := 0 ;
        rewrite (config_file) ;
        write (config_file,config) ;
        close (config_file)
      end ;
    fld := 1
  end ; { proc set_colors }

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

procedure initialize ;

var
    dosdate : date ;

begin  { proc initialize }
    assign (config_file, config_fname) ;
    if (exists (config_fname)) and (not is_mono) then
      begin
        reset (config_file) ;
        read  (config_file,config) ;
        close (config_file) ;
        bgcolor := config.bgc ;
        txcolor := config.txc
      end
    else
      begin
        bgcolor := 0 ;
        txcolor := 7
      end ;
    assigncolors ;
    getdate(dosdate) ;
    today := mk_dt_st(dosdate)
  end ; { proc initialize }

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

begin { --- program IO23DEMO --- }
(*  directvideo := false { uncomment this to avoid conflicts with Fansi-Console, etc. }
*)
    checkbreak := false ;
    initialize ;
    title_screen ;
    repeat
        display_menu ;
        repeat
            fld := 1 ;
            choice := 0 ;
            read_int (choice,1, 31,19) ;
            if fld < 1 then choice := 0 ;
            if fld = maxint then
              begin
                write_str (' ',31,19) ;
                write_str ('QUIT NOW? (Y/N)',26,21) ;
                read_yn (quitnow,42,21) ;
                if not quitnow then
                  begin
                    fld := 1 ;
                    choice := 0 ;
                    clrline (26,21)
                  end
              end ;
        until (choice in [1 .. 4]) or (fld = maxint) ;
        if not (fld = maxint) then
            case choice of
              1: display_instructions ;
              2: io_demo ;
              3: date_demo ;
              4: set_colors
            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.