home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 10 / 10.iso / l / l320 / 2.img / EXAMPLES / SCREENIN.F < prev    next >
Encoding:
Text File  |  1989-10-10  |  25.4 KB  |  869 lines
  1. c    Program SCREENIN: demonstration of GREX text-mode features
  2. c
  3. c    Copyright (C) 1989 by MicroWay Inc.
  4. c    For use in NDP applications
  5. c    by SSF and PNS
  6. c
  7. c
  8.  
  9.       INTEGER month, day, year, err, x, y, iattr
  10.  
  11.       INTEGER key, get_a_key, get_ordinal, iy, ix, kb
  12.  
  13.       INTEGER level
  14.  
  15.       CHARACTER*40 help_messages(11)
  16.  
  17.       CHARACTER*20 words(10)
  18.  
  19.       CHARACTER*80 string
  20.  
  21.       CHARACTER first_name*14, mi*1, last_name*30, magazine*30, town*26
  22.  
  23.       CHARACTER street*30, state*2, zip_code*10, telephone*14, ch*1
  24.  
  25.       CHARACTER q
  26.  
  27.       INCLUDE "scrval.fh"
  28.  
  29.       INCLUDE "GREX.FH"
  30.  
  31.       COMMON level,help_messages(11)
  32.  
  33.       first_name = ' '
  34.       mi         = ' '
  35.       last_name  = ' '
  36.       magazine   = ' '
  37.       town       = ' '
  38.       street     = ' '
  39.       state      = ' '
  40.       zip_code   = ' '
  41.       telephone  = ' '
  42.  
  43. c    initialize text mode actions
  44.       CALL get_video_mode(max_row,max_column)
  45.  
  46. c    initialize help messages
  47.       CALL messages
  48.  
  49. c    clear screen
  50.       CALL cls
  51.  
  52. c    Print a banner
  53.       CALL place_string_at(30,4,"MicroWay Questionnaire")
  54.  
  55. c    print the questionaire headings using the dim attribute
  56.       CALL set_active_attribute(idim)
  57.  
  58.       CALL place_string_at(0,6,"TODAY'S DATE")
  59.       CALL place_string_at(0,8,"NAME")
  60.       CALL place_string_at(0,10,"MAGAZINE READ")
  61.       CALL place_string_at(0,11,"STREET ADDRESS")
  62.       CALL place_string_at(0,12,"TOWN")
  63.       CALL place_string_at(31,12,"STATE")
  64.       CALL place_string_at(41,12,"ZIP CODE")
  65.       CALL place_string_at(0,13,"TELEPHONE")
  66.  
  67. c    set the attribute back to bright
  68.       CALL set_active_attribute(ibright)
  69.  
  70. c    read the date with bright attribute
  71.       CALL input_date_at(15,6,imonth,iday,iyear)
  72.  
  73. c    now change back to a dim attribute
  74.       CALL set_active_attribute(idim)
  75.  
  76. c    now put the help message on the screen
  77. c    that tells the user about alt-h and help messages
  78.       CALL help(0)
  79.  
  80.       CALL place_string_at(10,0,"use <left> and <up> arrows to go back")
  81.       CALL place_string_at(10,1,
  82.      &     "use <right>, <down> and <Enter> to advance")
  83.  
  84. c    now set the attribute byte back to bright
  85.       CALL set_active_attribute(ibright)
  86.  
  87.       call pause
  88.  
  89. c    initialize kb to non zero so that first usage works with
  90. c    arrow keys
  91.  
  92.       kb = 2
  93.  
  94. c   The main part of the program works like a linked list of
  95. c   subroutines. Each call to input_string_at updates the
  96. c   string that that particular call edits. This routine is
  97. c   written so that it can be reentered and it will start up
  98. c   editing in the same location on the screen. After exiting
  99. c   we check to see how the user left. If he left with an up
  100. c   or left arrow, we know that he wants to go backwards up the
  101. c   chain, and we call the previous invocation. If he exited with
  102. c   the <Enter>, down arrow or right arrow keys, we know he wants to go
  103. c   on and we fall through to the next call to input_string_at
  104. c   or we fall into the section which summarizes the values input
  105. c   from the screen
  106.     
  107.    10 level = 1
  108.       CALL input_string_at(0,9,"First ",first_name,kb,err)
  109.       IF ((kb .EQ. key_up_arrow) .OR. (kb .EQ. key_lt_arrow)) GOTO 10
  110.  
  111.    20 level = 2
  112.       CALL input_string_at(20,9,"MI ",mi,kb,err)
  113.       IF ((kb .EQ. key_up_arrow) .OR. (kb .EQ. key_lt_arrow)) GOTO 10
  114.  
  115.    30 level = 3
  116.       CALL input_string_at(26,9,"Last ",last_name,kb,err)
  117.       IF ((kb .EQ. key_up_arrow) .OR. (kb .EQ. key_lt_arrow)) GOTO 20
  118.  
  119.    40 level = 4
  120.       CALL input_string_at(14,10," ",magazine,kb,err)
  121.       IF ((kb .EQ. key_up_arrow) .OR. (kb .EQ. key_lt_arrow)) GOTO 30
  122.  
  123.    50 level = 5
  124.       CALL input_string_at(15,11," ",street,kb,err)
  125.       IF ((kb .EQ. key_up_arrow) .OR. (kb .EQ. key_lt_arrow)) GOTO 40
  126.  
  127.    60 level = 6
  128.       CALL input_string_at(5,12,"L",town,kb,err)
  129.       IF ((kb .EQ. key_up_arrow) .OR. (kb .EQ. key_lt_arrow)) GOTO 50
  130.  
  131.    70 level = 7
  132.       CALL input_string_at(37,12,"L",state,kb,err)
  133.       IF ((kb .EQ. key_up_arrow) .OR. (kb .EQ. key_lt_arrow)) GOTO 60
  134.  
  135.    80 level = 8
  136.       CALL input_string_at(50,12,"L",zip_code,kb,err)
  137.       IF ((kb .EQ. key_up_arrow) .OR. (kb .EQ. key_lt_arrow)) GOTO 70
  138.  
  139.    90 level = 9
  140.       CALL input_string_at(10,13,"L",telephone,kb,err)
  141.       IF ((kb .EQ. key_up_arrow) .OR. (kb .EQ. key_lt_arrow)) GOTO 80
  142.  
  143.   100 level = 10
  144.       CALL input_string_at(0,15,"Hit enter if complete ",ch,kb,err)
  145.       IF ((kb .EQ. key_up_arrow) .OR. (kb .EQ. key_lt_arrow)) GOTO 90
  146.  
  147. c   Now demonstrate the use of the alternate screens or pages.
  148. c
  149. c   Note: if you take advantage of these features, you
  150. c   cannot mix in ordinary Fortran I/O, as it always gets
  151. c    written and displayed on page 0
  152.  
  153.       CALL set_active_text_page(1)
  154.  
  155.       CALL cls
  156.  
  157.       CALL place_string_at(0,12,"Your input is:")
  158.  
  159.       CALL place_string_at(0,15,first_name)
  160.       ix = klen(first_name)+2
  161.       CALL place_string_at(ix,15,mi)
  162.       ix = ix+klen(mi)+2
  163.       CALL place_string_at(ix,15,last_name)
  164.       CALL place_string_at(0,16,magazine)
  165.       CALL place_string_at(0,17,street)
  166.       CALL place_string_at(0,18,town)
  167.       CALL place_string_at(0,19,state)
  168.       CALL place_string_at(0,20,zip_code)
  169.       CALL place_string_at(0,21,telephone)
  170.  
  171. c    now display page 1
  172.       CALL display_text_page(1)
  173.  
  174.  
  175.       CALL place_string_at(10,0,"Page 1 is now on the screen")
  176.       CALL set_active_attribute(iblinking_bright)
  177.       CALL place_string_at(10,1,"Hit any key to return to page 0")
  178.       CALL set_active_attribute(ibright)
  179.  
  180.       CALL pause
  181.  
  182.       CALL set_active_text_page(0)
  183.  
  184.       CALL cls
  185.  
  186.       CALL display_text_page(0)
  187.  
  188. C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  189.  
  190. C  Draw a frame around the screen, using currently active attribute
  191.  
  192. c    know max_row and max_column
  193.       ier = get_video_mode (max_row, max_column)
  194. c    move to top left
  195.       ier = home ()
  196. c    write a ┌
  197.       ier = write_one_char (218)
  198. c    move right one space
  199.       ier = rt_cursor ()
  200. c    write a line of ─
  201.       ier = write_char (196,max_column)
  202. c    move to right side
  203.       ier = locate (max_column,0)
  204. c    write a ┐
  205.       ier = write_one_char (191)
  206. c    for each line between the top and the bottom
  207.       do 1000 i=1,max_row-1
  208. c         write a │ on the left side
  209.            ier = locate (0,i)
  210.            ier = write_one_char (179)
  211. c         write a │ on the right side
  212.            ier = locate (max_column,i)
  213.            ier = write_one_char (179)
  214.  1000 continue
  215. c    End-for
  216. c    move to bottom left
  217.       ier = locate (0,max_row)
  218. c    write a └
  219.       ier = write_one_char (192)
  220. c    move right one space
  221.       ier = rt_cursor ()
  222. c    write a line of ─
  223.       ier = write_char (196,max_column)
  224. c    move to bottom right
  225.       ier = locate (max_column,max_row)
  226. c    write a ┘
  227.       ier = write_one_char (217)
  228.  
  229. C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  230.  
  231. C    Test scrolling of windows in text-mode
  232. c
  233. c      Scrolling is limited so that blank lines are not introduced into
  234. c      the window.
  235.  
  236. C    The data to be scrolled consist, logically enough,
  237. C      of MicroWay product names.
  238.  
  239.       words( 1) = 'NDP Fortran-386'
  240.       words( 2) = 'NDP C-386'
  241.       words( 3) = 'NDP Pascal-386'
  242.       words( 4) = 'Monoputer'
  243.       words( 5) = 'Quadputer'
  244.       words( 6) = 'Videoputer'
  245.       words( 7) = 'flickerFixer'
  246.       words( 8) = 'FastCache 286'
  247.       words( 9) = '287 TurboPlus'
  248.       words(10) = '386/387 Turbo-AT'
  249.  
  250. C    Show these ten items in a window that is only five lines high
  251.  
  252.       ier = place_string_at( 9, 5,'┌───── MicroWay ─────┐')
  253.       ier = place_string_at( 9, 6,'│                    │')
  254.       ier = place_string_at( 9, 7,'│                    │')
  255.       ier = place_string_at( 9, 8,'│                    │')
  256.       ier = place_string_at( 9, 9,'│                    │')
  257.       ier = place_string_at( 9,10,'│                    │')
  258.       ier = place_string_at( 9,11,'└────────────────────┘')
  259.  
  260. C    Write the initial text into the window
  261.  
  262.       ier = place_string_at(10, 6,words( 1))
  263.       ier = place_string_at(10, 7,words( 2))
  264.       ier = place_string_at(10, 8,words( 3))
  265.       ier = place_string_at(10, 9,words( 4))
  266.       ier = place_string_at(10,10,words( 5))
  267.  
  268. C    Instruct the user
  269.  
  270.       ier = locate(2,max_row-3)
  271.       ier = write_string('Use arrow keys to scroll up or down')
  272.       ier = locate(2,max_row-2)
  273.       ier = write_string('Press <Enter> or <Esc> to view the next test')
  274.  
  275. C    j is the index of the list element in the top line of the window
  276.  
  277. C    k is the index of the list element in the bottom line of the window
  278.  
  279.       j = 1
  280.       k = 5
  281.  
  282. C    While the user presses a key other than <Enter> or <Esc>,
  283.  1005 key = pause()
  284.       if(key.ne.13.and.key.ne.10.and.key.ne.27) then
  285. c         get a key from the user
  286. c         if key is the up arrow, scroll the window down
  287. c                                 decrement the list pointers
  288. c                                 if you would scroll blanks onto the screen
  289. c                                   then don't; beep instead.
  290.            if(key.eq.-72) then
  291.                 k = k-1
  292.                 j = j-1
  293.                 if(j.lt.1) then
  294.                      ier = beep()
  295.                      j = 1
  296.                      k = k+1
  297.                    else
  298.                      ier = scroll_active_page_down(10,6,29,10,1,7)
  299.                      ier = place_string_at(10, 6,words(j))
  300.                    endif
  301.               endif
  302. c         if key is the down arrow, scroll the window up
  303. c                                   increment the list pointers
  304. c                                   if you would scroll blanks onto the screen
  305. c                                     then don't; beep instead.
  306.            if(key.eq.-80) then
  307.                 j = j+1
  308.                 k = k+1
  309.                 if(k.gt.10) then
  310.                      ier = beep()
  311.                      k = 10
  312.                      j = j-1
  313.                    else
  314.                      ier = scroll_active_page_up(10,6,29,10,1,7)
  315.                      ier = place_string_at(10,10,words(k))
  316.                    endif
  317.               endif
  318. c           get another key from the user
  319.            go to 1005
  320.          endif
  321. c    End-while
  322.  
  323.       call cls
  324.  
  325. C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  326.  
  327. C    Test cursor movement functions
  328. C         get_cursor
  329. C         read_char
  330. C         read_attr
  331.  
  332.  
  333. C    Write an array of characters to the screen, with different attributes.
  334.       do 1013 i=1,4
  335.            do 1012 j =1,64
  336.                 ia = 64*(i-1) + j - 1
  337.                 k = 48 + mod(j-1,16)
  338.                 if(k.gt.57) k = k+7
  339.                 ier = locate(j+7,i+7)
  340.                 ier = write_char_attr (k,1,ia)
  341.  1012      continue
  342.  1013 continue
  343.  
  344. c    Instructions
  345.       ier = place_string_at (2,max_row-3,'Move cursor with arrow keys')
  346.       ier = locate (2,max_row-2)
  347.       ier = write_string ('Press <Esc> to view the next test. ')
  348.  
  349. C    know max_row and max_column
  350.       ier = get_video_mode(max_row,max_column)
  351. c    find the cursor
  352.       ier = get_cursor(ic,ir)
  353. c    while the user presses a key other than Escape
  354.  1014 key = pause()
  355.       if (key.ne.27) then
  356. c         move the cursor in response
  357. c                                                        Home key
  358.            if (key.eq.-71) ier = locate(0,ir)
  359. c                                                        Up arrow
  360.            if (key.eq.-72) ier = up_cursor()
  361. c                                                        PgUp key
  362.            if (key.eq.-73) ier = locate(ic,0)
  363. c                                                        Left arrow
  364.            if (key.eq.-75) ier = lt_cursor()
  365. c         note that the 5 key on the keypad is dead
  366. c                                                        Right arrow
  367.            if (key.eq.-77) ier = rt_cursor()
  368. c                                                        End key
  369.            if (key.eq.-79) ier = locate(max_column,ir)
  370. c                                                        Down arrow
  371.            if (key.eq.-80) ier = dn_cursor()
  372. c                                                        PgDn key
  373.            if (key.eq.-81) ier = locate(ic,max_row)
  374. c         get current cursor location
  375.            ier = get_cursor(ic,ir)
  376. c         read character at cursor position
  377.            k = read_char()
  378. c           the function returns an integer.  Convert to character.
  379.            q = char(k)
  380. c         read attribute at cursor position
  381.            ia = read_attr()
  382. c         write cursor position, character, and attribute in lower right
  383.            write(string,610) ir,ic,q,ia
  384.   610      format(2i4,1x,a,i4)
  385.            ier = place_string_at(max_column-14,max_row,string)
  386. c         get another key
  387.            go to 1014
  388.          endif
  389. c    End-while
  390.  
  391. C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  392.  
  393.       CALL locate(0,max_row)
  394.  
  395.       STOP 'Okay.'
  396.  
  397.       END
  398.  
  399. c***********************************************************************
  400. c
  401. c   Rewritten by P. Schweitzer to take advantage of new features
  402. c
  403.       subroutine input_string_at(xin,yin,prompt,result,key,err)
  404.  
  405.       integer max_row,max_column
  406.       integer ia
  407.       integer iblank
  408.       integer xin,yin,key,err
  409.       integer ix,jx,L,klen,x,y
  410.       integer get_a_key
  411.       character*(*) prompt,result
  412.       character*9 cv
  413.       character nul
  414.  
  415. c    include keyboard and color definitions
  416.       include 'scrval.fh'
  417.  
  418. c    make a few definitions here
  419.       iblank = 32
  420.       nul = char(0)
  421.       x = xin
  422.       y = yin
  423.  
  424. c    get screen limits
  425.       call get_video_mode(max_row,max_column)
  426.  
  427. c    show prompt if its length is greater than one
  428.       call locate(x,y)
  429.       if(len(prompt).gt.1) call write_string(prompt)
  430.  
  431. c    save current attribute
  432.       call get_active_attribute(ia)
  433.       call set_active_attribute(ireverse_bright)
  434.  
  435. c    current location is character after prompt or screen edge
  436.       call get_cursor(x,y)
  437.  
  438. c    save this; it is the leftward limit of backspacing
  439.       ix = x
  440.       if(x.eq.max_column) ix = x
  441.  
  442. c    write the result string into the remaining space
  443.       call locate(ix,y)
  444.       call write_string(result)
  445.  
  446. c    find out where this leaves the cursor
  447.       call get_cursor(x,y)
  448.  
  449. c    save cursor x-coordinate; it is the rightward limit of data entry
  450.       jx = ix + len(result) - 1
  451.       if(x.eq.max_column) jx = x
  452.  
  453. c    clear nul characters from result string
  454.       do 1 j = 1,len(result)
  455.            if(result(j:j).eq.nul) result(j:j) = ' '
  456.     1 continue
  457.  
  458. c    put cursor after last nonblank character in result
  459.       L = klen(result)
  460.       x = ix + L
  461. c    or on last displayable character, whichever is smaller
  462.       x = min0(x,jx)
  463.       call locate(x,y)
  464.  
  465. c    Get a key from user
  466.     5 key = get_a_key()
  467.  
  468.       if(key.gt.0) then
  469.  
  470.            If(key.eq.key_help) then
  471.                 call help(0)
  472.               endif
  473.  
  474.            if(key.eq.key_enter) then
  475.                 go to 86
  476.              endif
  477.  
  478.            if(key.eq.key_del) then
  479. c              find index of letter at cursor position
  480.                 j = x - ix + 1
  481. c              set to blank
  482.                 result(j:j) = ' '
  483. c              display
  484.                 call write_one_char(result(j:j))
  485.              endif
  486.  
  487.            if(key.eq.key_backspace) then
  488. c              move cursor one space to the left (if possible)
  489.                 x = max0(x-1,ix)
  490.                 call locate(x,y)
  491. c              blank this position
  492.                 call write_one_char(iblank)
  493. c              find index of letter at new cursor position
  494.                 j = x - ix + 1
  495. c              set to blank
  496.                 result(j:j) = ' '
  497. c              and get next key
  498.                 go to 5
  499.              endif
  500.  
  501. c         if key is a normal character, place on screen
  502.            call write_one_char(key)
  503. c         store character in result string
  504.            j = x - ix + 1
  505.            result(j:j) = char(key)
  506. c         move cursor to the right one space if possible
  507.            x = min0(x+1,jx)
  508.            call locate(x,y)
  509.  
  510.          else
  511.  
  512.            if(key.eq.key_home) then
  513. c              discard entire result
  514.                 result = ' '
  515. c              clear the screen display of the result
  516.                 call place_string_at(ix,y,result)
  517. c              place the cursor
  518.                 x = ix
  519.                 call locate(x,y)
  520.              endif
  521.  
  522.            if(key.eq.key_end) then
  523.              endif
  524.  
  525.            if(key.eq.key_lt_arrow) then
  526. c              move cursor one space to the left (if possible)
  527.                 x = max0(x-1,ix)
  528.                 call locate(x,y)
  529. c              blank this position
  530.                 call write_one_char(iblank)
  531. c              find index of letter at new cursor position
  532.                 j = x - ix + 1
  533. c              set to blank
  534.                 result(j:j) = ' '
  535.              endif
  536.  
  537.            if(key.eq.key_rt_arrow) then
  538. c              move cursor right one position
  539.                 x = min0(x+1,jx)
  540.                 call locate(x,y)
  541.              endif
  542.  
  543.            if(key.eq.key_up_arrow) then
  544.                 go to 86
  545.              endif
  546.  
  547.            if(key.eq.key_dn_arrow) then
  548.                 go to 86
  549.              endif
  550.  
  551.            if(key.eq.key_pgup) then
  552.                call beep()
  553.              endif
  554.  
  555.            if(key.eq.key_pgdn) then
  556.                 call beep()
  557.              endif
  558.  
  559.            if(key.eq.key_end) then
  560.                 call beep()
  561.              endif
  562.  
  563.          endif
  564.  
  565.       go to 5
  566.  
  567.    86 call set_active_attribute(ia)
  568.       return
  569.       end
  570.  
  571.       integer function klen(s)
  572.       character*(*) s
  573.       character blank,nul
  574.       blank = ' '
  575.       nul = char(0)
  576.       j = 1 + len(s)
  577.     1 j = j-1
  578.       if(j.le.0) go to 2
  579.       if(s(j:j).eq.blank.or.s(j:j).eq.nul) go to 1
  580.     2 klen = j
  581.       return
  582.       end
  583.  
  584.  
  585.  
  586.       SUBROUTINE input_date_at(x,y,month,day,year)
  587.  
  588.       INCLUDE "scrval.fh"
  589.  
  590.       CHARACTER*1 screen_char, input_key_at
  591.       INTEGER x, y, month, day, year
  592.       INTEGER key, key1, get_a_key, get_ordinal
  593.       INTEGER char_arg
  594.  
  595.       ix = x
  596.       iy = y
  597.       CALL locate(ix,iy)
  598.  
  599. c    write the initial template
  600.       CALL write_string("(mm-dd-yy)")
  601.  
  602. c    move cursor over '(' to first position
  603.       ix = ix + 1
  604.     5 CALL locate(ix,iy)
  605.  
  606. c    get first number till a 1 or 0 appears
  607.    10 key1 = get_a_key()
  608.       IF (key1 .EQ. key_0) GOTO 20
  609.       IF (key1 .EQ. key_1) GOTO 20
  610.       GO TO 10
  611.  
  612. c    write first character to screen
  613.    20 char_arg = key1
  614.       CALL write_one_char(char_arg)
  615.  
  616. c    move cursor to second position
  617.       ix = ix + 1
  618.  
  619. c    come here from next char backspace
  620.    25 CALL locate(ix,iy)
  621.  
  622. c    get the second character which must be an ordinal
  623. c     that results in 01,02 .. 09,10,11 or 12 only
  624.    30 key2 = get_ordinal()
  625.  
  626. c    first test for backspace and go back if found
  627.       IF (key2 .EQ. key_backspace) THEN
  628.            CALL write_one_char(key_m)
  629.            ix = ix - 1
  630.            GO TO 5
  631.          ENDIF
  632.  
  633. c    test for legal cases 10,11,12
  634.       IF ((key1 .EQ. key_1) .AND. (key2 .LT. key_3)) GOTO 40
  635.       IF  (key1 .EQ. key_1) GOTO 30
  636. c    only key1 = 0 get this far
  637. c    test for legal cases 01 .. 09 by eliminating 00 illegal case
  638.       IF (key2 .EQ. key_0) GOTO 30
  639.  
  640.    40 char_arg = key2
  641.       CALL write_one_char(char_arg)
  642.  
  643. c    skip over next key check
  644.       GOTO 50
  645.  
  646. c-----------------------Now get the day------------------------------
  647.  
  648. c     skip over '/'
  649.    50 ix = ix + 2
  650.    53 CALL locate(ix,iy)
  651.  
  652. c    now get first numeral of month    12/?#/##
  653. c    look for a 0, 1, 2 or 3
  654.  
  655.    55 key3 = get_ordinal()
  656.       IF (key3 .EQ. key_backspace) THEN
  657.            CALL write_one_char(key_d)
  658.            ix = ix -2
  659.            GOTO 25
  660.          ENDIF
  661.       IF (key3 .GT. key_3) GOTO 55
  662.  
  663. c    write it to first location and increment cursor
  664.       char_arg = key3
  665.       CALL write_one_char(char_arg)
  666.       ix = ix + 1
  667.  
  668. c--------------------last half of day--------------------------------
  669.  
  670.    57 CALL locate (ix,iy)
  671.  
  672. c    get next ordinal checking for backspace
  673.    60 key4 = get_ordinal()
  674.       IF (key4 .EQ. key_backspace) THEN
  675.            CALL write_one_char(key_d)
  676.            ix = ix - 1
  677.            GOTO 53
  678.          ENDIF
  679.  
  680. c    The second key must be in the range of 0 .. 9
  681. c    for all cases of key3, except 3, for which it
  682. c    must be either 0 or 1, so reject 32 .. 39
  683.       IF ((key3 .EQ. key_3) .AND. (key4 .GT. key_1)) GOTO 60
  684.  
  685.       char_arg = key4
  686.       CALL write_one_char(char_arg)
  687.  
  688. c---------------------------get the year-----------------------------
  689.  
  690. c    now read the year which can be any value between 00 .. 99
  691.       ix = ix + 2
  692.    65 CALL locate (ix,iy)
  693.  
  694. c    now get first numeral of year 12/34/?#
  695. c    look for a 0 .. 9
  696.  
  697.    70 key5 = get_ordinal()
  698.       IF (key5 .EQ. key_backspace) THEN
  699.            CALL write_one_char(key_y)
  700.            ix = ix -2
  701.            GOTO 57
  702.          ENDIF
  703.  
  704. c    write it to first location and increment cursor
  705.       char_arg = key5
  706.       CALL write_one_char(char_arg)
  707.       ix = ix + 1
  708.  
  709. c------------------------last half of year--------------------------
  710.  
  711.       CALL locate (ix,iy)
  712.  
  713. c    get next ordinal checking for backspace
  714.    75 key6 = get_ordinal()
  715.       IF (key6 .EQ. key_backspace) THEN
  716.            CALL write_one_char(key_y)
  717.            ix = ix - 1
  718.            GOTO 65
  719.          ENDIF
  720.  
  721.    80 char_arg = key6
  722.       CALL write_one_char(char_arg)
  723.  
  724. c    now wait for either a new numeral, backspace or enter
  725.    85 key = get_a_key()
  726.  
  727. c    check for ordinal
  728.       IF ((key .GE. key_0) .AND. (key .LE. key_9)) THEN
  729.            key6 = key
  730.            GOTO 80
  731.          ENDIF
  732.       IF (key .EQ. key_backspace) THEN
  733.            CALL write_one_char(key_y)
  734.            ix = ix - 1
  735.            GOTO 65
  736.          ENDIF
  737.       IF (key .EQ. key_enter) THEN
  738.            month = key2 - key_0 + 10*(key1 - key_0)
  739.            day   = key4 - key_0 + 10*(key3 - key_0)
  740.            year  = key6 - key_0 + 10*(key5 - key_0) + 1900
  741.            GOTO 90
  742.          ENDIF
  743.  
  744. c    if it wasn't a numeral, enter or backspace we poll again
  745.       GOTO 85
  746.  
  747. c       we're done !
  748.    90 CONTINUE
  749.       END
  750.  
  751. c*********************************************************************
  752.  
  753.       INTEGER FUNCTION get_ordinal()
  754.  
  755.       INCLUDE "scrval.fh"
  756.  
  757.       INTEGER key,get_a_key
  758.  
  759.    10 key = get_a_key()
  760.       IF (key .EQ. key_backspace) GOTO 20
  761.       IF (key .LT. key_0) GOTO 10
  762.       IF (key .GT. key_9) GOTO 10
  763.  
  764.    20 get_ordinal = key
  765.  
  766.       END
  767.  
  768. c*********************************************************************
  769.  
  770.       INTEGER FUNCTION get_a_key()
  771.       INTEGER level,ihelp,key
  772.       CHARACTER*40 help_messages(11)
  773.       COMMON level,help_messages(11)
  774.  
  775.       INCLUDE "scrval.fh"
  776.  
  777. c    initialize help flag to 0
  778.       ihelp = 0
  779.  
  780. c    read a key
  781.    10 key = inkey$()
  782.  
  783. c    filter the result of the read
  784.  
  785. c    no character read, so still poll
  786.       IF (key .EQ. key_null) GOTO 10
  787.  
  788. c    check to see if we have a help message printed below
  789. c      and if we do, erase it by calling help with a zero
  790.       IF (ihelp .NE. 0) THEN
  791.            ihelp = 0
  792.            CALL help(ihelp)
  793.          ENDIF
  794.  
  795. c    a control C was hit, so return to DOS
  796.       IF (key .EQ. key_cntrl_c) STOP
  797.  
  798. c    we chose to use the escape as a return to DOS also
  799.       IF (key .EQ. key_esc) STOP
  800.  
  801. c    This is an ideal place for a context-sensitive help
  802. c     function
  803.  
  804.       IF (key .EQ. key_alt_h) THEN
  805.            ihelp = level
  806.            CALL help(ihelp)
  807.            GOTO 10
  808.          ENDIF
  809.  
  810. c    return key code
  811.       get_a_key = key
  812.  
  813.       END
  814.  
  815. c **************************************************************************
  816.       SUBROUTINE help(ihelp)
  817.       INTEGER level,ihelp,iattr1,iattr2
  818.       CHARACTER*40 help_messages(11)
  819.       COMMON level,help_messages(11)
  820.  
  821.       INCLUDE "scrval.fh"
  822.  
  823. c    get the current cursor position
  824.       CALL get_cursor(ix1,iy1)
  825.  
  826. c    get the active attribute to restore it below
  827.       CALL get_active_attribute(iattr1)
  828.  
  829.  
  830. c    if ihelp <> 0 change to reverse bright characters
  831.       IF (ihelp .NE. 0) THEN
  832.            CALL set_active_attribute(ibright)
  833.          ELSE
  834.            CALL set_active_attribute(idim)
  835.          ENDIF
  836.  
  837. c    write the message to the next to the last row of the screen
  838.       CALL place_string_at(10,23,help_messages(ihelp+1))
  839.  
  840. c    restore the attribute
  841.       CALL set_active_attribute(iattr1)
  842.  
  843. c    restore the cursor to the input line
  844.       CALL locate(ix1,iy1)
  845.  
  846.       END
  847. *************************************************************************
  848.       SUBROUTINE messages
  849.       INTEGER level
  850.       CHARACTER*40 help_messages(11)
  851.       COMMON level,help_messages(11)
  852.  
  853. c   set up the help message array in common
  854.  
  855.       help_messages(1 ) = "<Alt-h> for help messages"
  856.       help_messages(2 ) = "Your first name please"
  857.       help_messages(3 ) = "Your middle initial please"
  858.       help_messages(4 ) = "Your last name please"
  859.       help_messages(5 ) = "Enter the name of your favorite magazine"
  860.       help_messages(6 ) = "Enter your street address"
  861.       help_messages(7 ) = "Enter the name of your town"
  862.       help_messages(8 ) = "Enter the state's two letter abreviation"
  863.       help_messages(9 ) = "Enter a 5 digit zip code only"
  864.       help_messages(10) = "Enter your area code and number"
  865.       help_messages(11) = "To go back use up arrow, else hit enter"
  866.  
  867.       END
  868. c************************************************************************
  869.