!  ***********************************************
!  ** (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 : Hiding the root window          **
!  ***********************************************
!
!  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.
!
!  In particular, this program 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 of the WINTERACTER module is compulsory
!
  USE WINTERACTER
!
  IMPLICIT NONE
!
!  Define the symbols used to represent menu options
!
  INTEGER, PARAMETER :: IDD_DIALOG1  =   101
  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
!
! Declare window-type and message variables
!
  TYPE(WIN_STYLE)    :: WINDOW
  TYPE(WIN_MESSAGE)  :: MESSAGE
  INTEGER            :: ITOOL,IDOWN,ITYPE,ICOLID
  INTEGER            :: COLTABLE(ID_RED:ID_MAGENTA) = (/32,64,96,128,160,192/)
  REAL               :: XPOS,YPOS,XOLD,YOLD
  CHARACTER(LEN=11)  :: TOOLTYPE(4) = (/'Pen        ', &
                                        'Line       ', &
                                        'Outline Box', &
                                        'Filled Box '/)
!
  INTERFACE
     SUBROUTINE Rectangle(X1,Y1,X2,Y2)
     IMPLICIT NONE
     REAL, INTENT(IN) :: X1,Y1,X2,Y2
     END SUBROUTINE Rectangle
  END INTERFACE
!
! Initialise Winteracter and open root window
!
  CALL WInitialise()
  CALL WindowOpen(FLAGS =SysMenuOn+MinButton+MaxButton+StatusBar, &
                  MENUID=IDR_MENU1,                               &
                  TITLE ='Graphics Input')
!
!  Set default pen colour
!
  ICOLID = ID_RED
  CALL IGrColourN(COLTABLE(ICOLID))
!
!  Clear graphics area
!
  CALL IGrAreaClear()
!
  CALL IGrPlotMode('N')
  ITOOL = ID_PEN
  IDOWN = 0
  CALL WMenuSetState(ID_PEN,ItemChecked,WintOn)
  CALL WindowOutStatusBar(1,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 select exit then break out of the main loop
!
          CASE (ID_EXIT)
            EXIT
!
!  If the user selects clear then re-initialise the display
!
          CASE (ID_CLEAR)
            CALL IGrAreaClear()
            CALL IGrPlotMode('N')
!
!  If the user selects a drawing tool then update the menu check mark
!  and the status bar
!
          CASE (ID_PEN,ID_LINE,ID_OUTLINE,ID_RECTANGLE)
            CALL WMenuSetState(ITOOL,ItemChecked,WintOff)
            ITOOL = MESSAGE%VALUE1
            CALL WMenuSetState(ITOOL,ItemChecked,WintOn)
            CALL WindowOutStatusBar(1,TOOLTYPE((MESSAGE%VALUE1-ID_PEN)+1))
!
!  If the user selected the about option then we load the 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()
!
!  Change drawing colour & update menu check marker
!
          CASE (ID_RED : ID_MAGENTA)
            CALL WMenuSetState(ICOLID,ItemChecked,WintOff)
            ICOLID = MESSAGE%VALUE1
            CALL WMenuSetState(ICOLID,ItemChecked,WintOn)
            CALL IGrColourN(COLTABLE(ICOLID))
        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 (ITOOL)
!
!  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('E')
              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('E')
              IF (ITOOL==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 (ITOOL)
!
!  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 we must redraw the last line to erase it from the
!  screen. We 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 we must redraw the last box to erase it from the
!  screen. We 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
!
!  We disable movement and button up events
!
           IDOWN = 0
           CALL WMessageEnable(MouseButUp,Disabled)
           CALL WMessageEnable(MouseMove ,Disabled)
           SELECT CASE (ITOOL)
!
!  For line plotting we must first erase the last line drawn by redrawing
!  it. Then we turn exclusive-OR mode off and plot our final line.
!
            CASE (ID_LINE)
              CALL IGrMoveTo(XPOS,YPOS)
              CALL IGrLineTo(XOLD,YOLD)
              CALL IGrPlotMode('N')
              CALL IGrMoveTo(XPOS,YPOS)
              CALL IGrLineTo(MESSAGE%GX,MESSAGE%GY)
!
!  For rectangle plotting we must first erase the last box drawn by redrawing
!  it. Then we turn exclusive-OR mode off and plot our final rectangle.
!
            CASE (ID_RECTANGLE, ID_OUTLINE)
              CALL Rectangle(XPOS,YPOS,XOLD,YOLD)
              CALL IGrPlotMode('N')
              CALL Rectangle(XPOS,YPOS,MESSAGE%GX,MESSAGE%GY)
          END SELECT
        END IF
!
! Close
!
      CASE (CloseRequest)            ! Exit main loop
        EXIT
!
!  Resize or expose event
!
      CASE (Resize, Expose)          ! Re-initialise display
        CALL IGrAreaClear()
        CALL IGrPlotMode('N')
    END SELECT
  END DO
  CALL WindowClose()                 ! Remove program window
  STOP
  END PROGRAM GIN
!
  SUBROUTINE Rectangle(X1,Y1,X2,Y2)
!
!  Draw a filled or outline rectangle at the specified co-ordinates
!
  USE WINTERACTER
!
  IMPLICIT NONE
  REAL, INTENT (IN) :: X1,Y1,X2,Y2
!
  CALL IGrPolygonComplex((/X1,X2,X2,X1/),(/Y1,Y1,Y2,Y2/),4)
  RETURN
  END SUBROUTINE Rectangle