!  ***********************************************
!  ** (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 : Graphical input                 **
!  ***********************************************
!
!  This program demonstrates the use of graphical input (GIN) with
!  Winteracter. All input messages are returned by WMessage/WMessagePeek
!  and processed by a CASE statement. GIN applications will mainly be
!  concerned with mouse button up, down and movement events. By default
!  button up and mouse movement events are disabled so WMessageEnable
!  must be used to turn them on.
!
!  This program also demonstrates the use of the 'rubber banding' technique
!  employed by numerous drawing packages. This is achieved by using
!  exclusive-or plotting mode. By drawing an object twice we can remove it
!  from the screen without distorting any other previously drawn objects.
!
  PROGRAM GIN
!
  USE WINTERACTER
  IMPLICIT NONE
!
!  Resource identifiers, as set via the resource editor
!
  INTEGER, PARAMETER :: IDD_DIALOG1  =   101
  INTEGER, PARAMETER :: IDC_PEN      =  2001
  INTEGER, PARAMETER :: IDC_LINE     =  2002
  INTEGER, PARAMETER :: IDC_OUTLINE  =  2003
  INTEGER, PARAMETER :: IDC_RECTANGLE=  2004
  INTEGER, PARAMETER :: IDR_MENU1    = 30001
  INTEGER, PARAMETER :: ID_PEN       = 40001
  INTEGER, PARAMETER :: ID_LINE      = 40002
  INTEGER, PARAMETER :: ID_OUTLINE   = 40003
  INTEGER, PARAMETER :: ID_RECTANGLE = 40004
  INTEGER, PARAMETER :: ID_CLEAR     = 40005
  INTEGER, PARAMETER :: ID_HELP      = 40006
  INTEGER, PARAMETER :: ID_EXIT      = 40007
  INTEGER, PARAMETER :: ID_RED       = 40011
  INTEGER, PARAMETER :: ID_MAGENTA   = 40016
!
  TYPE(WIN_MESSAGE)                               :: MESSAGE
  INTEGER                                         :: ITYPE,IDRAW,IDOWN,ICOLID,IR,IG,IB
  INTEGER          , DIMENSION(ID_RED:ID_MAGENTA) :: ICOLTABLE = (/RGB_RED,    &
                                                                   RGB_YELLOW, &
                                                                   RGB_GREEN,  &
                                                                   RGB_CYAN,   &
                                                                   RGB_BLUE,   &
                                                                   RGB_MAGENTA/)
  REAL                                            :: XPOS,YPOS,XOLD,YOLD
  INTEGER          , DIMENSION(2)                 :: WIDTHS
  CHARACTER(LEN=3)                                :: RTEXT,GTEXT,BTEXT
  CHARACTER(LEN=11), DIMENSION(4)                 :: TOOLTYPE = (/'Pen        ', &
                                                                  'Line       ', &
                                                                  'Outline Box', &
                                                                  'Filled Box '/)
!
! Initialise Winteracter and open the root window
!
  CALL WInitialise()
  CALL WindowOpen(FLAGS =SysMenuOn+MinButton+MaxButton+StatusBar, &
                  MENUID=IDR_MENU1,                               &
                  TITLE ='Graphics Input')
!
  CALL WCursorShape(IDC_PEN)
!
! Select 24-bit colour model. Not strictly necessary, but makes
! colour table initialisation (above) easier to understand.
!
  CALL IGrColourModel(24)
!
!  Set default pen colour to something other than black, since black
!  XOR'd with any colour gives the other colour on most display.
!  i.e. rubber banding when black is selected is not visible.
!
  ICOLID = ID_MAGENTA
  CALL IGrColourN(ICOLTABLE(ICOLID))
!
!  Initialise display
!
  CALL IGrAreaClear()
!
!  Set initial values
!
  IDRAW = ID_PEN
  IDOWN = 0
  CALL WMenuSetState(ID_PEN,ItemChecked,Enabled)
!
!  Set up status bar to shown current colour (RGB triplet) and tool type
!
  WIDTHS(1) = 3500
  WIDTHS(2) = 1000
  CALL WindowStatusBarParts(2,WIDTHS)
  CALL WindowOutStatusBar(1,'Pen Colour : Red (255) Green (  0) Blue (255)')
  CALL WindowOutStatusBar(2,TOOLTYPE(1))
!
! Main message loop
!
  DO                                 ! Loop until user terminates
    CALL WMessage(ITYPE,MESSAGE)
    SELECT CASE (ITYPE)
!
!  Get menu/accelerator input from user
!
      CASE (MenuSelect)
        SELECT CASE (MESSAGE%VALUE1)
!
!  If the user selects Exit, break out of the main loop
!
          CASE (ID_EXIT)
            EXIT
!
!  If the user selects Clear, re-initialise the display
!
          CASE (ID_CLEAR)
            CALL IGrAreaClear()
            CALL IGrPlotMode()
!
!  If the user selects a drawing tool, update the menu check mark
!  and the status bar
!
          CASE (ID_PEN,     &
                ID_LINE,    &
                ID_OUTLINE, &
                ID_RECTANGLE)
            SELECT CASE (MESSAGE%VALUE1)
              CASE (ID_PEN)
                CALL WCursorShape(IDC_PEN)
              CASE (ID_LINE)
                CALL WCursorShape(IDC_LINE)
              CASE (ID_OUTLINE)
                CALL WCursorShape(IDC_OUTLINE)
              CASE (ID_RECTANGLE)
                CALL WCursorShape(IDC_RECTANGLE)
            END SELECT
            CALL WMenuSetState(IDRAW,ItemChecked,Disabled)
            IDRAW = MESSAGE%VALUE1
            CALL WMenuSetState(IDRAW,ItemChecked,Enabled)
            CALL WindowOutStatusBar(2,TOOLTYPE((MESSAGE%VALUE1-ID_PEN)+1))
!
!  If the user selects the Colour option, change the drawing colour,
!  update menu check marker and Update the status bar
!
          CASE (ID_RED : ID_MAGENTA)
            CALL WMenuSetState(ICOLID,ItemChecked,Disabled)
            ICOLID = MESSAGE%VALUE1
            CALL WMenuSetState(ICOLID,ItemChecked,Enabled)
            CALL IGrColourN(ICOLTABLE(ICOLID))
            CALL WRGBsplit(ICOLTABLE(ICOLID),IR,IG,IB)
            CALL IntegerToString(IR,RTEXT,'(I3)')
            CALL IntegerToString(IG,GTEXT,'(I3)')
            CALL IntegerToString(IB,BTEXT,'(I3)')
            CALL WindowOutStatusBar(1,'Pen Colour : Red ('//RTEXT//') Green ('//GTEXT//') Blue ('//BTEXT//')')
!
!  If the user selects the about option, load the About dialog from
!  the resource, display it and wait until the OK button is pressed
!
          CASE (ID_HELP)
            CALL WDialogLoad(IDD_DIALOG1)
            CALL WDialogShow(ITYPE=Modal)
            CALL WDialogUnload()
        END SELECT
!
!  Mouse button down - only process mouse button 1 events
!
      CASE (MouseButDown)
        IF (MESSAGE%VALUE1 == 1) THEN
!
!  Enable button up and mouse movement events
!
          CALL WMessageEnable(MouseButUp,Enabled)
          CALL WMessageEnable(MouseMove ,Enabled)
          IDOWN = 1
!
!  Save the current cursor position
!
          XPOS  = MESSAGE%GX
          YPOS  = MESSAGE%GY
          SELECT CASE (IDRAW)
!
!  For pen plotting just draw the current point
!
            CASE (ID_PEN)
              CALL IGrPoint(MESSAGE%GX,MESSAGE%GY)
!
!  For line plotting we must initialise Exclusive-OR plotting,
!  draw the initial line and save the end of line co-ordinates
!
            CASE (ID_LINE)
              CALL IGrPlotMode(ModeXor)
              CALL IGrMoveTo(XPOS,YPOS)
              CALL IGrLineTo(MESSAGE%GX,MESSAGE%GY)
              XOLD = MESSAGE%GX
              YOLD = MESSAGE%GY
!
!  For box plotting we must initialise Exclusive-OR plotting,
!  set the fill type, draw the initial box and save the corner
!  co-ordinates
!
            CASE (ID_RECTANGLE,ID_OUTLINE)
              CALL IGrPlotMode(ModeXor)
              IF (IDRAW == ID_RECTANGLE) THEN
                  CALL IGrFillPattern(Solid)
              ELSE
                  CALL IGrFillPattern(Outline)
              END IF
              CALL Rectangle(XPOS,YPOS,MESSAGE%GX,MESSAGE%GY)
              XOLD = MESSAGE%GX
              YOLD = MESSAGE%GY
          END SELECT
        END IF
!
!  Mouse Movement
!
      CASE (MouseMove)
        IF (IDOWN == 1) THEN
          SELECT CASE (IDRAW)
!
!  For pen plotting we simply join the current mouse position to the
!  previous mouse position and update the co-ordintates
!
             CASE (ID_PEN)
               CALL IGrMoveTo(XPOS,YPOS)
               CALL IGrLineTo(MESSAGE%GX,MESSAGE%GY)
               XPOS = MESSAGE%GX
               YPOS = MESSAGE%GY
!
!  For line plotting, redraw the last line to erase it.
!  Then update the co-ordinates and draw the new line.
!
             CASE (ID_LINE)
               CALL IGrMoveTo(XPOS,YPOS)
               CALL IGrLineTo(XOLD,YOLD)
               XOLD = MESSAGE%GX
               YOLD = MESSAGE%GY
               CALL IGrMoveTo(XPOS,YPOS)
               CALL IGrLineTo(MESSAGE%GX,MESSAGE%GY)
!
!  For rectangle plotting, redraw the last box to erase it.
!  Then update the co-ordinates and draw the new rectangle.
!
             CASE (ID_RECTANGLE, &
                   ID_OUTLINE)
               CALL Rectangle(XPOS,YPOS,XOLD,YOLD)
               XOLD = MESSAGE%GX
               YOLD = MESSAGE%GY
               CALL Rectangle(XPOS,YPOS,MESSAGE%GX,MESSAGE%GY)
          END SELECT
        END IF
!
!  Mouse button up - only process mouse button one events
!
      CASE (MouseButUp)
        IF (MESSAGE%VALUE1 == 1) THEN
!
!  Disable movement and button up events
!
           IDOWN = 0
           CALL WMessageEnable(MouseButUp,Disabled)
           CALL WMessageEnable(MouseMove ,Disabled)
           SELECT CASE (IDRAW)
!
!  For line plotting, first erase the last line drawn by redrawing it.
!  Then turn exclusive-OR mode off and plot our final line.
!
            CASE (ID_LINE)
              CALL IGrMoveTo(XPOS,YPOS)
              CALL IGrLineTo(XOLD,YOLD)
              CALL IGrPlotMode()
              CALL IGrMoveTo(XPOS,YPOS)
              CALL IGrLineTo(MESSAGE%GX,MESSAGE%GY)
!
!  For rectangle plotting, first erase the last box drawn by redrawing it.
!  Then turn exclusive-OR mode off and plot our final rectangle.
!
             CASE (ID_RECTANGLE, &
                   ID_OUTLINE)
              CALL Rectangle(XPOS,YPOS,XOLD,YOLD)
              CALL IGrPlotMode()
              CALL Rectangle(XPOS,YPOS,MESSAGE%GX,MESSAGE%GY)
          END SELECT
        END IF
!
!  Resize window
!
      CASE (Resize)
        CALL IGrAreaClear()
        CALL IGrPlotMode()
!
!  Window exposed
!
      CASE (Expose)
        CALL IGrAreaClear()
        IF (IDOWN == 1) THEN
            CALL IGrPlotMode(ModeXor)
        ELSE
            CALL IGrPlotMode()
        END IF
!
! Close
!
      CASE (CloseRequest)            ! Exit main loop
        EXIT
    END SELECT
  END DO
  CALL WindowClose()                 ! Remove program window
  STOP
!
  CONTAINS
!
  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 GIN