!  ***********************************************
!  ** (c) Interactive Software Services Ltd and **
!  **     Lahey Computer Systems Inc. 1997-2002 **
!  ** ----------------------------------------- **
!  ** This demonstration program source may be  **
!  ** modified for training and for product     **
!  ** familiarisation.                          **
!  ** ----------------------------------------- **
!  ** Purpose : Palette manipulation            **
!  ***********************************************
!
!  This program displays the full Winteracter 256-colour palette on
!  suitable displays. To view the full palette a Windows video driver
!  with more than 256 colours is required. Under a 256 colour video driver
!  128 colours will be used by the colour chart. Only 8 colours will
!  be seen on a 16-colour display.
!
!  This program also demonstrates how the palette can be remapped
!  by filling the screen with a graded grey scale pattern.
!
      PROGRAM COL256
!
      USE WINTERACTER
!
      IMPLICIT NONE
!
      INTEGER, PARAMETER :: IDR_MENU1 = 30001
      INTEGER, PARAMETER :: ID_CHART  = 40001
      INTEGER, PARAMETER :: ID_GREY   = 40002
      INTEGER, PARAMETER :: ID_EXIT   = 40003
!
      INTEGER            :: IPICTURE, ITYPE
      TYPE(WIN_STYLE)    :: WINDOW
      TYPE(WIN_MESSAGE)  :: MESSAGE
!
      INTERFACE
        SUBROUTINE ColourChart()
          IMPLICIT NONE
        END SUBROUTINE ColourChart
        SUBROUTINE GreyScales()
          IMPLICIT NONE
        END SUBROUTINE GreyScales
      END INTERFACE
!
!  Initialise WiSK
!
      CALL WInitialise()
!
!  Open root window. Use a 128-colour palette on a 256-colour display.
!
      CALL WindowOpen(MENUID =IDR_MENU1,                      &
                      TITLE  ='WiSKr 8-bit graphics colours', &
                      NCOL256=128)
!
      IPICTURE = 1
      CALL ColourChart()
!
!  Loop forever until user terminates
!
      DO
        CALL WMessage(ITYPE, MESSAGE)
        SELECT CASE (ITYPE)
!
!  Menu item message
!
          CASE (MenuSelect)
            CALL WindowClear()
            SELECT CASE (MESSAGE%VALUE1)
!
!  Display colour chart
!
              CASE (ID_CHART)
                IPICTURE = 1
                CALL ColourChart()
!
!  Display grey scales
!
              CASE (ID_GREY)
                IPICTURE = 2
                CALL GreyScales()
!
!  Exit program
!
              CASE (ID_EXIT)
                EXIT
            END SELECT
!
!  Redisplay data if we get an expose or resize event
!
          CASE (Expose,Resize)
            IF (IPICTURE==1) THEN
                CALL ColourChart()
            ELSE
                CALL GreyScales()
            END IF
!
!  Close window
!
          CASE (CloseRequest)
            EXIT
        END SELECT
      END DO
!
      CALL WindowClose()
      STOP
      END PROGRAM COL256
!
      SUBROUTINE ColourChart()
!
!  Draw a 256-colour chart
!
      USE WINTERACTER
!
      IMPLICIT NONE
!
      REAL, DIMENSION (4) :: XARRAY, YARRAY
      REAL                :: X, Y
      INTEGER             :: IBORCOL, ICOL, IX, ICOLN
!
!  Reinitialise palette
!
      CALL IGrPaletteInit()
!
!  set fill style to solid
!
      CALL IGrFillPattern(Solid)
!
!  Set border colour
!
      IBORCOL = 96
!
!  Draw labelled rectangles in each available colour
!
      CALL IGrUnits(0.0,0.0,32.0,1.0)
      DO ICOL = 0,255,32
        Y = REAL(ICOL)/256.0
        DO IX = 0,31
          X = REAL(IX)
!
!  Select colour number to give graduated tint on-screen
!
          IF (IX<=15) THEN
              ICOLN = ICOL + IX
          ELSE
              ICOLN = ICOL + IX - 32
              IF (ICOLN<0) ICOLN = ICOLN + 256
          END IF
!
!  Fill a rectangle in the next colour
!
          CALL IGrColourN(ICOLN)
          XARRAY(1) = X
          YARRAY(1) = Y
          XARRAY(2) = X+1.0
          YARRAY(2) = Y
          XARRAY(3) = X+1.0
          YARRAY(3) = Y+0.125
          XARRAY(4) = X
          YARRAY(4) = Y+0.125
          CALL IGrPolygonComplex(XARRAY,YARRAY,4)
!
!  Put a border around each item
!
          CALL IGrColourN(IBORCOL)
          CALL IGrFillPattern(Outline,0,0)
          CALL IGrPolygonComplex(XARRAY,YARRAY,4)
          CALL IGrFillPattern(Solid,0,0)
        END DO
      END DO
      RETURN
      END SUBROUTINE ColourChart
!
      SUBROUTINE GreyScales()
!
!  Use palette handling to display a grey scale from black to white
!
      USE WINTERACTER
!
      IMPLICIT NONE
!
      REAL, DIMENSION (4) :: XARRAY, YARRAY
      REAL                :: Y1,Y2
      INTEGER             :: NCOL,NCOLOURS,IGREY,ICOL,IPOSTPONE
!
!  Reinitialise palette
!
      CALL IGrPaletteInit()
!
!  set fill style to solid
!
      CALL IGrFillPattern(Solid)
!
!  How many colours available ?
!
      NCOLOURS = InfoGrScreen(30)
!
!  Redefine palette with NCOLOURS grey scales
!
      IPOSTPONE = 1
      DO NCOL = 0,NCOLOURS-1
        ICOL  = (256/NCOLOURS)*NCOL
        IGREY = (255*NCOL)/(NCOLOURS-1)
        IF (NCOL==NCOLOURS-1) IPOSTPONE = 0
        CALL IGrPalette(ICOL,WRGB(IGREY,IGREY,IGREY),IPOSTPONE)
      END DO
!
!  Draw grey rectangles
!
      CALL IGrUnits(0.0,0.0,1.0,REAL(NCOLOURS))
      DO NCOL = 0,NCOLOURS-1
        ICOL = (256/NCOLOURS)*NCOL
        CALL IGrColourN(ICOL)
        Y1   = REAL(NCOL)
        Y2   = REAL(NCOL+1)
        XARRAY(1) = 0.0
        YARRAY(1) = Y1
        XARRAY(2) = 1.0
        YARRAY(2) = Y1
        XARRAY(3) = 1.0
        YARRAY(3) = Y2
        XARRAY(4) = 0.0
        YARRAY(4) = Y2
        CALL IGrPolygonComplex(XARRAY,YARRAY,4)
      END DO
      RETURN
      END SUBROUTINE GreyScales