C              Fortran Friends (3 Mar 1996).
      PROGRAM TGRAPHICS
C        tests all Graphics library
C        needs 'graphics' and 'utils' libraries
C
      COMMON MODE,KOLORS,MROW,MCOL,NXOS,NYOS,NXPIX,NYPIX,IYB,IYT
C                 variables are:
C         MODE  = screen mode         KOLORS = number of colours
C         MROW  = bottom text row     MCOL   = right text column
C         NXOS,NYOS  = screen size in OS units
C         NXPIX,NYIX = screen size in pixels
C         IYB,IYT    = bottom and top of graphics window
C
C                  set up common
      CALL INIT
C                  set up screen and text window
      CALL LAYOUT
C                  test the remaining text commands
      CALL TTEXT
C                  test GRDPOL
      CALL TDPOL
C                  test colours for RISC_PC
      CALL TRPCC
C                  test animation with GRWAIT
      CALL TANIM
C                  test Colour Translation using ColourTrans module
      CALL TCOLTR
C                  test drawing commands
      CALL TDRAW
C                  test bits of circles
      CALL TCIRCB
C                  test mouse commands
      CALL TMOUSE
      END
C
      SUBROUTINE INIT
C        find graphics environment, and store in COMMON
      COMMON MODE,KOLORS,MROW,MCOL,NXOS,NYOS,NXPIX,NYPIX,IYB,IYT
      DIMENSION IVAR(12)
C        get the mode
      CALL GRGETM(MODE)
C        get all mode variables
      DO 10 I=1,12
   10 CALL GRRMV(-1,I,IVAR(I))
C        # colours
      KOLORS = IVAR(3) + 1
C        check for at least 16 colours
      IF(KOLORS .LT. 16) THEN
         PRINT *,'Please change to a mode with at least 16 colours'
         PRINT *,'This one has only',KOLORS
         PRINT *,'Then run the program again'
         STOP 'Too few colours'
       ENDIF
C        text rows and columns
      MROW = IVAR(2)
      MCOL = IVAR(1)
C        screen size in pixels
      NXPIX = IVAR(11) + 1
      NYPIX = IVAR(12) + 1
C        screen size in OS units
      NXOS = ISHFT(NXPIX,IVAR(4))
      NYOS = ISHFT(NYPIX,IVAR(5))
C              debug print
C      PRINT 101,MODE,KOLORS,MROW,MCOL,NXOS,NYOS,NXPIX,NYPIX
C  101 FORMAT(' screen variables are:'
C     +/'   MODE KOLORS   MROW   MCOL   NXOS   NYOS  NXPIX  NYPIX'
C     +/8I7)
C      CALL KWAIT
      RETURN
      END
C
      SUBROUTINE KWAIT
C         wait for keypress
C      PRINT *,'Space to continue, Escape to stop'
       CALL GRWOT(0,5,'Space to continue, Escape to stop')
C         stop if 'escape'
   10 I=IGET()
      IF(I.EQ.27) STOP 'Escape'
      IF(I.NE.32) GO TO 10
C         clear message window
      CALL GRCLRT
      RETURN
      END
C
      SUBROUTINE LAYOUT
C          set up screen and windows
      COMMON MODE,KOLORS,MROW,MCOL,NXOS,NYOS,NXPIX,NYPIX,IYB,IYT
      CHARACTER*3 TXCOLR
C
C          set mode to initialse screen
      CALL GRSETM(MODE)
C          set text window in centre of bottom
      IXL = (MCOL + 1)/2 - 20
      CALL GRTWIN(IXL, MROW, IXL+39, MROW-5)
C          set text background colour blue
      IF(KOLORS .GE. 256) THEN
        CALL GRSETT(256, 0, 255)
      ELSE
        CALL GRTCOL(132)
      ENDIF
C          clear text window to background colour
      CALL GRCLRT
C          explain
      PRINT *,'This is a text window'
      PRINT *,'It will contain instructions'
C          test mode valid
      M=MODE
      DO 5 I=1,2
        CALL GRCMV(M,NEWMOD)
        IF(M.LT.255) THEN
          PRINT *,'mode',M,' validates as',NEWMOD
        ELSE
          IF(NEWMOD.GT.255) THEN
            PRINT *,'current mode selector OK'
          ELSE
            PRINT *,'current mode validates as',NEWMOD
          ENDIF
        ENDIF
        M=-1
    5 CONTINUE
C          set graphics background to dark grey
      IF(KOLORS.LT.256) THEN
C              16 colours, set up colours 8 to 14 to be grey shades
        DO 10 IC=1,7
   10   CALL GRPAL(IC+7,IC*32,IC*32,IC*32)
C              set colour 15 to be orange
        CALL GRPAL(15,240,144,0)
        CALL GRGCOL(0,137)
      ELSE
C               RISC_PC mode
        CALL GRSETC(128,64,64,64)
      ENDIF
C          translate screen mode to ASCII
      IF(KOLORS.LE.256) THEN
        WRITE (TXCOLR,101) KOLORS
  101   FORMAT(I3)
      ELSEIF(KOLORS.LT.10000000) THEN
        TXCOLR = '16K'
      ELSE
        TXCOLR = '32M'
      ENDIF
C          calculate where to put 19 character double size heading
      IXL = (NXOS * (MCOL - 19 * 2))/(2 * MCOL)
      IYT = NYOS - (NYOS * 2) / (MROW + 1)
C          write heading (17 characters long)
      CALL GRWBIG(IXL, IYT, TXCOLR//' Colour Graphics',2)
C          now make graphics window in between
      IYB = (NYOS * 6) / (MROW + 1)
      CALL GRGWIN(0, IYB, NXOS-1, IYT)
C          clear graphics screen
      CALL GRCLRG
C                  wait for user to press key
      CALL KWAIT
      RETURN
      END
C
      SUBROUTINE SETCOL(COLOUR)
C          set the graphics colour to COLOUR
C          made into a separate routine because the procedure 
C          depends on the number of colours
C
      COMMON MODE,KOLORS,MROW,MCOL,NXOS,NYOS,NXPIX,NYPIX,IYB,IYT
      PARAMETER (NC=8)
      DIMENSION K16(NC),KR(NC),KG(NC),KB(NC)
      CHARACTER*8 COLS(NC),DUM
      CHARACTER*(*) COLOUR
      DATA K16 /   1,     2,      3,    4,      5,     6,      7,    0/
      DATA KR  / 192,     0,    192,    0,    192,     0,    192,    0/
      DATA KG  /   0,   192,    192,    0,      0,   192,    192,    0/
      DATA KB  /   0,     0,      0,  192,    192,   192,    193,    0/ 
      DATA COLS/'RED','GREEN','YELLOW','BLUE','MAGENTA','CYAN','WHITE',
     +      'BLACK'/
C           find colour
      DUM = COLOUR
      DO 10 IC=1,NC
        IF(DUM .EQ. COLS(IC)) GO TO 20
   10 CONTINUE
      PRINT *,'unknown colour',COLOUR
      STOP 'colour'
   20 IF(KOLORS .GE. 256) THEN
        CALL GRSETC(0,KR(IC),KG(IC),KB(IC))
      ELSE
        CALL GRGCOL(0,K16(IC))
      ENDIF
      RETURN
      END
C
      SUBROUTINE TANIM
C         test animation with/without GRWAIT
C
      COMMON MODE,KOLORS,MROW,MCOL,NXOS,NYOS,NXPIX,NYPIX,IYB,IYT
C
C         set up graphics colour
      IF(KOLORS .GE. 256) THEN
        JWHI = IEOR(255,64)
        CALL GRSETC(3,JWHI,JWHI,JWHI)
      ELSE
        CALL GRGCOL(3,14)
      ENDIF
C         loop over animation, first without GRWAIT, then with
      DO 50 I=1,2
        IF(I .EQ. 1) THEN
          CALL GRWOT(0,0,'animation without waiting for frame scan')
        ELSE
          PRINT *,'animation waiting for frame scan'
        ENDIF
        PRINT *,'press any key to stop animation'
        IY = IYB+64
   10   IX = -64
C         plot initial circle
        CALL GRCIRC(IX,IY,64,.TRUE.)
C         animate
   20   IF(I .EQ. 2) CALL GRWAIT
C         erase old disc
        CALL GRCIRC(IX,IY,64,.TRUE.)
C         draw new disc
        IX = IX + 2
        CALL GRCIRC(IX,IY,64,.TRUE.)
        IF(IX .GT. NXOS+64) GO TO 10
C         check for key press
        IF(INKEY(0) .LT. 0) GO TO 20
        CALL GRCLRG
        CALL GRCLRT
   50 CONTINUE
      RETURN
      END
C
      SUBROUTINE TCIRCB
      COMMON MODE,KOLORS,MROW,MCOL,NXOS,NYOS,NXPIX,NYPIX,IYB,IYT
      PARAMETER(DTOR = 3.14159/180.0)
C            Red circular arcs
      CALL SETCOL('RED')
      CALL GRORIG(0,IYB)
      CALL GRARCC(100,100,80,-0.5,2.)
      CALL GRSECT(300,100,80,-0.5,2.,.FALSE.)
      CALL GRSECT(500,100,80,-0.5,2.,.TRUE.)
      PRINT *,'Red circular arcs'
      CALL KWAIT
      CALL SETCOL('GREEN')
      CALL GRSEGC(300,300,80,-0.5,2.,.FALSE.)
      CALL GRSEGC(500,300,80,-0.5,2.,.TRUE.)
      CALL GRSEGC(700,300,80,-2.5,2.,.FALSE.)
      CALL GRSEGC(900,300,80,-2.5,2.,.TRUE.)
      PRINT *,'Green circular sectors'
      CALL KWAIT
      CALL GRCLRG
      RETURN
      END
C
      SUBROUTINE TCOLTR
C         test colour translation using ColourTrans module
C
      COMMON MODE,KOLORS,MROW,MCOL,NXOS,NYOS,NXPIX,NYPIX,IYB,IYT
C
C         draw a set of 8 rectangles in shades of grey
      DO 10 IC = 16, 240, 32
C         pre-setcolour to yellow
        CALL SETCOL('YELLOW')
C         set colour to shade of grey
        CALL GRSETC(0, IC, IC, IC)
C         draw solid rectangle
        CALL GRRECT(64, IC*3+IYB, NXOS-64, IC*3+IYB+80, .TRUE.)
C         draw outline red rectangle
        CALL SETCOL('RED')
        CALL GRRECT(64, IC*3+IYB, NXOS-64, IC*3+IYB+80, .FALSE.)
   10 CONTINUE
C         set background text colour red
      CALL GRSETT(256+240,0,0)
      CALL GRCLRT
C         set light grey text
      CALL GRSETT(192,192,192)
      PRINT *,'    8 grey-shaded rectangles'
      PRINT *
C         set light yellow text
      CALL GRSETT(255,255,0)
      PRINT *,'if they are all yellow,'
      PRINT *,'load the ColourTrans module'
C         restore white text
      CALL GRSETT(240,240,240)
      CALL KWAIT
C         restore blue text background
      CALL GRSETT(256,0,240)
      CALL GRCLRT
      CALL GRCLRG
      RETURN
      END

      SUBROUTINE TDRAW
C         test proper graphics - drawing commands
C
      COMMON MODE,KOLORS,MROW,MCOL,NXOS,NYOS,NXPIX,NYPIX,IYB,IYT
      PARAMETER(DTOR = 3.14159/180.0)
      DIMENSION IX1(6),IY1(6),IX2(6),IY2(6)
C
C         outline red rectangle
      CALL SETCOL('RED')
      CALL GRRECT(0,IYB,256,512,.FALSE.)
C         with internal solid green one
      CALL SETCOL('GREEN')
      CALL GRRECT(16,IYB+16,240,496,.TRUE.)
      PRINT *,'green solid rectangle inside'
      PRINT *,'red outline rectangle'
      CALL KWAIT
C         outline yellow triangle
      CALL SETCOL('YELLOW')
      CALL GRTRI(320,IYB,640,IYB,360,512,.FALSE.)
C         with internal solid cyan one
      CALL SETCOL('CYAN')
      CALL GRTRI(336,IYB+16,610,IYB+16,368,480,.TRUE.)
      PRINT *,'outline yellow triangle'
      PRINT *,'with internal solid cyan one'
      CALL KWAIT
C         copy a piece of the rectangle
      CALL GRCOPY(0,IYB,256,256,64,640)
      PRINT *,'copy the bottom of the rectangles'
      CALL KWAIT
C         fill border between triangles with magenta
      CALL SETCOL('MAGENTA')
      CALL GRFILB(336,IYB+8)
      PRINT *,'fill border between triangles'
      PRINT *,'with magenta'
      CALL KWAIT
C          set up pentagons radii 180 & 200
      A = 0.0
      DO 10 I = 1, 6
      IX1(I) = 200.0 * COS(A * DTOR)
      IY1(I) = 200.0 * SIN(A * DTOR)
      IX2(I) = 180.0 * COS(A * DTOR)
      IY2(I) = 180.0 * SIN(A * DTOR)
   10 A = A + 72.0
C         move origin
      CALL GRORIG(960,IYB+200)
C         outline white pentagon
      CALL SETCOL('WHITE')
      CALL GRPOLY(6,IX1,IY1,.FALSE.)
C         solid blue pentagon
      CALL SETCOL('BLUE')
      CALL GRPOLY(5,IX2,IY2,.TRUE.)
      PRINT *,'outline white pentagon'
      PRINT *,'with solid blue pentagon'
      CALL KWAIT
C         outline circle
      CALL GRORIG(1000,600+IYB)
      CALL SETCOL('RED')
      CALL GRCIRC(0,0,200,.FALSE.)
      PRINT *,'red outline circle with'
      PRINT *,'yellow spots'
      CALL GRWOT(0,5,'press any key to stop spots')
      CALL SETCOL('YELLOW')
   20 IX = -200 + 400 * RND01()
      IY = -200 + 400 * RND01()
      IF(IX*IX + IY*IY .GT. 40000) GO TO 20
      CALL GRWAIT
      CALL GRSPOT(IX,IY)
      IF(INKEY(0) .LE. 0) GO TO 20
C         dotted pentagon
      CALL GRORIG(560,600+IYB)
C         define dot size
      CALL GRDEFD('1111100011000')
      CALL GRMOVE(IX1(1),IY1(1))
      DO 30 I=2,6
   30 CALL GRPLOT(21,IX1(I),IY1(I))
C           Print message in pentagon
      CALL GRMOVE(-64,0)
      CALL GRVDU(5)
      PRINT *,'Pentagon'
      CALL GRVDU(4)
      CALL GRCLRT
      PRINT *,'dotted pentagon'
C           Underline it
      CALL GRLINE(-48,-24,80,-24)
C           Spotted line over it
      CALL GRDEFD('A')
      CALL GRMOVE(-48,16)
      CALL GRPLOT(17,128,0)
      CALL KWAIT
C           draw line right across the screen
      CALL GRORIG(0,0)
      CALL SETCOL('RED')
      CALL GRMOVE(-2000,-2000)
      CALL GRDRAW(2000,2000)
      PRINT *,'line diagonally across the screen'
      CALL KWAIT
C            draw outline green ellipse
      CALL SETCOL('GREEN')
      CALL GRELIP(NXOS/2,NYOS/2,400,200,1.0,.FALSE.)
C            draw solid red ellipse inside it
      CALL SETCOL('RED')
      CALL GRELIP(NXOS/2,NYOS/2,200,100,2.0,.TRUE.)
      PRINT *,'outline green ellipse containing'
      PRINT *,'solid red ellipse'
      CALL KWAIT
      CALL GRCLRG
      RETURN
      END
C
      SUBROUTINE TDPOL
C         test the Draw_Stroke/Draw_Fill
C
      COMMON MODE,KOLORS,MROW,MCOL,NXOS,NYOS,NXPIX,NYPIX,IYB,IYT
      PARAMETER(DTOR = 3.14159/180.0)
      DIMENSION IXY(2,6)
      A = 0.
      R = 200
      DO 10 I=1,6
        IXY(1,I) = 400+R*COS(A)
        IXY(2,I) = 400+R*SIN(A)
        A = A + DTOR*60.0
   10 CONTINUE
      CALL SETCOL('RED')
      CALL GRDPOL(IXY,6,.TRUE.,.FALSE.,?I800,0)
      PRINT *,'testing GRDPOL...'
      PRINT *,'solid red outline'
      CALL KWAIT
      CALL SETCOL('GREEN')
C             filled green hexagon
      CALL GRDPOL(IXY,6,.TRUE.,.TRUE.,?I800,0)
      PRINT *,'green hexagon with no outline'
      CALL KWAIT
      CALL SETCOL('CYAN')
C             cyan dashed line
      CALL GRORIG(640,512)
      IXY(1,1) = -640
      IXY(2,2) = -512
      IXY(1,2) = 640
      IXY(2,1) = 512
C         dash sizes on:18, off:12, on:6, off:12.
      CALL GRDPOL(IXY,2,.FALSE.,.FALSE.,?I600,?I120C060C)
      PRINT *,'dot-dashed cyan line'
      CALL KWAIT
      CALL GRORIG(0,0)
      CALL GRCLRG
      RETURN
      END
C
      SUBROUTINE TMOUSE
C         test the mouse commands:
C         GRPBOX, GRPBUT, GRPGET, GRPPUT, GRPSET, GRPSPD
C
      COMMON MODE,KOLORS,MROW,MCOL,NXOS,NYOS,NXPIX,NYPIX,IYB,IYT
C
      CHARACTER*6 BUTTONS(4)
      SAVE BUTTONS
      DATA BUTTONS/'Adjust','  Menu',' ','Select'/
      PRINT *,'Turn on the pointer'
      CALL GRPSET(1)
      CALL KWAIT
C           set pointer box
      CALL GRPBOX(NXOS/2,NYOS/2,NXOS-1,NYOS-1)
      PRINT *,'Pointer now limited to'
      PRINT *,'the top right of the screen'
      CALL KWAIT
C           set to whole screen
      CALL GRPBOX(0,0,NXOS-1,NYOS-1)
C           check for interrupt driven mouse operation
      DO 10 I=1,2
        PRINT *,'move the pointer then click'
        PRINT *,' a mouse button or key'
        CALL GRPBUT(IX,IY,IB)
        IF(IB.LT.5) THEN
          PRINT *,BUTTONS(IB),' pressed at',IX,IY
        ELSE IF(IB.GT.32 .AND. IB.LT.127) THEN
          PRINT *,'Key <',CHAR(IB),'> pressed at',IX,IY
        ELSE
          PRINT *,'ASCII character',IB,' received at',IX,IY
        ENDIF
        CALL KWAIT
   10 CONTINUE
C           check for continuous mouse operation
      PRINT *,'press ''Menu'' to stop'
      PRINT *,'pointer at:'
      CALL GRCURS(.FALSE.)
   20 CALL GRPGET(IX,IY,IB)
      IF(IB.NE.0) CALL GRSPOT(IX,IY)
      CALL GRTAB(11,1)
      PRINT 101,IX,IY,IB
  101 FORMAT(2I5,' button',I2)
      IF(IB.NE.2) GO TO 20
      CALL GRCURS(.TRUE.)
      CALL GRCLRG
      CALL GRCLRT
      PRINT *,'pointer now disconnected from mouse'
      CALL GRPSET(2)
      CALL KWAIT
C           move pointer in a circle
      CALL GRORIG(NXOS/2,NYOS/2)
      PRINT *,'pointer drawing a circle'
      DO 30 A= 0., 6.283, 0.02
      IX = NINT(300.*COS(A))
      IY = NINT(300.*SIN(A))
      CALL GRWAIT
      CALL GRPPUT(IX,IY)
      CALL GRSPOT(IX,IY)
   30 CONTINUE
      CALL KWAIT
      CALL GRPSET(1)
   40 CALL GRCLRT
      PRINT *,'enter new mouse speed (-128 to 127)'
      PRINT *,'0 to stop'
      READ *,ISPD
      IF(ISPD.NE.0) THEN
        CALL GRPSPD(ISPD)
        GO TO 40
      ENDIF
C        reset to configured speed
      CALL GRPSPD(200)
C        test hourglass
      CALL GRCLRT
      PRINT *,'Hourglass turned on'
      CALL GRHOUR(-1)
      CALL KWAIT
      PRINT *,'test  percentage Hourglass'
      DO 50 I=10,90,10
        CALL GRHOUR(I)
        K=INKEY(50)
   50 CONTINUE
C        turn off hourglass
      CALL GRHOUR(0)
      RETURN
      END
C
      SUBROUTINE TRPCC
C         test large number of colours especially RISC_PC modes
C
      COMMON MODE,KOLORS,MROW,MCOL,NXOS,NYOS,NXPIX,NYPIX,IYB,IYT
C
C      IF(KOLORS.LT.256) RETURN
C         draw colour triangle
      JDX = (NXOS/16)/2
      JDY = (IYT-IYB)/16
      DO 30 IR=0,15
        DO 20 IG=0,15
          IB = 30 - IR - IG
          IF(IB.LE.15) THEN
            CALL GRSETC(0,IR*16,IG*16,IB*16)
            IX0 = (15+IR-IG)*JDX
            IY0 = (IR+IG-15)*JDY+IYB
            CALL GRTRI(IX0,IY0,IX0+JDX*2,IY0,IX0+JDX,IY0+JDY,.TRUE.)
            IF(IR.NE.15) THEN
              CALL GRSETC(0,IR*16+8,IG*16,IB*16)
              CALL GRTRI(IX0+JDX,IY0+JDY,IX0+JDX*2,IY0,
     +                   IX0+3*JDX,IY0+JDY,.TRUE.)
            ENDIF
          ENDIF
   20   CONTINUE
   30 CONTINUE
C              turn on pointer
      CALL GRPSET(1)
   40 CALL GRCLRT
      PRINT *,'click select over colour'
      PRINT *,'click adjust to continue'
   50 CALL GRPGET(IX,IY,IB)
      IF(IB.EQ.0) GO TO 50
      IF(IB.EQ.4) THEN
        CALL GRGETC(IX,IY,IR,IG,IB)
        PRINT 101,IR,IG,IB
  101   FORMAT('RGB = ',3I4)
   60   CALL GRPGET(IX,IY,IB)
        IF(IB.NE.0) GO TO 60
        GO TO 40
      ENDIF
C               turn off pointer
      CALL GRPSET(0)
      CALL KWAIT
      CALL GRCLRG
      RETURN
      END
C
      SUBROUTINE TTEXT
C         test remaining text commands: 
C       GRCHAR, GRCURS, GRTAB, GRWOG
C
      COMMON MODE,KOLORS,MROW,MCOL,NXOS,NYOS,NXPIX,NYPIX,IYB,IYT
C
C         createa stick figure
      DIMENSION IDEF(8)
      DATA IDEF/56,56,16,124,146,56,68,130/
      CALL GRCHAR(126,IDEF)
C         print him BIG
      CALL GRWBIG(NXOS/2,NYOS/2,CHAR(126),8)
C         test tab
      CALL GRTAB(2,2)
      PRINT *,'create a stick figure character'
C         reset definitions
      CALL OSBYTE(20,0,0)
      CALL KWAIT
      CALL GRCLRG
C         test cursor off/on
      CALL GRCURS(.FALSE.)
      CALL GRWOG(32,IYT-64,'there should be no flashing text cursor')
      CALL KWAIT
      CALL GRCURS(.TRUE.)
      CALL GRCLRG
      CALL GRWOG(32,IYT-64,'flashing cursor now restored')
      CALL KWAIT
      CALL GRCLRG
C
      RETURN
      END
