home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 10 / 10.iso / l / l320 / 2.img / EXAMPLES / FDEMO.F < prev    next >
Encoding:
Text File  |  1989-12-22  |  38.8 KB  |  1,317 lines
  1. c    Program to demonstrate video graphics functions
  2. c      using NDP Fortran-386 graphics extension library
  3. c
  4. c      MicroWay, Inc.
  5. c      P.O. Box 79
  6. c      Kingston, MA 02364
  7. c      (508) 746-7341
  8. c
  9. c    graphic functions must be declared with the appropriate type
  10.       include 'grex.fh'
  11. c
  12. c    all graphics functions return an integer value
  13.       integer ier
  14. c
  15. c    declare type of a function defined in this file
  16.       integer actual_length
  17. c
  18. c    indices for iterations
  19.       integer i,j,k
  20. c
  21. c    video modes (a) suggested by GREX and (b) supplied by user
  22.       integer mode,new_mode
  23. c
  24. c    limits of the current video device
  25.       integer limx,limy,max_color
  26. c
  27. c    clip limits (initially equal to device limits)
  28.       integer xmin,xmax,ymin,ymax
  29. c
  30. c    codes for hardware present in the computer
  31.       integer video_system(4)
  32. c
  33. c    string for writing graphic text to screen
  34.       character*64 string
  35. c
  36. c    print banner to user
  37.       write(6,*)
  38.       write(6,*) 'NDP Fortran-386 Graphics Extension test program'
  39.       write(6,*)
  40.       write(6,*) '    MicroWay, Inc.'
  41.       write(6,*) '    P.O. Box 79'
  42.       write(6,*) '    Kingston, MA 02364'
  43.       write(6,*) '    (508) 746-7341'
  44.       write(6,*)
  45. c
  46. c    While the user enters more video modes
  47. c
  48. c         get information about hardware configuration and suggested mode
  49.            mode = video_configuration(video_system)
  50. c
  51. c         show user the video configuration
  52.     1      write(6,201) ' Video system codes:',(video_system(i),i=1,4)
  53.   201      format(a,4i4)
  54.            write(6,201) ' Suggested graphic mode:',mode
  55. c
  56. c         show hardware configuration in words
  57.            write(6,*)
  58.            write(6,*) 'Available video systems: '
  59.            call show_video_systems
  60. c
  61. c         try whatever mode the user enters
  62.            write(6,*)
  63.     2      write(6,101) ' Enter video mode desired '
  64.            write(6,101) ' (press <Enter> to quit): '
  65.   101      format(a,$)
  66.            read(5,100) string
  67.   100      format(a)
  68.            L = actual_length(string)
  69.            if(L.le.0) go to 86
  70.            read(string,300,err=2) new_mode
  71.   300      format(bn,i8)
  72. c
  73. c         try to enter the requested mode
  74.            if (new_mode.gt.0) ier = graphics_mode(new_mode)
  75.            if (new_mode.eq.0) go to 86
  76.            if (new_mode.lt.0) then
  77.                 write(*,101) ' If other than 800 horizontal pixels, '
  78.                 write(*,101) ' enter horizontal pixel count: '
  79.                 read(5,100) string
  80.                 L = actual_length (string)
  81.                 if (L.le.0) then
  82.                      limx = 800
  83.                    else
  84.                      read(string,300,err=2) limx
  85.                    endif
  86.                 write(*,101) ' If other than 600 vertical pixels, '
  87.                 write(*,101) ' enter vertical pixel count: '
  88.                 read(5,100) string
  89.                 L = actual_length (string)
  90.                 if (L.le.0) then
  91.                      limy = 600
  92.                    else
  93.                      read(string,300,err=2) limy
  94.                    endif
  95.                 new_mode = super_vga(-new_mode,limx,limy)
  96.                 ier = new_mode
  97.               endif
  98. c
  99. c         if unsuccessful, get another mode code from user
  100.            if(ier.eq.0) go to 2
  101. c
  102. c         if successful, get device limits for future use
  103.            ier = get_device_limits(limx,limy,max_color)
  104. c
  105. c         Run tests
  106.            call test1
  107.            call test2
  108.            call test3
  109.            call test4
  110.            call test5
  111.            call test6
  112.            call test7
  113.            call test8
  114.            call test9
  115.            call test10
  116.            call test11
  117.            call test12
  118.            call test13
  119.            call test14
  120.            call test15
  121. c
  122. c         clear the screen
  123.            ier = clear()
  124. c
  125. c         and return to text mode.  Parentheses are not optional here.
  126.            ier = text_mode()
  127. c
  128.       go to 1
  129. c    End-while
  130. c
  131.    86 stop 'Okay.'
  132.       end
  133.  
  134. c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  135.  
  136.       subroutine test1
  137.       include 'grex.fh'
  138.       integer new_mode,limx,limy,max_color
  139.       new_mode = get_device_limits (limx,limy,max_color)
  140. c
  141. c Test 1: setting pixels
  142. c
  143. c    Clear the screen.  Parentheses are not optional.
  144.       ier = clear()
  145. c
  146. c    use color 6 (brown or yellow, depending on contrast setting)
  147.       ier = set_color(6)
  148.  
  149. c    repeatedly set pixels on a diagonal line
  150.       do 10 i=1,51
  151.            j = 100 + i-1
  152.            k = j
  153.            ier = set_pixel(j,k)
  154.    10 continue
  155. c
  156. c    label screen
  157.       ier = graphic_text('Test 1: setting pixels',10,limy-20,14)
  158. c
  159. c    prompt the user for a key
  160.       ier = graphic_text('Press a key to continue',10,limy-10,14)
  161. c
  162. c    wait for a keystroke from user
  163.       ier = pause()
  164. c
  165.       return
  166.       end
  167.  
  168. c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  169.  
  170.       subroutine test2
  171.       include 'grex.fh'
  172.       integer limx,limy,max_color
  173.       new_mode = get_device_limits (limx,limy,max_color)
  174. c
  175. c Test 2: drawing lines
  176. c
  177. c    use color 1 (blue)
  178.       ier = set_color(1)
  179. c
  180. c    draw a box
  181.       ier = move(100,100)
  182.       ier = draw(150,100)
  183.       ier = draw(150,150)
  184.       ier = draw(100,150)
  185.       ier = draw(100,100)
  186. c
  187. c    double the box border
  188.       ier = move(101,101)
  189.       ier = draw(149,101)
  190.       ier = draw(149,149)
  191.       ier = draw(101,149)
  192.       ier = draw(101,101)
  193. c
  194. c    use color 4 (red)
  195.       ier = set_color(4)
  196. c
  197. c    draw a box around the blue box
  198.       ier = move( 99, 99)
  199.       ier = draw(151, 99)
  200.       ier = draw(151,151)
  201.       ier = draw( 99,151)
  202.       ier = draw( 99, 99)
  203. c
  204. c    double this box's border also
  205.       ier = move( 98, 98)
  206.       ier = draw(152, 98)
  207.       ier = draw(152,152)
  208.       ier = draw( 98,152)
  209.       ier = draw( 98, 98)
  210. c
  211. c    clear text
  212.       ier = set_color(0)
  213.       ier = filled_rectangle(0,limy-20,limx,limy)
  214. c
  215. c    label screen
  216.       ier = graphic_text('Test 2: drawing lines',10,limy-20,14)
  217. c
  218. c    prompt the user for a key
  219.       ier = graphic_text('Press a key to continue',10,limy-10,14)
  220. c
  221. c    get another keystroke from the user
  222.       ier = pause()
  223. c
  224.       return
  225.       end
  226.  
  227. c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  228.  
  229.       subroutine test3
  230.       include 'grex.fh'
  231.       integer ix,iy,ih,iv,ier
  232.       integer new_mode,limx,limy,max_color
  233.       new_mode = get_device_limits (limx,limy,max_color)
  234. c
  235. c Test 3: circles
  236. c
  237. c    calculate parameters of a circle
  238.       ix = 240
  239.       iy = 100
  240.       ih = 30 * aspect_ratio(new_mode)/100
  241.       iv = 30
  242. c
  243. c    use color 2 (green)
  244.       ier = set_color(2)
  245. c
  246. c    draw a circle
  247.       ier = open_ellipse(ix,iy,ih,iv)
  248. c
  249. c    draw a filled circle nearby
  250.       ix = ix + 2*ih
  251.       iy = iy + iv
  252.       ier = filled_ellipse (ix,iy,ih,iv)
  253. c
  254. c    clear text
  255.       ier = set_color(0)
  256.       ier = filled_rectangle(0,limy-20,limx,limy)
  257. c
  258. c    label screen
  259.       ier = graphic_text('Test 3: circles',10,limy-20,14)
  260. c
  261. c    prompt the user for a key
  262.       ier = graphic_text('Press a key to continue',10,limy-10,14)
  263. c
  264. c    get a key from the user
  265.       ier = pause()
  266. c
  267.       return
  268.       end
  269.  
  270. c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  271.  
  272.       subroutine test4
  273.       include 'grex.fh'
  274.       integer new_mode,limx,limy,max_color
  275.       character buffer (4096)
  276.       character text_buffer (4096)
  277.       integer ix,iy,jx,jy,ier
  278.       character*64 string
  279.       integer L,actual_length
  280.  
  281.       new_mode = get_device_limits (limx,limy,max_color)
  282. c
  283. c Test 4: saving and restoring windows
  284. c
  285. c    clear text
  286.       ier = set_color(0)
  287.       ier = filled_rectangle(0,limy-30,limx,limy)
  288. c
  289. c    label screen
  290.       string = 'Test 4: Saving and restoring windows'
  291.       ier = graphic_text(string,10,limy-30,14)
  292. c
  293. c    copy the box to the left of it
  294.       ier = save_window(98,98,152,152,buffer)
  295.       ier = restore_window(38,98,92,152,buffer)
  296. c
  297. c    get a key from the user
  298.       ier = pause()
  299. c
  300. c    save a window in the middle of these boxes
  301.       string = 'Saved window; press a key to restore'
  302.       L = actual_length(string)
  303.       ix = 19
  304.       iy = 120
  305.       jx = 25+8*L
  306.       jy = 131
  307.       ier = save_window(ix,iy,jx,jy,buffer)
  308.       ier = set_color(0)
  309.       ier = filled_rectangle(ix,iy,jx,jy)
  310.       ier = set_color(11)
  311.       ier = move(ix,iy)
  312.       ier = draw(jx,iy)
  313.       ier = draw(jx,jy)
  314.       ier = draw(ix,jy)
  315.       ier = draw(ix,iy)
  316.       ier = graphic_text(string,ix+5,iy+2,11)
  317.       ier = pause()
  318.       ier = restore_window(ix,iy,jx,jy,buffer)
  319.  
  320.       string = 'Move window using arrow keys'
  321.       ier = graphic_text (string, 10, limy-20, 14)
  322.       string = 'Press <Enter> to begin the next test'
  323.       ier = graphic_text (string, 10, limy-10, 14)
  324.  
  325.       string = 'Text window'
  326.       L = actual_length (string)
  327.       ix = 16
  328.       iy = 120
  329.       jx = 25+8*L
  330.       jy = 131
  331.       ier = save_window (ix, iy, jx, jy, buffer)
  332.       ier = set_color (0)
  333.       ier = filled_rectangle (ix, iy, jx, jy)
  334.       ier = set_color (11)
  335.       ier = move (ix,iy)
  336.       ier = draw (jx,iy)
  337.       ier = draw (jx,jy)
  338.       ier = draw (ix,jy)
  339.       ier = draw (ix,iy)
  340.       ier = graphic_text (string, ix+5, iy+2, 11)
  341. c
  342. c    keep the text window in a buffer
  343.       ier = save_window (ix, iy, jx, jy, text_buffer)
  344.  
  345.    20 key = pause()
  346.       if (key.ne.13) then
  347. c
  348. c         restore the previous screen
  349.            ier = restore_window (ix, iy, jx, jy, buffer)
  350. c
  351. c         adjust coordinates according to the key
  352.            if (key.eq.-71) then
  353.                 ix = ix - 8
  354.                 iy = iy - 2
  355.                 jx = jx - 8
  356.                 jy = jy - 2
  357.               endif
  358.            if (key.eq.-72) then
  359.                 iy = iy - 2
  360.                 jy = jy - 2
  361.               endif
  362.            if (key.eq.-73) then
  363.                 ix = ix + 8
  364.                 iy = iy - 2
  365.                 jx = jx + 8
  366.                 jy = jy - 2
  367.               endif
  368.            if (key.eq.-75) then
  369.                 ix = ix - 8
  370.                 jx = jx - 8
  371.               endif
  372.            if (key.eq.-77) then
  373.                 ix = ix + 8
  374.                 jx = jx + 8
  375.               endif
  376.            if (key.eq.-79) then
  377.                 ix = ix - 8
  378.                 iy = iy + 2
  379.                 jx = jx - 8
  380.                 jy = jy + 2
  381.               endif
  382.            if (key.eq.-80) then
  383.                 iy = iy + 2
  384.                 jy = jy + 2
  385.               endif
  386.            if (key.eq.-81) then
  387.                 ix = ix + 8
  388.                 iy = iy + 2
  389.                 jx = jx + 8
  390.                 jy = jy + 2
  391.               endif
  392. c
  393. c         don't let the text window go off the screen
  394.            if (ix.lt.0) then
  395.                 ix = ix + 8
  396.                 jx = jx + 8
  397.               endif
  398.            if (iy.lt.0) then
  399.                 iy = iy + 2
  400.                 jy = jy + 2
  401.               endif
  402.            if (jx.gt.limx) then
  403.                 ix = ix - 8
  404.                 jx = jx - 8
  405.               endif
  406.            if (jy.gt.limy) then
  407.                 iy = iy - 2
  408.                 jy = jy - 2
  409.               endif
  410. c
  411. c         save the screen region and emplace the text window
  412.            ier = save_window (ix, iy, jx, jy, buffer)
  413.            ier = restore_window (ix, iy, jx, jy, text_buffer)
  414.  
  415.            go to 20
  416.          endif
  417.  
  418.       ier = restore_window (ix, iy, jx, jy, buffer)
  419.       return
  420.       end
  421.  
  422. c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  423.  
  424.       subroutine test5
  425.       include 'grex.fh'
  426.       integer i,j,ix,iy,ier
  427.       integer new_mode,limx,limy,max_color
  428.       character q,crawl
  429.       character*64 string
  430.       new_mode = get_device_limits (limx,limy,max_color)
  431. c
  432. c Test 5: cursor movement and region fill
  433. c
  434. c    erase the previous prompt using a black bar
  435.       call set_color(0)
  436.       call filled_rectangle(10,limy-30,limx,limy)
  437. c
  438. c    put up a new prompt
  439.       string = 'Test 5: cursor movement and region fill'
  440.       ier = graphic_text(string,10,limy-30,14)
  441.       string = 'Move cursor using arrow keys'
  442.       ier = graphic_text(string,10,limy-20,14)
  443.       string = 'Press R to fill red, G = green, B = blue'
  444.       ier = graphic_text(string,10,limy-10,14)
  445. c
  446. c    start the cursor in the center of the open green circle
  447.       ix = 240
  448.       iy = 100
  449.       i = ix
  450.       j = iy
  451. c
  452. c    allow the user to move the cursor around with the keyboard.
  453. c      arrow keys move one step in the indicated direction
  454. c      <Home>, <End>, <PgUp>, and <PgDn> move one step in each of two directions
  455. c      <Ins> increases the size of the step by one pixel (up to 100 pixels)
  456. c      <Del> decreases the size of the step by one pixel (down to 1 pixel)
  457. c     return control here when user presses a key with an ASCII code
  458.    35 q = crawl(i,j)
  459. c
  460. c    if the key was 'r', then begin a red fill at the cursor position
  461.       if(q.eq.'r'.or.q.eq.'R') then
  462.            ier = flood_fill(i,j,4,4)
  463.            go to 35
  464.          endif
  465. c
  466. c    if the key was 'g' then begin a green fill at the cursor position
  467.       if(q.eq.'g'.or.q.eq.'G') then
  468.            ier = flood_fill(i,j,2,2)
  469.            go to 35
  470.          endif
  471. c
  472. c    if the key was 'b' then begin a blue fill at the cursor position
  473.       if(q.eq.'b'.or.q.eq.'B') then
  474.            ier = flood_fill(i,j,1,1)
  475.            go to 35
  476.          endif
  477. c
  478.       return
  479.       end
  480.  
  481. c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  482.  
  483.       subroutine test6
  484.       include 'grex.fh'
  485.       integer ier,i,j
  486.       integer xmin,ymin,xmax,ymax
  487.       integer new_mode,limx,limy,max_color
  488.       character q,crawl
  489.       character*64 string
  490.       new_mode = get_device_limits (limx,limy,max_color)
  491. c
  492. c Test 6: cursor movement in a clipping window
  493. c
  494. c    erase the previous prompt
  495.       ier = set_color(0)
  496.       ier = filled_rectangle(10,limy-30,limx,limy)
  497.  
  498. c    label the next display
  499.       string = 'Test 6: Clipping window (Quarter-screen, centered)'
  500.       ier = graphic_text(string,10,limy-30,14)
  501.       string = 'Move cursor using arrow keys'
  502.       ier = graphic_text(string,10,limy-20,14)
  503.       string = 'Press any key to continue'
  504.       ier = graphic_text(string,10,limy-10,14)
  505. c
  506. c    clip outside a window one fourth the size of the screen
  507. c      centered in the middle
  508.       ier = set_clip_limits(limx/4,limy/4,3*limx/4,3*limy/4)
  509. c
  510. c    put the cursor in the middle of the clip window
  511.       ier = get_clip_limits(xmin,ymin,xmax,ymax)
  512.       i = (xmin + xmax)/2
  513.       j = (ymin + ymax)/2
  514. c
  515. c    and move the cursor until an ASCII key is hit
  516.       q = crawl(i,j)
  517. c
  518. c    to deactivate clipping, set the clip limits to current device limits
  519.       ier = get_device_limits(limx,limy,max_color)
  520.       ier = set_clip_limits(0,0,limx,limy)
  521. c
  522.       return
  523.       end
  524.  
  525. c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  526.  
  527.       subroutine test7
  528.       include 'grex.fh'
  529.       integer i,j,k,ier
  530.       integer xmin,ymin,xmax,ymax
  531.       integer new_mode,limx,limy,max_color
  532.       new_mode = get_device_limits (limx,limy,max_color)
  533. c
  534. c Test 7: available colors
  535. c
  536. c    show the user all of the colors supported in this mode
  537. c      do this by drawing a vertical bar of each color
  538.       ier = get_clip_limits(xmin,ymin,xmax,ymax)
  539.       k = xmin
  540.       do 40 i=1,max_color+1
  541.            ier = set_color(i-1)
  542.            j = k+1
  543.            k = j + xmax/(max_color+1)
  544.            ier = filled_rectangle(j,ymin,k,ymax)
  545.    40 continue
  546. c
  547. c    label the screen
  548.       ier = graphic_text('Test 7: Available colors',10,limy-10,15)
  549. c
  550. c    and wait for keyboard input
  551.       ier = pause()
  552. c
  553.       return
  554.       end
  555.  
  556. c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  557.  
  558.       subroutine test8
  559.       include 'grex.fh'
  560.       integer new_mode,limx,limy,max_color
  561.       new_mode = get_device_limits (limx,limy,max_color)
  562. c
  563. c Test 8: Line clipping
  564. c
  565. c    clear the screen
  566.       ier = clear()
  567. c
  568. c    demonstrate line clipping
  569. c      using color 12 (bright red)
  570.       ier = set_color(12)
  571.       ier = move(-100,-100)
  572.       ier = draw( 800, 100)
  573.       ier = draw( 300, 500)
  574.       ier = draw(-100, 200)
  575. c
  576. c    label the screen
  577.       ier = graphic_text('Test 8: Clipped lines',10,limy-10,9)
  578. c
  579. c    wait for keyboard input
  580.       ier = pause()
  581. c
  582.       return
  583.       end
  584.  
  585. c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  586.  
  587.       subroutine test9
  588.       include 'grex.fh'
  589.       integer new_mode,limx,limy,max_color
  590.       integer ier,ix,iy,jx,jy,ih,iv
  591.       character*64 string
  592.       new_mode = get_device_limits (limx,limy,max_color)
  593. c
  594. c Test 9: Graphic pages
  595. c
  596. c    show this test only in EGA modes 14,15,16, and HGC mode
  597.       if(graphic_page_count().gt.1) then
  598. c
  599. c         write something on page 0
  600.            ier = set_active_page(0)
  601.            ier = clear()
  602.            call graphic_text('Test 9: Graphic pages',10,limy-30,14)
  603.            ier = graphic_text('Page Zero',10,limy-20,10)
  604.            string = 'Press 1 to see page one, <Enter> to continue'
  605.            ier = graphic_text(string,10,limy-10,14)
  606.            ier = set_color(4)
  607.            ix = limx/2
  608.            iy = limy/2
  609.            iv = limy/4
  610.            ih = iv * aspect_ratio(new_mode)/100
  611.            ier = filled_ellipse(ix,iy,ih,iv)
  612. c
  613. c         write something else on page 1
  614.            ier = set_active_page(1)
  615.            if(ier.gt.0) ier = clear()
  616.            call graphic_text('Test 9: Graphic pages',10,limy-30,14)
  617.            ier = graphic_text('Page One',100,limy-20,12)
  618.            string = 'Press 0 to see page zero, <Enter> to continue'
  619.            ier = graphic_text(string,10,limy-10,14)
  620.            ier = set_color(1)
  621.            ix = limx/4
  622.            iy = limy/4
  623.            jx = 3*ix
  624.            jy = 3*iy
  625.            ier = filled_rectangle(ix,iy,jx,jy)
  626. c
  627. c         toggle back and forth between pages until return is hit
  628.    50      ier = pause()
  629.            if(ier.ne.13) then
  630.                 ier = set_display_page(ier)
  631.                 go to 50
  632.               else
  633.                 ier = set_active_page(0)
  634.                 ier = set_display_page(0)
  635.               endif
  636.  
  637.          else
  638.  
  639. c         inform user that only one graphic page is available in this mode
  640.            ier = clear()
  641.            string = 'Test 9: Graphic pages'
  642.            ier = graphic_text(string,10,limy-30,14)
  643.            string = 'Only one page is available in this mode'
  644.            ier = graphic_text(string,10,limy-20,14)
  645.            string = 'Press a key to continue'
  646.            ier = graphic_text(string,10,limy-10,14)
  647.            ier = pause()
  648.  
  649.          endif
  650. c
  651.       return
  652.       end
  653.  
  654. c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  655.  
  656.       subroutine test10
  657.       include 'grex.fh'
  658.       integer new_mode,limx,limy,max_color
  659.       character*64 string
  660.       new_mode = get_device_limits (limx,limy,max_color)
  661. c
  662. c Test 10: graphic text
  663. c
  664. c    clear screen
  665.       ier = clear()
  666. c
  667. c    label screen
  668.       string = 'Test 10: Graphic text'
  669.       ier = graphic_text(string,10,limy-30,14)
  670.       string = 'Use <Backspace> to fix mistakes'
  671.       ier = graphic_text(string,10,limy-20,14)
  672.       string = 'Press <Enter> to continue.'
  673.       ier = graphic_text(string,10,limy-10,14)
  674. c
  675. c    show how to do character I/O in graphics modes:
  676. c      prompt the user and get some input
  677.       call get_string(0,0,'Please enter your name:',string)
  678. c      echo user's input
  679.       call graphic_text(string,0,10,12)
  680. c
  681. c    wait for keyboard input
  682.       ier = pause()
  683. c
  684.       return
  685.       end
  686.  
  687. c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  688.  
  689.       subroutine test11
  690.       include 'grex.fh'
  691.       integer ix,iy,jx,jy,ier
  692.       integer new_mode,limx,limy,max_color
  693.       character*64 string
  694.       new_mode = get_device_limits (limx,limy,max_color)
  695. c
  696. c Test 11: XOR functions
  697.  
  698. c    clear the screen
  699.       ier = clear()
  700.  
  701. c    Label the screen
  702.       string = 'Test 11: XOR functions'
  703.       ier = graphic_text(string,10,limy-20,14)
  704.       string = 'Press any key to continue'
  705.       ier = graphic_text(string,10,limy-10,14)
  706.  
  707. c    set up a few coordinates
  708.       ix = 0
  709.       iy = 0
  710.       jx = limx/2
  711.       jy = limy/2
  712.  
  713. c    draw a bar on the screen
  714.       ier = set_color(1)
  715.       ier = filled_rectangle(ix,iy,jx,jy)
  716.  
  717.       ier = pause()
  718.  
  719. c    change coordinates
  720.       ix = limx/4
  721.       iy = limy/4
  722.       jx = 3*ix
  723.       jy = 3*iy
  724.  
  725. c    now draw another bar, overlapping the first, but XOR them.
  726.       ier = set_color(2)
  727.       ier = set_xor(1)
  728.       ier = filled_rectangle(ix,iy,jx,jy)
  729.       ier = set_xor(0)
  730.  
  731.       ier = pause()
  732.  
  733. c    Try the same operation with a line
  734.       ix = 0
  735.       iy = 0
  736.  
  737.       ier = set_color(4)
  738.       ier = set_xor(1)
  739.       ier = move(ix,iy)
  740.       ier = draw(jx,jy)
  741.       ier = set_xor(0)
  742.  
  743.       ier = pause()
  744.  
  745. c    Try writing some text in XOR mode also.
  746.       ix = limx/4 - 40
  747.       iy = limy/2 - 8
  748.  
  749.       ier = set_xor(1)
  750.       string = 'MicroWay GREX library supports XOR'
  751.       ier = graphic_text(string,ix,iy,15)
  752.       ier = set_xor(0)
  753.  
  754. c    Get a key from the user before going on
  755.       ier = pause()
  756. c
  757.       return
  758.       end
  759.  
  760. c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  761.  
  762.       subroutine test12
  763.       include 'grex.fh'
  764.       integer ix,iy,jx,jy,ier
  765.       integer new_mode,limx,limy,max_color
  766.       character*64 string
  767.       new_mode = get_device_limits (limx,limy,max_color)
  768. c
  769. c Test 12: Vertical text
  770.  
  771. c    clear the screen
  772.       ier = clear()
  773. c
  774. c    Write vertical text
  775.       ix = limx/8
  776.       iy = 7 * limy/8
  777.  
  778.       string = 'MicroWay GREX'
  779.       ier = vertical_text(string,ix,iy,12)
  780.       string = 'does vertical text'
  781.       ier = vertical_text(string,ix+10,iy,12)
  782.  
  783. c    Label the screen
  784.       string = 'Test 12: Vertical text and magnification'
  785.       ier = graphic_text(string,10,limy-20,14)
  786.       string = 'Press any key to continue'
  787.       ier = graphic_text(string,10,limy-10,14)
  788.  
  789.       call magnify_text (1,1)
  790.       ix = 10
  791.       iy = limy/4
  792.       call graphic_text ('Normal graphic text',ix,iy,7)
  793.       call magnify_text (2,1)
  794.       iy = iy + 20
  795.       call graphic_text ('Double-width graphic text',ix,iy,14)
  796.       call graphic_text ('Double-width graphic text',ix+1,iy,14)
  797.       call magnify_text (1,2)
  798.       iy = iy + 20
  799.       call graphic_text ('Double-height graphic text',ix,iy,14)
  800.       call graphic_text ('Double-height graphic text',ix,iy+1,14)
  801.       call magnify_text (2,2)
  802.       iy = iy + 20
  803.       call graphic_text ('Double-size graphic text',ix  ,iy  ,14)
  804.       call graphic_text ('Double-size graphic text',ix+1,iy  ,14)
  805.       call graphic_text ('Double-size graphic text',ix  ,iy+1,14)
  806.       call graphic_text ('Double-size graphic text',ix+1,iy+1,14)
  807.       iy = iy + 20
  808.       call graphic_text ('Double-size graphic text',ix  ,iy  ,14)
  809.  
  810.       call magnify_text (1,1)
  811.       ix = 2*limx/3
  812.       iy = limy-10
  813.       call vertical_text ('Normal vertical text',ix,iy,7)
  814.       call magnify_text (2,1)
  815.       ix = ix + 20
  816.       call vertical_text ('Double-width vertical text',ix,iy  ,14)
  817.       call vertical_text ('Double-width vertical text',ix,iy+1,14)
  818.       call magnify_text (1,2)
  819.       ix = ix + 20
  820.       call vertical_text ('Double-height vertical text',ix  ,iy,14)
  821.       call vertical_text ('Double-height vertical text',ix+1,iy,14)
  822.       call magnify_text (2,2)
  823.       ix = ix + 20
  824.       call vertical_text ('Double-size vertical text',ix  ,iy  ,14)
  825.       call vertical_text ('Double-size vertical text',ix+1,iy  ,14)
  826.       call vertical_text ('Double-size vertical text',ix  ,iy+1,14)
  827.       call vertical_text ('Double-size vertical text',ix+1,iy+1,14)
  828.       ix = ix + 20
  829.       call vertical_text ('Double-size vertical text',ix  ,iy  ,14)
  830.       call magnify_text(1,1)
  831.  
  832. c    Get a key from user before going on
  833.       ier = pause()
  834. c
  835.       return
  836.       end
  837.  
  838. c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  839.  
  840.       subroutine test13
  841.       include 'grex.fh'
  842.       integer i,ix,iy,jx,jy
  843.       integer new_mode,limx,limy,max_color
  844.       character*64 string
  845.  
  846. c    dash patterns are 32-bit unsigned integers
  847.       character*4 dash_pattern(16)
  848.  
  849.       new_mode = get_device_limits (limx,limy,max_color)
  850.  
  851.     dash_pattern( 1) = char(z'FF')//char(z'FF')//char(z'FF')//char(z'FF')
  852.     dash_pattern( 2) = char(z'00')//char(z'FF')//char(z'FF')//char(z'FF')
  853.     dash_pattern( 3) = char(z'00')//char(z'00')//char(z'FF')//char(z'FF')
  854.     dash_pattern( 4) = char(z'00')//char(z'00')//char(z'00')//char(z'FF')
  855.     dash_pattern( 5) = char(z'F0')//char(z'F0')//char(z'F0')//char(z'F0')
  856.     dash_pattern( 6) = char(z'0F')//char(z'0F')//char(z'0F')//char(z'0F')
  857.     dash_pattern( 7) = char(z'FF')//char(z'00')//char(z'FF')//char(z'00')
  858.     dash_pattern( 8) = char(z'00')//char(z'FF')//char(z'00')//char(z'FF')
  859.     dash_pattern( 9) = char(z'F0')//char(z'0F')//char(z'F0')//char(z'0F')
  860.     dash_pattern(10) = char(z'F6')//char(z'F6')//char(z'F6')//char(z'F6')
  861.     dash_pattern(11) = char(z'11')//char(z'11')//char(z'11')//char(z'11')
  862.     dash_pattern(12) = char(z'33')//char(z'33')//char(z'33')//char(z'33')
  863.     dash_pattern(13) = char(z'55')//char(z'55')//char(z'55')//char(z'55')
  864.     dash_pattern(14) = char(z'77')//char(z'77')//char(z'77')//char(z'77')
  865.     dash_pattern(15) = char(z'99')//char(z'99')//char(z'99')//char(z'99')
  866.     dash_pattern(16) = char(z'AA')//char(z'AA')//char(z'AA')//char(z'AA')
  867. c
  868. c Test 13: dashed lines
  869.  
  870. c    erase previous screen
  871.       ier = clear()
  872.  
  873. c    Label the screen
  874.       string = 'Test 13: dashed lines'
  875.       ier = graphic_text(string,10,limy-20,14)
  876.       string = 'Press any key to begin next test'
  877.       ier = graphic_text(string,10,limy-10,14)
  878.  
  879.       ix = 0
  880.       iy = 0
  881.  
  882.       DO i=1,16
  883.            call move (ix,iy)
  884.            call set_color (i)
  885.            call set_dash (dash_pattern(i))
  886.            jx = limx
  887.            jy = i*limy/8
  888.            call draw (jx,jy)
  889.       EndDO
  890.  
  891.       call set_dash (-1)
  892.  
  893. c    Get a key from user before going on
  894.       ier = pause()
  895. c
  896.       return
  897.       end
  898.  
  899. c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  900.  
  901.       subroutine test14
  902.       include 'grex.fh'
  903.       integer ier,ix,iy,jx,jy,key,j
  904.       integer new_mode,limx,limy,max_color
  905.       character*64 string
  906.       new_mode = get_device_limits (limx,limy,max_color)
  907. c
  908. c Test 14: define_color
  909.  
  910. c    erase previous screen
  911.       ier = clear()
  912.  
  913. c    Label the screen
  914.       string = 'Test 14: define_color function'
  915.       ier = graphic_text(string,10,limy-20,14)
  916.       string = 'Press <Esc> to begin next test'
  917.       ier = graphic_text(string,10,limy-10,14)
  918.  
  919.       if(new_mode.eq.64.or.max_color.gt.15) then
  920.            ier = set_color(0)
  921.            ier = filled_rectangle(10,limy-10,limx,limy)
  922.            string = 'Not supported in this mode'
  923.            ier = graphic_text(string,10,limy-10,14)
  924.            ier = pause()
  925.            go to 66
  926.          endif
  927.  
  928. c    Draw a bar in the center of the screen in color 1
  929.       ix = limx/4
  930.       iy = limy/4
  931.       jx = 3 * ix
  932.       jy = 3 * iy
  933.  
  934.       call set_color(1)
  935.       call filled_rectangle(ix,iy,jx,jy)
  936.  
  937. c    Prompt user to enter a new value for color 1
  938.       iy = jy+3
  939.       call graphic_text('Enter new color code: ',ix,iy,15)
  940.    60 ix = limx/4 + 23 * 8
  941.  
  942. c    Get a number from user.  Allow user to backspace.
  943. c      Ignore non-numbers.
  944.       j = 0
  945.       string = ' '
  946.    65 key = pause()
  947.       if(key.eq.27) go to 66
  948.            if(key.ne.13.and.key.ne.10) then
  949.            if(key.eq.8) then
  950.                 if(j.gt.0) then
  951.                      ix = ix - 8
  952.                      call set_xor(1)
  953.                      call graphic_text(string(j:j),ix,iy,12)
  954.                      call set_xor(0)
  955.                      string(j:j) = ' '
  956.                      j = j-1
  957.                    endif
  958.               else
  959.                 if(key.ge.48.and.key.le.57) then
  960.                      if(j.lt.8) then
  961.                           j = j+1
  962.                           string(j:j) = char(key)
  963.                           call graphic_text(string(j:j),ix,iy,12)
  964.                           ix = ix+8
  965.                         endif
  966.                    endif
  967.               endif
  968.            go to 65
  969.          else
  970. c         read the number that was entered
  971.            read(string,303) new_color
  972.   303      format(BN,I8)
  973. c         change color 1 to the new value
  974.            ier = define_color(1,new_color)
  975. c         erase the number that was entered
  976.            ix = limx/4 + 23 * 8
  977.            call set_xor(1)
  978.            call graphic_text(string,ix,iy,12)
  979.            call set_xor(0)
  980.            string = ' '
  981.            j = 0
  982.            go to 65
  983.          endif
  984.  
  985.    66 continue
  986. c
  987.       return
  988.       end
  989.  
  990. c- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  991.  
  992.       subroutine test15
  993.       include 'grex.fh'
  994.       integer ier,key,i,j,k
  995.       integer ix,iy,jx,jy
  996.       integer new_mode,limx,limy,max_color
  997.       character*64 string
  998.       integer L,actual_length
  999.       integer new_color
  1000.       integer ip(17)
  1001.       character pal(17)
  1002.       new_mode = get_device_limits (limx,limy,max_color)
  1003. c
  1004. c Test 15: set_palette function
  1005.  
  1006. c    clear screen
  1007.       ier = clear()
  1008.  
  1009. c    this test is not relevant to HGC and MCGA users
  1010.       if(new_mode.eq.64.or.max_color.gt.15) then
  1011.            string = 'set_palette not supported in this mode.'
  1012.            ier = graphic_text(string,10,limy-10,14)
  1013.            ier = pause()
  1014.            go to 75
  1015.          endif
  1016.  
  1017. c    draw a bunch of bars on the screen
  1018.    70 ix = limx/5
  1019.       iy = limy/5
  1020.       jx = 4 * ix
  1021.       jy = 4 * iy - 10
  1022.  
  1023. c    make each bar a different color
  1024.       k = ix
  1025.       do 71 i=1,max_color+1
  1026.            ier = set_color(i-1)
  1027.            j = k+1
  1028.            k = j + (jx-ix)/(max_color+1)
  1029.            ier = filled_rectangle(j,iy,k,jy)
  1030.    71 continue
  1031.  
  1032. c    Put palette numbers on left margin
  1033.       ix = 10
  1034.       do 72 i=1,17
  1035.            ip(i) = 0
  1036.            iy = 10 * i
  1037.            write(string,304) i-1
  1038.   304      format(i2)
  1039.            call graphic_text(string(1:2),ix,iy,11)
  1040.    72 continue
  1041.  
  1042. c    Let the user know what to do
  1043.       ier = set_xor(1)
  1044.       string = 'Test 15: set_palette function'
  1045.       ier = graphic_text (string,60,limy-50,14)
  1046.       string = 'Select a new color value for each palette register.'
  1047.       ier = graphic_text (string,60,limy-40,14)
  1048.       string = 'Use <Backspace> to fix errors, press <Enter> to move'
  1049.       ier = graphic_text (string,60,limy-30,14)
  1050.       L = actual_length(string)
  1051.       string = ' to next value.'
  1052.       ier = graphic_text (string,60+8*L,limy-30,14)
  1053.       string = 'The new palette will be set after you finish the list.'
  1054.       ier = graphic_text (string,60,limy-20,14)
  1055.       string = '>> Press <Esc> to move on to next test'
  1056.       ier = graphic_text (string,60,limy-10,14)
  1057.       ier = set_xor(0)
  1058.  
  1059. c    set (ix,iy) to write text next to the top number (0).
  1060.       i = 1
  1061.       iy = 10
  1062.    73 ix = 35
  1063.       ier = set_xor(1)
  1064.       ier = graphic_text (char(16),0,iy,12)
  1065.       ier = set_xor(0)
  1066.  
  1067. c    Get a number from the user.  Allow backspacing over mistakes.
  1068. c    Ignore letters and spaces.
  1069.       j = 0
  1070.       string = ' '
  1071.    74 key = pause()
  1072.       if(key.eq.27) go to 75
  1073.       if(key.ne.13.and.key.ne.10) then
  1074.            if(key.eq.8) then
  1075.                 if(j.gt.0) then
  1076.                      ix = ix - 8
  1077.                      call set_xor(1)
  1078.                      call graphic_text(string(j:j),ix,iy,12)
  1079.                      call set_xor(0)
  1080.                      string(j:j) = ' '
  1081.                      j = j-1
  1082.                    endif
  1083.               else
  1084.                 if(key.ge.48.and.key.le.57) then
  1085.                      if(j.lt.8) then
  1086.                           j = j+1
  1087.                           string(j:j) = char(key)
  1088.                           call graphic_text(string(j:j),ix,iy,12)
  1089.                           ix = ix+8
  1090.                         endif
  1091.                    endif
  1092.               endif
  1093.            go to 74
  1094.          else
  1095. c         read the number
  1096.            read(string,301) new_color
  1097.   301      format(BN,I8)
  1098. c         set the array element corresponding to this color
  1099.            pal(i) = char(new_color)
  1100.            iy = iy + 10
  1101.            i = i+1
  1102. c         if  seventeen numbers have been entered, use them to set palette
  1103.            if(i.gt.17) then
  1104.                 ier = set_palette(pal)
  1105.                 key = pause()
  1106.                 if(key.eq.27) go to 75
  1107.                 call clear()
  1108.                 go to 70
  1109.               endif
  1110.            ier = set_xor(1)
  1111.            ier = graphic_text (char(16),0,iy-10,12)
  1112.            ier = set_xor(0)
  1113.            go to 73
  1114.          endif
  1115.  
  1116.    75 continue
  1117. c
  1118.       return
  1119.       end
  1120.  
  1121. C-------------------------------------------------------------------------
  1122.  
  1123.       integer function actual_length (s)
  1124.       character*(*) s
  1125.       j = 1 + len(s)
  1126.     1 j = j-1
  1127.       if(j.le.0) go to 2
  1128.       if(s(j:j).eq.' ') go to 1
  1129.     2 actual_length = j
  1130.       return
  1131.       end
  1132.  
  1133. C-------------------------------------------------------------------------
  1134.  
  1135.       subroutine show_video_systems
  1136.       integer video_system(4),video_configuration,mode,card,crt
  1137.  
  1138.       mode = video_configuration(video_system)
  1139.  
  1140.       card = video_system(1)
  1141.       crt = video_system(2)
  1142.  
  1143.       if(card.eq.0) then
  1144.            write(6,*) ' No video adapter present'
  1145.            go to 86
  1146.          endif
  1147.  
  1148.       write(6,101) ' Active: '
  1149.  
  1150.       if(card.eq. 1) write(6,101) 'MDA: Monochrome Display Adapter'
  1151.       if(card.eq. 2) write(6,101) 'CGA: Color Graphics Adapter'
  1152.       if(card.eq. 3) write(6,101) 'EGA: Enhanced Graphics Adapter'
  1153.       if(card.eq. 4) write(6,101) 'MCGA: Multi Color Gate Array'
  1154.       if(card.eq. 5) write(6,101) 'VGA: Video Graphics Array'
  1155.       if(card.eq.64) write(6,101) 'HGC: Hercules Graphics Card'
  1156.   101 format(1x,a,$)
  1157.       if(crt.eq.1) write(6,*) ' with MDA-compatible monochrome display'
  1158.       if(crt.eq.2) write(6,*) ' with CGA-compatible color display'
  1159.       if(crt.eq.3) write(6,*) ' with EGA-compatible color display'
  1160.       if(crt.eq.4) write(6,*) ' with PS/2-compatible monochrome display'
  1161.       if(crt.eq.5) write(6,*) ' with PS/2-compatible color display'
  1162.  
  1163.       card = video_system(3)
  1164.       crt = video_system(4)
  1165.  
  1166.       write(6,101) ' Inactive: '
  1167.  
  1168.       if(card.eq.0) write(6,*) 'Not installed.'
  1169.  
  1170.       if(card.eq. 1) write(6,101) 'MDA: Monochrome Display Adapter'
  1171.       if(card.eq. 2) write(6,101) 'CGA: Color Graphics Adapter'
  1172.       if(card.eq. 3) write(6,101) 'EGA: Enhanced Graphics Adapter'
  1173.       if(card.eq. 4) write(6,101) 'MCGA: Multi Color Gate Array'
  1174.       if(card.eq. 5) write(6,101) 'VGA: Video Graphics Array'
  1175.       if(card.eq.64) write(6,101) 'HGC: Hercules Graphics Card'
  1176.  
  1177.       if(crt.eq.1) write(6,*) ' with MDA-compatible monochrome display'
  1178.       if(crt.eq.2) write(6,*) ' with CGA-compatible color display'
  1179.       if(crt.eq.3) write(6,*) ' with EGA-compatible color display'
  1180.       if(crt.eq.4) write(6,*) ' with PS/2-compatible monochrome display'
  1181.       if(crt.eq.5) write(6,*) ' with PS/2-compatible color display'
  1182.  
  1183.    86 return
  1184.       end
  1185.  
  1186. C-------------------------------------------------------------------------
  1187.  
  1188.       character function crawl(x,y)
  1189.       include 'grex.fh'
  1190.       integer xmin,ymin,xmax,ymax
  1191.       integer k,j,x,y,step
  1192.       character q,nul,cv*13
  1193.       ier = get_clip_limits(xmin,ymin,xmax,ymax)
  1194.       ix = xmax - 98
  1195.       jx = xmax - 2
  1196.       iy = ymax - 10
  1197.       jy = ymax - 2
  1198.       nul = char(0)
  1199.       step = 4
  1200.    10 ier = move_cursor(x,y)
  1201.       j = get_pixel(x,y)
  1202.       write(cv,301) x,y,j,nul
  1203.   301 format(3i4,a)
  1204.       call set_color(0)
  1205.       call filled_rectangle(ix,iy,jx,jy)
  1206.       call graphic_text(cv,ix,iy,9)
  1207.       k = pause()
  1208.       if(k.lt.0) then
  1209.            k = -k
  1210.            if(k.eq.83) step = step-1
  1211.            if(k.eq.82) step = step+1
  1212.            step = max0(step,1)
  1213.            step = min0(step,100)
  1214.            if(k.lt.71.or.k.gt.81) go to 10
  1215.            if(k.eq.71.or.k.eq.72.or.k.eq.73) y = y - step
  1216.            if(k.eq.79.or.k.eq.80.or.k.eq.81) y = y + step
  1217.            if(k.eq.71.or.k.eq.75.or.k.eq.79) x = x - step
  1218.            if(k.eq.73.or.k.eq.77.or.k.eq.81) x = x + step
  1219.            if(x.lt.xmin) x = xmax + x - xmin + 1
  1220.            if(y.lt.ymin) y = ymax + y - ymin + 1
  1221.            if(x.gt.xmax) x = xmax - x + xmin + 1
  1222.            if(y.gt.ymax) y = ymax - y + ymin + 1
  1223.            go to 10
  1224.          endif
  1225.       crawl = char(k)
  1226.       ier = move_cursor(-1,-1)
  1227.       call set_color(0)
  1228.       call filled_rectangle(ix,iy,jx,jy)
  1229.       return
  1230.       end
  1231.  
  1232. C-------------------------------------------------------------------------
  1233.  
  1234.       integer function get_string(x,y,prompt,string)
  1235. c
  1236. c    Routine to get a string from the user interactively, displaying
  1237. c      the results on screen, and allowing the user to backspace over
  1238. c      mistakes.  Return or line feed terminate the procedure.
  1239. c
  1240.       integer x,y
  1241.       integer ix,iy,key,ic,ier
  1242.       integer xmin,ymin,xmax,ymax
  1243.       character*(*) prompt,string
  1244.       character nul
  1245.       include 'grex.fh'
  1246. c
  1247. c    nul value
  1248.       nul = char(0)
  1249. c
  1250. c    write prompt to screen
  1251.       ix = x
  1252.       iy = y
  1253.       call graphic_text(prompt,ix,iy,14)
  1254. c
  1255. c    find last nonblank character in prompt
  1256.       j = 1 + len(prompt)
  1257.     1 j = j-1
  1258.       if(j.le.0) go to 2
  1259.       if(prompt(j:j).eq.' '.or.prompt(j:j).eq.nul) go to 1
  1260.     2 j = max0(j,0)
  1261. c
  1262. c    adjust ix to describe position of the last nonblank character in prompt
  1263.       ix = ix + j*8
  1264. c
  1265. c    add one extra space
  1266.       ix = ix + 8
  1267. c
  1268. c    compare ix with clip limits; clip to within limits
  1269.       call get_clip_limits(xmin,ymin,xmax,ymax)
  1270.       ix = min0(ix,xmax)
  1271. c
  1272. c    initialize string and set up a character counter
  1273.       string = ' '
  1274.       ic = 0
  1275. c
  1276. c    While the user has not entered a return or a line feed
  1277. c      get a key from user
  1278.     5 key = pause()
  1279.       if(key.le.0) go to 5
  1280.       if(key.eq.13) go to 86
  1281.       if(key.eq.10) go to 86
  1282.       if(key.eq.8) then
  1283.  
  1284. c         erase a character only if one is there to erase
  1285.            if(ic.gt.0) then
  1286. c              adjust character position pointer
  1287.                 ix = ix - 8
  1288. c              erase character from screen using xor function
  1289.                 call set_xor(1)
  1290.                 call graphic_text(string(ic:ic),ix,iy,10)
  1291.                 call set_xor(0)
  1292. c              remove character from string
  1293.                 string(ic:ic) = ' '
  1294.                 ic = ic-1
  1295.               endif
  1296.  
  1297.          else
  1298.  
  1299. c         write character on screen
  1300.            call graphic_text(char(key),ix,iy,10)
  1301. c         advance to next position
  1302.            ix = ix + 8
  1303. c         store character in string
  1304.            ic = ic+1
  1305. c           if there is room
  1306.            ic = min0(ic,len(string))
  1307. c           otherwise replace last character of string
  1308.            string(ic:ic) = char(key)
  1309.  
  1310.          endif
  1311.  
  1312.       go to 5
  1313. c    End-while
  1314.  
  1315.    86 return
  1316.       end
  1317.