home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / fortran / mslang / mouse_32 / m_test.for < prev    next >
Text File  |  1993-06-16  |  6KB  |  177 lines
  1. C  This program does some basic tests of the mouse routines in MOUSE.ASM
  2. C  
  3.       include 'flib.fi'
  4.       include 'fgraph.fi'
  5.       include 'mouse.fi'
  6.       include 'flib.fd'
  7.       include 'fgraph.fd'
  8.       include 'mouse.fd'
  9.  
  10.       integer*4 ix,iy, ip, ir
  11.       character*40 buf
  12.       character*1 ans
  13.  
  14.       RECORD / rccoord / pos
  15.       RECORD / EVENT / pEvent
  16.       RECORD / BTN_STS / btns
  17.  
  18.       open(1,file='mousetst.out')      
  19.       i=setvideomode($VRES16COLOR)
  20.       
  21.       call settextposition(1,1,pos)
  22.       call outtext('Note: This test reqires full screen mode')
  23.       if (getcharQQ() .eq. 'q') stop
  24.  
  25. C  Test 1: call MOUSEINIT
  26. C
  27. C       The following call is not required, each mouse function checks to see
  28. C          if initialization is required, and calls MOUSEINIT if necessary.
  29.       if (mouseinit() .eq. 0) stop 'No Mouse Driver'
  30.         write(1,*) 'Mouse exists (test 1 - Pass)'
  31.       
  32. C  Test 2: test GETMOUSEEVENT (with no event)
  33.       call settextposition(1,1,pos)
  34.       call outtext('Without moving cursor, press a key      ')
  35.  
  36.       if (getcharQQ() .eq. 'q') stop
  37.       if (getmouseevent(pEvent)) then
  38.         call settextposition(2,2,pos)
  39.         call outtext('Mouse Event')
  40.         write(1,*) 'Mouse event - test failed'
  41.       else
  42.         write(1,*) 'No Event (test 2 - Pass)'
  43.       endif
  44.       
  45. C  Test 3: test GETMOUSEEVENT (with an event)
  46.       call settextposition(1,1,pos)
  47.       call outtext('Move the cursor then press a key  ')
  48.  
  49.       if (getcharQQ() .eq. 'q') stop
  50.       if (getmouseevent(pEvent)) then
  51.         call settextposition(2,2,pos)
  52.         call outtext('Mouse Event')
  53.         write(1,*) 'Read mouse move (test 3 - Pass)'
  54.       else
  55.         call settextposition(2,2,pos)
  56.         call outtext('           ')
  57.         write(1,*) 'Did not read mouse move'
  58.       endif
  59.       
  60. C  Test 4: test Cursor Move (GETPTRPOS and SETPTRPOS)
  61.       call settextposition(1,1,pos)
  62.       call outtext('Press a key and watch the cursor move')
  63.       call settextposition(3,3,pos)
  64.       write(buf,'(I3,'','',I3)') pEvent.x, pEvent.y
  65.       call outtext('Current position:'//buf)
  66.  
  67.       if (getcharQQ() .eq. 'q') stop
  68.       
  69.       ix = pEvent.x +10
  70.       iy = pEvent.y +10
  71.       call setptrpos(ix,iy)
  72.       
  73.       call settextposition(1,1,pos)
  74.       call outtext('Did the cursor move down and left?   ')
  75.       call settextposition(2,2,pos)
  76.       call outtext('                           ')
  77.       call settextposition(3,3,pos)
  78.       call getptrpos(pEvent)
  79.       write(buf,'(I3,'','',I3)') pEvent.x, pEvent.y
  80.       call outtext('New position:'//buf)
  81.  
  82.       ans = getcharQQ()
  83.       if (ans .eq. 'q') stop
  84.       if (ans .eq. 'y' .or. ans .eq. 'Y') then
  85.         write(1,*) 'Mouse move OK (test 4 - Pass)'
  86.       else
  87.         write(1,*) 'Mouse move Fail'
  88.       endif
  89.  
  90.       call settextposition(3,3,pos)
  91.       call outtext('                              ')
  92.  
  93. C  Test 5: test Cursor Drag and Drop (GETBUTTONPRESS and GETBUTTONRELEASE)
  94.       call settextposition(1,1,pos)
  95.       call outtext('Press left button while moving cursor  ')
  96.       call settextposition(3,3,pos)
  97.       call outtext('                           ')
  98.  
  99.       if (getcharQQ() .eq. 'q') stop
  100.       
  101.       btns.Btn = 0  !left button
  102.       ip = getbuttonpress(btns)
  103.       ix = btns.x
  104.       iy = btns.y
  105.       ir = getbuttonrelease(btns)
  106.       
  107.       call settextposition(1,1,pos)
  108.       write(buf,'(I3,'', released:'',I3)') ip,ir
  109.       call outtext('Left button was pressed:'//buf)
  110.       write(buf,'(I3,'','',I3)') ix, iy
  111.       call settextposition(2,2,pos)
  112.       call outtext('Dragged from:'//buf)
  113.       call settextposition(3,3,pos)
  114.       write(buf,'(I3,'','',I3)') btns.x, btns.y
  115.       call outtext('To:'//buf)
  116.  
  117.       ans = getcharQQ()
  118.       if (ans .eq. 'q') stop
  119.       if (ans .eq. 'n' .or. ans .eq. 'N') then
  120.         write(1,*) 'Mouse drag Fail'
  121.       else
  122.         write(1,*) 'Mouse drag OK (test 5 - Pass)'
  123.       endif
  124.  
  125.       call settextposition(2,2,pos)
  126.       call outtext('                              ')
  127.       call settextposition(3,3,pos)
  128.       call outtext('                              ')
  129.  
  130. C  Test 6: Making Cursor Invisible (SETPTRVIS(2))
  131.       call settextposition(1,1,pos)
  132.       call outtext('Is the cursor visible?                          ')
  133.  
  134.       call setptrvis(2) !hide cursor
  135.       ans = getcharQQ()
  136.       if (ans .eq. 'q') stop
  137.       if (ans .eq. 'y' .or. ans .eq. 'Y') then
  138.         write(1,*) 'Cursor visible (SetPtrVis Fail)'
  139.       else
  140.         write(1,*) 'Cursor visible (test 6 - Pass)'
  141.       endif
  142.  
  143. C  Test 7: Making Cursor Visible (SETPTRVIS(1))
  144. C
  145. C     Note: if setptrvis(2) is called more than once, setptrvis(1) will need
  146. C           to be called more than once to restore visibility.
  147. C           It is safe to call setptrvis(1) many times (even if it is not
  148. C           necessary)
  149.       call settextposition(1,1,pos)
  150.       call outtext('Is the cursor visible?              ')
  151.  
  152.       call setptrvis(1) !show cursor
  153.       ans = getcharQQ()
  154.       if (ans .eq. 'q') stop
  155.       if (ans .eq. 'y' .or. ans .eq. 'Y') then
  156.         write(1,*) 'Cursor visible (test 7 - Pass)'
  157.       else
  158.         write(1,*) 'Cursor visible (SetPtrVis Fail)'
  159.       endif
  160.  
  161. C  Test 8: Get the coordinates of the corners (tests coordinate limits and
  162. C          absolute positioning)
  163.       call setptrpos(-1,-1)
  164.       call getptrpos(pEvent)
  165.       write(1,*) 'Upper left is:', pEvent.x, pEvent.y
  166.       call setptrpos(-1,1234)
  167.       call getptrpos(pEvent)
  168.       write(1,*) 'Lower left is:', pEvent.x, pEvent.y
  169.       call setptrpos(1234,-1)
  170.       call getptrpos(pEvent)
  171.       write(1,*) 'Upper right is:', pEvent.x, pEvent.y
  172.       call setptrpos(1234,1234)
  173.       call getptrpos(pEvent)
  174.       write(1,*) 'Lower right is:', pEvent.x, pEvent.y
  175.  
  176.  
  177.       end