!  ***********************************************
!  ** (c) Interactive Software Services Ltd and **
!  **     Lahey Computer Systems Inc. 1997-2011 **
!  ** ----------------------------------------- **
!  ** This demonstration program source may be  **
!  ** modified for training and for product     **
!  ** familiarisation.                          **
!  ** ----------------------------------------- **
!  ** Purpose : Direct 24-bit colour control    **
!  ***********************************************
!
!  This program demonstrates the use of direct 24-bit colour
!  specification, as enabled by IGrColourModel(24). When this
!  colour model is enabled, colours specified to IGrColourN
!  represent a 24-bit RGB value encoded as:
!
!     RED + 256*GREEN + 256*256*BLUE
!
!  Theoretically, this allows direct access to 16 million different
!  colours simultaneously, compared to Winteracter's conventional 8-bit
!  palette which provides up to 256 simultaneous colours from the same
!  16 million colours. In practice, only certain displays support 24-bit
!  colour, so WInfoGrDriver(42) reports the ability of the current display
!  to take full advantage of 24-bit colour specification.
!
!  The 24-bit colour model can still be used on lower spec
!  (e.g. 8-bit colour) displays, but Winteracter then has to
!  select the 'nearest' colour in its own 8-bit colour palette.
!  While this works well under many conditions, it is less
!  predictable than specifying an 8-bit colour number directly.
!
      PROGRAM COL24BIT
!
      USE WINTERACTER
      IMPLICIT NONE
!
      TYPE(WIN_MESSAGE) :: MESSAGE
      INTEGER           :: ITYPE
!
!  Initialise Winteracter
!
      CALL WInitialise()
!
!  Open root window (use 128 colour palatte on a 256 colour display)
!
      CALL WindowOpen(TITLE='24-bit colour',NCOL256=128)
!
!  Check state of 24-bit colour support on current display
!
      IF (WInfoGrDriver(Col24Bits)==0) &
          CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,                 &
            'True 24-bit colour control is not available in the current '// &
            'video mode. Colour selection will therefore be limited.',      &
            '24-bit Colour Demo : Warning')
!
      CALL DrawColours()
!
!  Loop forever until user terminates
!
      DO
        CALL WMessage(ITYPE,MESSAGE)
        SELECT CASE (ITYPE)
!
!  Redisplay plot if we get an expose or resize event
!
          CASE (Expose,Resize)
              CALL DrawColours()
!
!  Close window
!
          CASE (CloseRequest)
              EXIT
        END SELECT
      END DO
!
      CALL WindowClose()
      STOP
!
      CONTAINS
!
      SUBROUTINE DrawColours()
      IMPLICIT NONE
      INTEGER :: ISTEP,IR,IG,IB
      REAL    :: X1,Y1,X2,Y2
!
!  Clear window in case this routine is being called
!  in response to a Resize or Expose message
!
      CALL IGrArea(0.0,0.0,1.0,1.0)
      CALL IGrAreaClear()
!
!  Set graphics units to match 0-255 RGB range
!
      CALL IGrUnits(0.0,0.0,256.,256.)
!
!  Solid fills
!
      CALL IGrFillPattern(Solid)
      ISTEP = 4
!
!  Select 24-bit colour model
!
      CALL IGrColourModel(24)
!
!  Draw a string in red
!
      CALL IGrColourN(RGB_RED)
      CALL WGrTextString(64.,192.,'24-bit Colour')
!
!  Red/Green combinations
!
      CALL IGrArea(0.05,0.05,0.48,0.48)
      DO IR = 0,255,ISTEP
        DO IG = 0,255,ISTEP
          CALL IGrColourN(WRGB(IR,IG,0))
          X1 = IR
          X2 = IR + ISTEP
          Y1 = IG
          Y2 = IG + ISTEP
          CALL Rectangle(X1,Y1,X2,Y2)
        END DO
      END DO
!
!  Red/Blue combinations
!
      CALL IGrArea(0.52,0.05,0.95,0.48)
      DO IR = 0,255,ISTEP
        DO IB = 0,255,ISTEP
          CALL IGrColourN(WRGB(IR,0,IB))
          X1 = IR
          X2 = IR + ISTEP
          Y1 = IB
          Y2 = IB + ISTEP
          CALL Rectangle(X1,Y1,X2,Y2)
        END DO
      END DO
!
!  Green/Blue combinations
!
      CALL IGrArea(0.52,0.52,0.95,0.95)
      DO IG = 0,255,ISTEP
        DO IB = 0,255,ISTEP
          CALL IGrColourN(WRGB(0,IG,IB))
          X1 = IG
          X2 = IG + ISTEP
          Y1 = IB
          Y2 = IB + ISTEP
          CALL Rectangle(X1,Y1,X2,Y2)
        END DO
      END DO
      RETURN
      END SUBROUTINE DrawColours
!
      SUBROUTINE Rectangle(X1,Y1,X2,Y2)
!
!  Draw a filled or outline rectangle at the specified co-ordinates
!
      IMPLICIT NONE
      REAL, INTENT (IN) :: X1,Y1,X2,Y2
!
      CALL IGrPolygonComplex((/X1,X2,X2,X1/),(/Y1,Y1,Y2,Y2/),4)
      RETURN
      END SUBROUTINE Rectangle
!
      END PROGRAM COL24BIT