      PROGRAM TWIMP6
C        a  Fortran wimp program to test more text icon functions
C         and caret functions.
C        needs the Wimp, Font and SpriteOp libraries
C        (this program is not into testing the spriteop routines,
C          so they are called as subroutines to simplify the logic).
C
      COMMON /HANDLE/IWH,IHS,IHR,IHB,IHG,IHTXT1,IHTXT2,ICARET,IDEL,IFONT
C
C        initialise the wimp
      CALL WPINIT('TWIMP6')
C        set up the desk-top
      CALL SETUP
C        go into the wimp loop (without null calls)
      CALL WPLOOP(1)
C        at the end we must 'lose' the font we found
      CALL FTLOSE(IFONT)
      END
C
      SUBROUTINE SETUP
C        here we make the windows and icons
C        keep their handles in common
      COMMON /HANDLE/IWH,IHS,IHR,IHB,IHG,IHTXT1,IHTXT2,ICARET,IDEL,IFONT
C        space for four indirected text icons
      CHARACTER ICTXT1*28,ICTXT2*28,CARET*11,FONT*28
      COMMON /ICTEXT/ ICTXT1,ICTXT2,CARET,FONT
C            space for sprite area
      COMMON /SPAREA/IBSPR(1000)
C            initialise user sprite area
      CALL SPINIT(1000,IBSPR)
C            prepare the window to receive sprites from our area
      CALL WPCHSA(IBSPR)
C        make the window, but with cyan background
      CALL WPCHWC(3,15)
C        and without a 'close' and 'back' icon
      CALL WPCHWF(25,.FALSE.)
      CALL WPCHWF(24,.FALSE.)
      CALL WPMKNW(640,464,200,200,640,464,0,0,'Icon tests',IWH)
C        make an icon to stop the program
      CALL WPADTI(IWH,40,-80,96,48,'Stop',0,IHS)
C        make all following icons ESG 2
      CALL WPCHTF(202)
C        make a red background icon
      CALL WPCHTC(1,11)
C        with white text
      CALL WPCHTC(0,0)
      CALL WPADTI(IWH,40,-140,96,48,'Red',0,IHR)
C        make a blue background icon
      CALL WPCHTC(1,8)
      CALL WPADTI(IWH,40,-200,96,48,'Blue',0,IHB)
C        make a green background icon
      CALL WPCHTC(1,10)
      CALL WPADTI(IWH,40,-260,96,48,'Green',0,IHG)
C        make a sprite
      CALL MAKESP
C          remove ESG
      CALL WPCHTF(200)
C          make text icon in trinity medium font
      CALL FTFIND('Trinity.Medium',40,40,IFONT)
      CALL WPCHFT(IFONT)
      FONT = 'Trinity.Medium font - Ugh!'//CHAR(0)
      CALL WPADTI(IWH,64,-448,512,48,FONT,0,I)
C          change colours to black on white 
      CALL WPCHTC(0,7)
      CALL WPCHTC(1,0)
C          make icons unselectable
      CALL WPCHTF(103)
C        make an icon to delete
      CALL WPADTI(IWH,400,-360,112,48,'Delete',0,IDEL)
C          make indirected icon
      CALL WPCHTF(8,.TRUE.)
C        'null' terminate the indirected text
      ICTXT1='Type into the icon below'//CHAR(0)
      CALL WPADTI(IWH,160,-200,400,48,ICTXT1,0,IHTXT1)
C        make caret flag icon
      CARET='No caret'//CHAR(0)
      CALL WPADTI(IWH,320,-120,176,48,CARET,0,ICARET)
C        make writeable icons
      CALL WPCHTF(115)
      ICTXT2=CHAR(0)
      CALL WPADTI(IWH,160,-280,400,48,ICTXT2,0,IHTXT2)
C        open the window
      CALL WPOPNW(IWH)
      RETURN
      END
C
      SUBROUTINE MAKESP
      COMMON /HANDLE/IWH,IHS,IHR,IHB,IHG,IHTXT1,IHTXT2,ICARET,IDEL,IFONT
C            sprite area
      COMMON /SPAREA/IBSPR(1000)
C               make up a sprite in mode 12
      CALL SPRESV(IBSPR,'spr_mine',0,34,17,12)
C               now put in the pixels using colours 0 to 15
      DO 20 IY = 0, 16
        DO 10 IX = 0, 16
          CALL SPWPIX(IBSPR,'spr_mine',IX*2,IY,MOD(IX+IY,16),0)
          CALL SPWPIX(IBSPR,'spr_mine',IX*2+1,IY,MOD(IX+IY,16),0)
   10   CONTINUE
   20 CONTINUE
C            insert sprite in window with ESG 2 (same as colour icons)
      CALL WPCHSF(202)
      CALL WPADSI(IWH,200,-120,'spr_mine',ICS)
      RETURN
      END
C
      SUBROUTINE WQCLIK(IWHAN,ICONH,IX,IY,IBUTT)
C         here we receive a mouse button click
      COMMON /HANDLE/IWH,IHS,IHR,IHB,IHG,IHTXT1,IHTXT2,ICARET,IDEL,IFONT
C         stop the program when 'stop' clicked
      IF(ICONH .EQ. IHS) THEN
        CALL WPQUIT
        RETURN
      ENDIF
      IF(ICONH .GT. 0) THEN
C         if click over colour or sprite icon,
C         force a redraw to print the text
        IF(ICONH .LE. 4) CALL WPPLOT(IWHAN, 0, -400, 400, -280)
C         delete the 'Delete' icon
        IF(ICONH .EQ. IDEL) CALL WPDELI(IWHAN,ICONH)
      ENDIF
      RETURN
      END
C
      SUBROUTINE WQPLOT(IWHAN,IX1,IY1,IX2,IY2)
C         to draw text in the window
      LOGICAL SET
      CHARACTER*6 COLOUR(4)
      DATA COLOUR/'Red','Blue','Green','Sprite'/
C            space to store list of selected icons
      DIMENSION LIST(10)
C            make list of selected icons
      CALL WPGTIL(IWHAN,21,LIST,NLIST)
C            write message if one icon is selected
      IF(NLIST .GE. 1) THEN
        IF(LIST(1).LE.4) CALL WPTEXT(8,-320,'Icon is '//COLOUR(LIST(1)))
C            find first flag set
        INDEX=0
   10   CALL WPGTIF(IWHAN,LIST(1),INDEX,SET)
        IF(.NOT.SET) THEN
          INDEX = INDEX + 1
          GO TO 10
        ENDIF
        CALL WPTEXT(8,-360,'First flag set is '//CHAR(INDEX+48))
      ENDIF
      RETURN
      END
C
      SUBROUTINE WQKEYP(IWHAN,ICONH,IX,IY,ICIND,KEY)
C             called when a special key is pressed
C             in window IWHAN
C             over icon ICONH
C             at (IX,IY)
C             with the caret at position ICIND
C             ASCII code of key in KEY
      COMMON /HANDLE/IWH,IHS,IHR,IHB,IHG,IHTXT1,IHTXT2,ICARET,IDEL,IFONT
C        space for three indirected text icons
      CHARACTER ICTXT1*28,ICTXT2*28,CARET*11
      COMMON /ICTEXT/ ICTXT1,ICTXT2,CARET
      IF(IWHAN.NE.IWH .OR. ICONH.NE.IHTXT2 .OR. KEY.NE.13) THEN
C            if we don't accept this key press...
        CALL WPKEYP(KEY)
      ELSE
C            get caret position (we actually have this already in ICIND)
        CALL WPGTCP(IWHAN,ICONH,ICP)
C            print position of caret
        WRITE(ICTXT1,101)ICP,CHAR(0)
  101   FORMAT('Caret was at position',I3,A1)
C            deselect the icon (to force a redraw)
        CALL WPSTIF(IWHAN,IHTXT1,21,.FALSE.)
C            Put caret at beginning
        CALL WPSTCP(IWHAN,ICONH,0)
      ENDIF
      RETURN
      END
C
      SUBROUTINE WQLGCT(GAIN,IWBLK)
C           this routine is called if we gain or lose the caret
      DIMENSION IWBLK(6)
      LOGICAL GAIN
      COMMON /HANDLE/IWH,IHS,IHR,IHB,IHG,IHTXT1,IHTXT2,ICARET,IDEL,IFONT
C        space for four indirected text icons
      CHARACTER ICTXT1*28,ICTXT2*28,CARET*11,FONT*28
      COMMON /ICTEXT/ ICTXT1,ICTXT2,CARET,FONT
C        set up text according to whether we gain or lose the caret
      IF(GAIN) THEN
        CARET='Gain Caret'//CHAR(0)
      ELSE
        CARET='Lose Caret'//CHAR(0)
      ENDIF
C            deselect the icon (to force a redraw)
      CALL WPSTIF(IWH,ICARET,21,.FALSE.)
      RETURN
      END
