      PROGRAM TFONT
      COMMON /SIZES/ MAXSCR(2),MAXPRT(2),ISCL(2),MINY,NCOLR,IHAND
C       to test the font library
C
C       needs the font and graphics libraries
C
C       first set up the screen
      CALL SETUP
C       list the font cache etc.
      CALL LISTC
C       list the available fonts
   10 CALL LISTF
C       fix up colours etc.
      CALL FIXCOL
C       check size measurements
      CALL CKSIZE
C       print at an angle
      CALL ANGLE
      GO TO 10
      END
C
      SUBROUTINE ANGLE
      COMMON /SIZES/ MAXSCR(2),MAXPRT(2),ISCL(2),MINY,NCOLR,IHAND
      PARAMETER (D2R=3.14159/180.)
C                make red background
      CALL GRSETC(0,255,0,0)
      CALL GRRECT(0,MINY,MAXSCR(1),MAXSCR(2),.TRUE.)
      IX = 64
      IY = MAXSCR(2)/2
      CALL FTPRNT(IHAND,'Text at  +0 degrees',IX,IY,0,0)
      CALL FTPRTA(IHAND,'Text at -45 degrees',IX,IY,0,
     +  -45.0*D2R,1.0)
      CALL FTPRTA(IHAND,'Text at +45 degrees half size, blanked',
     +  IX,IY,1,45.0*D2R,0.5)
      PRINT *,'SPACEBAR to continue; ESCAPE to stop'
   30 CALL GRPBUT(IX1,IY1,IB)
      IF(IB.LT.4) GO TO 30
      CALL GRCLRT
      CALL FTLOSE(IHAND)
      CALL GRCLRG
      RETURN
      END
C
      SUBROUTINE CKSIZE
C        to check the size calculations
      COMMON /SIZES/ MAXSCR(2),MAXPRT(2),ISCL(2),MINY,NCOLR,IHAND
      CHARACTER PREFIX*256, STRING*24, CHR*1
      DATA STRING/'Where is the silly text?'/
      IF(IHAND.EQ.0) STOP 'problem finding font'
      CALL FTPREF(IHAND,PREFIX)
      IX = 32
      IY = MAXSCR(2) - 64
      DO 10 IT=1,2
        CALL FTSZXY(IHAND,STRING,IXMIN,IYMIN,IXMAX,IYMAX)
C            print string unjustified
        CALL FTPRNT(IHAND,STRING,IX,IY,IT.EQ.2,0)
C            draw red box round it
        CALL GRSETC(0,255,0,0)
        CALL GRRECT(IX+IXMIN,IY+IYMIN,IX+IXMAX,IY+IYMAX,.FALSE.)
C            and justified
        IXMAX = IXMAX + 256
        IY = IY - 96
        CALL FTPRNT(IHAND,STRING,IX,IY,IT.EQ.2,IX+IXMAX)
C            draw box round it
        CALL GRRECT(IX+IXMIN,IY+IYMIN,IX+IXMAX,IY+IYMAX,.FALSE.)
        IY = IY - 96
C            make green background for second pass
        IF(IT.EQ.1) THEN
          CALL GRSETC(0,0,255,0)
          CALL GRRECT(0,IY-128,IXMAX+64,IY+64,.TRUE.)
        ENDIF
   10 CONTINUE
      PRINT *,'Prefix to Intmetrics file is:'
      PRINT *,PREFIX(1:LNBLNK(PREFIX))
      LINE = -1
   20 PRINT *,'click where you want the caret; ',
     +'SPACEBAR to continue; ESCAPE to stop'
   30 CALL GRPBUT(IX1,IY1,IB)
      IF(IB.LT.4) GO TO 30
      CALL GRCLRT
      IF(LINE.GE.0) CALL FTSCRT(IHAND,13,IXOUT+IX,MAXSCR(2)-96*LINE-64)
      LINE = (MAXSCR(2) - IY1)/96
      IF(IB.EQ.32) THEN
        CALL GRCLRG
        RETURN
      ELSEIF(LINE.GT.3) THEN
C           draw font bounding box in cyan
        CALL FTBBOX(IHAND,IXL,IYL,IXH,IYH)
        CALL GRSETC(0,0,255,255)
        CALL GRRECT(IXL+IX1,IYL+IY1,IXH+IX1,IYH+IY1,.TRUE.)
        CALL GRSETC(0,255,255,0)
        CALL GRCIRC(IX1,IY1,8,.TRUE.)
        IF(IB.GT.32.AND.IB.LT.127) THEN
          CHR = CHAR(IB)
        ELSE
          CHR = 'A'
        ENDIF
        CALL FTSIZC(IHAND,CHR,IXL,IYL,IXH,IYH)
        CALL FTPRNT(IHAND,CHR,IX1,IY1,.TRUE.,0)
        CALL GRSETC(0,0,0,0)
        CALL GRRECT(IXL+IX1,IYL+IY1,IXH+IX1,IYH+IY1,.FALSE.)
        LINE = -1
      ELSEIF(IB.EQ.4) THEN
C          here we have mouse click  
        IF(IAND(LINE,1).EQ.0) THEN
          JUST = 0
        ELSE
          JUST = IXMAX
        ENDIF
        CALL FTFCRT(IHAND,STRING,IX1-IX,JUST,IXOUT,NPC,INDX)
        PRINT *,'Caret after character',NPC
        CALL FTSCRT(IHAND,13,IXOUT+IX,MAXSCR(2)-96*LINE-64)
      ELSE
        LINE = -1
      ENDIF
      GO TO 20
      END
C
      SUBROUTINE FIXCOL
C         to fix colours etc.
      COMMON /SIZES/ MAXSCR(2),MAXPRT(2),ISCL(2),MINY,NCOLR,IHAND
      DIMENSION IBPAL(3),IFPAL(3)
      IF(NCOLR.GE.15) THEN
        CALL FTGETC(IHAND,IBKGD,IFGND,IOFF)
        PRINT *,'Background/''Foreground'' logical colours:',IBKGD,IFGND
        PRINT *,'Extra shades beyond ''foreground'':',IOFF
        CALL KWAIT(.TRUE.)
C      ELSE
        CALL FTGETP(IHAND,IBPAL,IFPAL,IOFF)
        PRINT *,'Background RGB',IBPAL
        PRINT *,'Foreground RGB',IFPAL,', extra shades:',IOFF
        CALL KWAIT(.TRUE.)
      ENDIF
      RETURN
      END
C
      SUBROUTINE LISTC
C         to list the characteristics of the environment
      COMMON /SIZES/ MAXSCR(2),MAXPRT(2),ISCL(2),MINY,NCOLR,IHAND
      DIMENSION MX15(5),IFMX(3),ITHRSH(16)
      CALL FTCACH(ISIZE,IUSED)
      CALL GRVDU(5)
      IY = MAXSCR(2)-32
      CALL GRMOVE(32,IY)
      PRINT *,'Font cache size:',ISIZE,' bytes, of which',
     +         IUSED,' are used'
      DO 20 J=1,3
        IY = IY - 64
        CALL GRVDU(5)
        CALL GRMOVE(32,IY)
        CALL FTRFMX(IFMX(J),MX15)
        PRINT *,'FontMax =',IFMX(J)
        IY = IY - 96
        DO 10 I=1,5
          IX = I*200-180
          CALL GRMOVE (IX,IY+32)
          PRINT 101,I
  101     FORMAT('FontMax',I1)
          CALL GRMOVE (IX,IY-8)
          PRINT 102,MX15(I)
  102     FORMAT(I6)
   10   CONTINUE
        CALL GRVDU(4)
        IF(J.EQ.1) THEN
          PRINT *,'Set FontMax to',ISIZE
          CALL FTWFMX(ISIZE,MX15)
        ELSE IF(J.EQ.2) THEN
          PRINT *,'Reset FontMax to',IFMX(1)
          CALL FTWFMX(IFMX(1),MX15)
        ENDIF
        CALL KWAIT(.FALSE.)
   20 CONTINUE
      CALL PTHRSH(ITHRSH,MTHRSH)
C             in standard 16-colour mode these should be:
C             6, 2, 4, 6, 8, 10, 12, 14, -1
      IF(MTHRSH.EQ.8 .AND. ITHRSH(8).EQ.14 .AND. ITHRSH(1).EQ.6) THEN
        ITHRSH(9) = 15
        ITHRSH(10) = -1
        ITHRSH(1) = 7
        PRINT *,'add an extra threshhold'
        CALL KWAIT(.FALSE.)
        CALL FTSETT(ITHRSH)
        CALL PTHRSH(ITHRSH,MTHRSH)
        PRINT *,'change it back'
        ITHRSH(9) = -1
        ITHRSH(1) = 6
        CALL KWAIT(.FALSE.)
        CALL FTSETT(ITHRSH)
        CALL PTHRSH(ITHRSH,MTHRSH)
      ENDIF
      CALL KWAIT(.TRUE.)
      RETURN
      END
C
      SUBROUTINE LISTF
      COMMON /SIZES/ MAXSCR(2),MAXPRT(2),ISCL(2),MINY,NCOLR,IHAND
      CHARACTER*40 FONTNM
C         print out the available fonts
      NFONTS = 0
      IY = MAXSCR(2)-40
      IX = 0
      MY = (MAXSCR(2)-MINY)/48
      NC1 = 1000
      MIDX = MAXSCR(1)/2
   10 CALL FTLIST(FONTNM)
      IF(FONTNM.NE.' ') THEN
        CALL GRPGET(IX1,IY1,IB)
        IF(IB.EQ.4) THEN
          CALL SKIP
          PRINT 101
          GO TO 45
        ENDIF
        IF(INKEY(0).EQ.27) STOP 'Escape pressed to stop'
        L = LNBLNK(FONTNM)
        CALL FTFIND(FONTNM(1:L),40,40,IHAND)
        IF(IHAND.EQ.0) STOP 'Problem finding font '
        CALL FTPRNT(IHAND,FONTNM(1:L),IX,IY,.FALSE.,0)
C        CALL GRWOG(IX,IY+32,FONTNM(1:L))
        CALL FTLOSE(IHAND)
        NFONTS = NFONTS + 1
        IY = IY - 48
        IF(IY.GE.MINY+48) GO TO 10
        IF(IX.EQ.0) THEN
          IX = MIDX
          IY = MAXSCR(2)-40
          NC1 = NFONTS
          GO TO 10
        ELSE
          CALL SKIP 
        ENDIF
      ENDIF
   30 PRINT 101
  101 FORMAT(' Click with the mouse over the one you want')
   40 CALL GRPBUT(IX1,IY1,IB)
      IF(IB.NE.4) GO TO 40
C         calculate which one it is
   45 NF = (MAXSCR(2)-IY1)/48
      IF(IX1.GT.MIDX) NF = NF + NC1
      IF(NF.GE.NFONTS) GO TO 40
      DO 50 I=0,NF
        CALL FTLIST(FONTNM)
   50 CONTINUE
      CALL SKIP
      CALL GRCLRT
      PRINT 102,FONTNM
  102 FORMAT(' you chose ',A)
C        find font at 24 point (OS units = 60)
      CALL FTFIND(FONTNM,60,60,IHAND)
      CALL KWAIT(.TRUE.)
      RETURN
      END
C
      SUBROUTINE KWAIT(CLEAR)
C        wait for key press
      LOGICAL CLEAR
      CALL GRVDU(4)
      PRINT *,'Press SPACEBAR to continue; ESCAPE to stop'
   10 I = IGET()
      IF(I.EQ.27) STOP
      IF(I.NE.32) GO TO 10
      IF(CLEAR) CALL GRCLRG
      RETURN
      END
C
      SUBROUTINE PTHRSH(ITHRSH,MTHRSH)
C         to read and print the colour threshholds
C         returns the maximum one
      DIMENSION ITHRSH(16)
      CALL FTGETT(ITHRSH)
      DO 10 MTHRSH=1,14
        IF(ITHRSH(MTHRSH+1).LT.0) GO TO 20
   10 CONTINUE
      MTHRSH = 15
   20 PRINT 101,MTHRSH,(ITHRSH(I),I=1,MTHRSH)
  101 FORMAT(I3,' colour threshholds:',16I3)
      RETURN
      END
C
      SUBROUTINE SETUP
C        set up the screen
      COMMON /SIZES/ MAXSCR(2),MAXPRT(2),ISCL(2),MINY,NCOLR,IHAND
C          get screen size
      DO 10 I=1,2
        CALL GRRMV(-1,I+3,ISCL(I))
        CALL GRRMV(-1,I+10,IS)
        MAXSCR(I) = ISHFT(IS+1,ISCL(I))
        CALL GRRMV(-1,I,MAXPRT(I))
   10 CONTINUE
C         get # colours
      CALL GRRMV(-1,3,NCOLR)
C         clear the windows
      CALL GRVDU(26)
C         set up text window of 4 lines at the bottom
      CALL GRTWIN(0,MAXPRT(2),MAXPRT(1),MAXPRT(2)-3)
C         make dark blue background
      CALL GRSETT(256,0,128)
C         make yellow letters 
      CALL GRSETT(255,255,0)
C         clear the text screen
      CALL GRCLRT
C         set up graphics window
      MINY = (4*MAXSCR(2))/(MAXPRT(2)+1)
      CALL GRGWIN(0,MINY,MAXSCR(1)-1,MAXSCR(2)-1)
C         clear the graphics screen
      CALL GRCLRG
      PRINT *,'Graphics screen',0,MINY,' to ',MAXSCR
      CALL KWAIT(.FALSE.)
      CALL GRCLRT
      RETURN
      END
C
      SUBROUTINE SKIP
C            skip to the end of the font list
      CHARACTER*40 FONTNM
   10 CALL FTLIST(FONTNM)
      IF(FONTNM.NE.' ') GO TO 10
      RETURN
      END
