home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgLangD.iso / FORTRAN / DISK6 / WINDOW.FO$ / WINDOW.bin
Text File  |  1990-09-28  |  3KB  |  96 lines
  1. CC  WINDOW.FOR - Illustrates windows and coordinate systems using
  2. CC               the following functions:
  3. CC               clearscreen   ellipse        ellipse_w 
  4. CC               rectangle      rectangle_w   setcliprgn
  5. CC               setvieworg     setviewport    setwindow
  6. CC
  7. CC  Although not all illustrated here, functions ending in _w
  8. CC  are similar to rectangle_w and ellipse_w.
  9.  
  10.       INCLUDE  'FGRAPH.FI'
  11.       INCLUDE  'FGRAPH.FD'
  12.  
  13.       INTEGER*2  status, xhalf, yhalf, xquar, yquar
  14.       DOUBLE PRECISION  x_upleft, y_upleft, x_botrght, y_botrght
  15.       RECORD / xycoord /     xy
  16.       RECORD / videoconfig / vc
  17.  
  18. C
  19. C     Find graphics mode.
  20. C
  21.       IF( setvideomode( $MAXRESMODE ) .EQ. 0 ) 
  22.      +    STOP 'Error:  cannot set graphics mode'
  23.       CALL getvideoconfig( vc )
  24.       xhalf = vc.numxpixels / 2
  25.       yhalf = vc.numypixels / 2
  26.       xquar = xhalf / 2
  27.       yquar = yhalf / 2
  28.  
  29. C
  30. C     First window - integer physical coordinates
  31. C
  32.       CALL setviewport( 0, 0, xhalf - 1, yhalf - 1 )
  33.       status = setcolor( 2 )
  34.       status = rectangle( $GBORDER, 0, 0, xhalf - 1, yhalf - 1 )
  35.       status = setcolor( 1 )
  36.       status = ellipse( $GFILLINTERIOR, xquar / 4, yquar / 4,
  37.      +                 xhalf - (xquar / 4), yhalf - (yquar / 4) )
  38.       READ (*,*) ! Wait for ENTER to be pressed
  39.       CALL clearscreen( $GVIEWPORT )
  40.       status = rectangle( $GBORDER, 0, 0, xhalf - 1, yhalf - 1 )
  41.  
  42. C
  43. C     Second window - integer world coordinates with clip region
  44. C
  45.       CALL setcliprgn( xhalf, 0, vc.numxpixels, yhalf )
  46.       CALL setvieworg( xhalf + xquar - 1, yquar - 1, xy )
  47.       status = setcolor( 3 )
  48.       status = rectangle( $GBORDER, -xquar + 1, -yquar + 1, xquar,
  49.      +                   yquar )
  50.       status = setcolor( 2 )
  51.       status = ellipse( $GFILLINTERIOR, (-xquar * 3) / 4,
  52.      +                 (-yquar * 3) / 4, (xquar * 3) / 4,
  53.      +                 (yquar * 3) / 4 )
  54.       READ (*,*) ! Wait for ENTER to be pressed
  55.       CALL clearscreen( $GVIEWPORT )
  56.       status = rectangle( $GBORDER, -xquar + 1, -yquar + 1, xquar,
  57.      +                   yquar )
  58.  
  59. C
  60. C     Third window
  61. C
  62.       CALL setviewport( xhalf, yhalf, vc.numxpixels - 1,
  63.      +                  vc.numypixels - 1 )
  64.       status = setwindow( .FALSE., -4.0, -5.0, 4.0, 5.0 )
  65.       status = setcolor( 4 )
  66.       status = rectangle_w( $GBORDER, -4.0, -5.0, 4.0, 5.0 )
  67.       status = setcolor( 3 )
  68.       status = ellipse_w( $GFILLINTERIOR, -3.0, -3.5, 3.0, 3.5 )
  69.       READ (*,*) ! Wait for ENTER to be pressed
  70.       CALL clearscreen( $GVIEWPORT )
  71.       status = rectangle_w( $GBORDER, -4.0, -5.0, 4.0, 5.0 )
  72.  
  73. C
  74. C     Fourth window
  75. C
  76.       CALL setviewport( 0, yhalf, xhalf - 1, vc.numypixels - 1 )
  77.       status = setwindow( .FALSE., -4.0, -5.0, 4.0, 5.0 )
  78.       x_upleft  = -4.0
  79.       y_upleft  = -5.0
  80.       x_botrght =  4.0
  81.       y_botrght =  5.0
  82.       status = setcolor( 5 )
  83.       status = rectangle_w( $GBORDER, x_upleft, y_upleft,
  84.      +                     x_botrght, y_botrght )
  85.       x_upleft  = -3.0
  86.       y_upleft  = -3.5
  87.       x_botrght =  3.0
  88.       y_botrght =  3.5
  89.       status = setcolor( 4 )
  90.       status = ellipse_w( $GFILLINTERIOR, x_upleft, y_upleft,
  91.      +                   x_botrght, y_botrght )
  92.  
  93.       READ (*,*) ! Wait for ENTER to be pressed
  94.       status = setvideomode( $DEFAULTMODE )
  95.       END
  96.