!  ********************************************************************
!  * This program is one of a set of demonstration programs which     *
!  * illustrate the use of the OpenGL graphics library in combination *
!  * with the Winteracter Fortran 9x user-interface/graphics toolset. *
!  *                                                                  *
!  * This demonstration program is freely distributable.              *
!  *                                                                  *
!  * Winteracter contact information:                                 *
!  * email : help@winteracter.com                                     *
!  * web   : www.winteracter.com                                      *
!  *                                                                  *
!  * This program USE's a Fortran 9x module called OPENGL.            *
!  * This was derived from f90gl which was written by:                *
!  *   William F. Mitchell                                            *
!  *   Mathematical and Computational Sciences Division               *
!  *   National Institute of Standards and Technology                 *
!  *   Gaithersburg, MD 20899, USA                                    *
!  *                                                                  *
!  * OpenGL is a trademark of Silicon Graphics Inc.                   *
!  *                                                                  *
!  ********************************************************************
!
      MODULE SELECT_MOD
!
! Global variables
!
      USE WINTERACTER
      USE OPENGL
!
      IMPLICIT NONE
!
! Current viewport/window data
!
      INTEGER            :: IWWIDTH  = 400     ! Window width
      INTEGER            :: IWHEIGHT = 400     ! Window height
      LOGICAL            :: fillpoly = .TRUE.  ! Draw filled polygons
!
! Object information
!
      TYPE :: SELOBJ
          REAL(glfloat)  :: VERTEX1(2)         ! Vertex information
          REAL(glfloat)  :: VERTEX2(2)
          REAL(glfloat)  :: VERTEX3(2)
          REAL(glfloat)  :: COLOUR(3)          ! Colour information
      END TYPE SELOBJ
!
      INTEGER, PARAMETER :: IMAXOBJ  = 10      ! Maximum number of objects
      INTEGER            :: IOBJNUM  = IMAXOBJ ! Number of generated objects
      TYPE(SELOBJ)       :: OBJECT(IMAXOBJ)    ! Object information
!
! Display info
!
      REAL(glfloat)      :: RZOOM    =  1.0    ! Zoom factor
      REAL(glfloat)      :: RZROTATE = 90.0
!
! Mouse button binding lookup
!
      INTEGER            :: IMOUSEBUT(3) = (/1,2,3/) ! Mouse button functions
!
! Resource definitions :
!
      INTEGER, PARAMETER :: IDR_MENU1   = 30001
      INTEGER, PARAMETER :: ID_EXIT     = 40001
      INTEGER, PARAMETER :: ID_FILL     = 40009
      INTEGER, PARAMETER :: ID_LCOLOUR  = 40012
      INTEGER, PARAMETER :: ID_LDELETE  = 40013
      INTEGER, PARAMETER :: ID_LGROW    = 40014
      INTEGER, PARAMETER :: ID_MCOLOUR  = 40015
      INTEGER, PARAMETER :: ID_MDELETE  = 40016
      INTEGER, PARAMETER :: ID_MGROW    = 40017
      INTEGER, PARAMETER :: ID_RCOLOUR  = 40018
      INTEGER, PARAMETER :: ID_RDELETE  = 40019
      INTEGER, PARAMETER :: ID_RGROW    = 40020
      END MODULE SELECT_MOD
!
!*****************************************************************************
!
      PROGRAM SELECT
!
! Example of selection using the mouse in OpenGL
!
      USE SELECT_MOD
!
      IMPLICIT NONE
!
      INTEGER           :: ITYPE
      TYPE(WIN_MESSAGE) :: MESSAGE
!
!  Initialise Winteracter.
!
      CALL WInitialise()
!
!  Open root window.
!
      CALL WindowOpen(FLAGS=SysMenuOn+MinButton+MaxButton+StatusBar,  &
                      WIDTH=IWWIDTH,HEIGHT=IWHEIGHT,MENUID=IDR_MENU1, &
                      TITLE='Mouse Selection')
!
! Initialise checked menu options
!
      CALL WMenuSetState(ID_LCOLOUR+IMOUSEBUT(1)-1,ItemChecked,WintOn)
      CALL WMenuSetState(ID_MCOLOUR+IMOUSEBUT(2)-1,ItemChecked,WintOn)
      CALL WMenuSetState(ID_RCOLOUR+IMOUSEBUT(3)-1,ItemChecked,WintOn)
!
      IF (fillpoly) CALL WMenuSetState(ID_FILL,ItemChecked,WintOn)
!
!  Display prompt in status bar
!
      CALL WindowOutStatusBar(1,"Use the cursor keys or click on a triangle")
!
!  Check screen colour depth.
!  OpenGL doesn't work well on 16-colour displays
!
      IF (WInfoScreen(ScreenColours)<=16)                  &
          CALL WMessageBox(OKOnly,InformationIcon,CommonOK,  &
            'Your video driver is configured'//CHAR(13)//    &
            'for 16 colours or less.'//CHAR(13)//            &
            'For best results run in a higher colour mode.', &
            'Limited Colour Warning')
!
!  Initialise Open-GL
!
      CALL WglSelect(1)
!
!  Set up display
!
      CALL DisplaySetup()
      CALL DisplayResize(IWWIDTH,IWHEIGHT)
!
!  Draw initial display
!
      CALL Display()
!
! Main message loop
!
      DO
        CALL WMessage(ITYPE,MESSAGE)
        SELECT CASE (ITYPE)
          CASE (Expose)
            CALL Display()
          CASE (Resize)
            CALL DisplayResize(MESSAGE%WPIX,MESSAGE%HPIX)
          CASE (MouseButDown)
            CALL ProcessMouse(MESSAGE%X,MESSAGE%Y,MESSAGE%VALUE1)
          CASE (KeyDown)
            CALL ProcessKey(MESSAGE%VALUE1)
          CASE (MenuSelect)
            IF (MESSAGE%VALUE1 == ID_EXIT) THEN
                EXIT
            ELSE
                CALL ProcessMenu(MESSAGE%VALUE1)
            END IF
          CASE (CloseRequest)
              EXIT
        END SELECT
      END DO
!
!  Terminate Open-GL and Winteracter
!
      CALL WglSelect(0)
      CALL WindowClose()
      STOP
!
      CONTAINS
!
!*****************************************************************************
!
      FUNCTION RandomGLfloat()
!
! Return an OpenGl float random number between 0.0 and 1.0
!
      IMPLICIT NONE
      REAL(glfloat)  :: RandomGLfloat
      REAL           :: RVAL
!
      CALL RANDOM_NUMBER(RVAL)
      RandomGLfloat = RVAL
      RETURN
      END FUNCTION RandomGLfloat
!
!*****************************************************************************
!
      SUBROUTINE ProcessMouse(X,Y,IBUT)
!
! Process mouse events
!
      USE SELECT_MOD
!
      IMPLICIT NONE
!
      INTEGER, INTENT(IN) :: X,Y,IBUT
      INTEGER             :: IPOSX,IPOSY,IHIT,IFUNC
!
      CALL WindowUnitsToPixels(X,Y,IPOSX,IPOSY)
      IPOSY = WInfoWindow(WindowHeight) - IPOSY + 1
!
! Determine which triangle was clicked on
!
      IHIT = MouseSelect(IPOSX,IPOSY)
!
      IF (IHIT/=-1) THEN
          IFUNC = 0
!
! Lookup currently assigned function
!
          SELECT CASE (IBUT)
              CASE (LeftButton)
                  IFUNC = IMOUSEBUT(1)
              CASE (MiddleButton)
                  IFUNC = IMOUSEBUT(2)
              CASE (RightButton)
                  IFUNC = IMOUSEBUT(3)
          END SELECT
!
! Execute function
!
          SELECT CASE (IFUNC)
            CASE (1)
              CALL TriangleRecolour(IHIT)
            CASE (2)
              CALL TriangleDelete(IHIT)
            CASE (3)
              CALL TriangleGrow(IHIT)
          END SELECT
      END IF
      RETURN
      END SUBROUTINE ProcessMouse
!
!*****************************************************************************
!
      SUBROUTINE ProcessKey(IDENT)
!
! Process keydown events
!
      USE SELECT_MOD
!
      IMPLICIT NONE
!
      INTEGER, INTENT(IN) :: IDENT
!
      SELECT CASE (IDENT)
!
! Zoom function
!
        CASE (KeyCursorUp)
          RZOOM = RZOOM/0.75_glfloat
        CASE (KeyCursorDown)
          RZOOM = RZOOM*0.75_glfloat
!
! Rotate function
!
        CASE (KeyCursorLeft)
          RZROTATE = RZROTATE + 1.0_glfloat
        CASE (KeyCursorRight)
          RZROTATE = RZROTATE - 1.0_glfloat
      END SELECT
!
      CALL Display()
      RETURN
      END SUBROUTINE ProcessKey
!
!*****************************************************************************
!
      SUBROUTINE ProcessMenu(IDENT)
!
! Process menu events
!
      USE SELECT_MOD
!
      IMPLICIT NONE
!
      INTEGER, INTENT(IN) :: IDENT
!
      SELECT CASE (IDENT)
        CASE (ID_LCOLOUR:ID_LGROW)
!
! Assign function to left mouse button
!
          CALL WMenuSetState(ID_LCOLOUR+IMOUSEBUT(1)-1,ItemChecked,WintOff)
          IMOUSEBUT(1) = IDENT-ID_LCOLOUR+1
          CALL WMenuSetState(IDENT                    ,ItemChecked,WintOn)
        CASE (ID_MCOLOUR:ID_MGROW)
!
! Assign function to middle mouse button
!
          CALL WMenuSetState(ID_MCOLOUR+IMOUSEBUT(2)-1,ItemChecked,WintOff)
          IMOUSEBUT(2) = IDENT-ID_MCOLOUR+1
          CALL WMenuSetState(IDENT                    ,ItemChecked,WintOn)
        CASE (ID_RCOLOUR:ID_RGROW)
!
! Assign function to right mouse button
!
          CALL WMenuSetState(ID_RCOLOUR+IMOUSEBUT(3)-1,ItemChecked,WintOff)
          IMOUSEBUT(3) = IDENT-ID_RCOLOUR+1
          CALL WMenuSetState(IDENT                    ,ItemChecked,WintOn)
        CASE (ID_FILL)
!
! Select filled or line drawn polygons
!
          fillpoly = .NOT.fillpoly
          IF (fillpoly) THEN
              CALL WMenuSetState(ID_FILL,ItemChecked,WintOn)
              CALL glPolygonMode(GL_FRONT_AND_BACK, GL_FILL)
          ELSE
              CALL WMenuSetState(ID_FILL,ItemChecked,WintOff)
              CALL glPolygonMode(GL_FRONT_AND_BACK, GL_LINE)
          END IF
          CALL Display()
      END SELECT
      RETURN
      END SUBROUTINE ProcessMenu
!
!*****************************************************************************
!
      FUNCTION MouseSelect(IPOSX,IPOSY)
!
! Determine which triangle (if any) was selected)
!
      USE SELECT_MOD
!
      IMPLICIT NONE
!
      INTEGER, INTENT(IN)  :: IPOSX,IPOSY
      INTEGER              :: MouseSelect
!
      REAL(gldouble)       :: RPOSX,RPOSY
      INTEGER(gluint)      :: selectBuf(IMAXOBJ)
      INTEGER(glsizei)     :: IGMAXOBJ
      INTEGER(glint)       :: IDUM,IHIT
      INTEGER(glint)       :: IVIEWPORT(4)
!
      IGMAXOBJ = IMAXOBJ
      RPOSX    = IPOSX
      RPOSY    = IPOSY
!
      CALL glSelectBuffer(IGMAXOBJ, selectBuf)
      IDUM = glRenderMode(GL_SELECT)
      IDUM = IDUM         ! Avoid compiler warning
      CALL glInitNames()
      CALL glPushName(-1) ! Need bit pattern
!
      CALL glPushMatrix()
!
      CALL glMatrixMode(GL_PROJECTION)
      CALL glLoadIdentity()
!
      CALL glGetIntegerv(GL_VIEWPORT, IVIEWPORT)
      CALL gluPickMatrix(RPOSX, RPOSY, 4.0_gldouble, 4.0_gldouble, IVIEWPORT)
      CALL gluOrtho2D(-175.0_gldouble, 175.0_gldouble, -175.0_gldouble, 175.0_gldouble)
      CALL glMatrixMode(GL_MODELVIEW)
!
      CALL glClearColor(0.0_glclampf, 0.0_glclampf, 0.0_glclampf, 0.0_glclampf)
      CALL glClear(GL_COLOR_BUFFER_BIT)
!
      CALL glScalef(RZOOM, RZOOM, RZOOM)
      CALL glRotatef(RZROTATE, 0.0_glfloat, 0.0_glfloat, 1.0_glfloat)
!
      CALL DisplayRender(GL_SELECT)
!
      CALL glPopMatrix()
!
      IHIT = glRenderMode(GL_RENDER)
!
      IF (IHIT<=0) THEN
          MouseSelect = -1
      ELSE
          MouseSelect = selectBuf(IHIT+3)
      END IF
      RETURN
      END FUNCTION MouseSelect
!
!*****************************************************************************
!
      SUBROUTINE TriangleRecolour(IHIT)
!
! Change the colour of the selected triangle
!
      USE SELECT_MOD
!
      IMPLICIT NONE
!
      INTEGER, INTENT(IN) :: IHIT
!
      OBJECT(IHIT)%COLOUR(1) = (10.0_glfloat*RandomGLfloat() + 5.0_glfloat)/15.0_glfloat
      OBJECT(IHIT)%COLOUR(2) = (10.0_glfloat*RandomGLfloat() + 5.0_glfloat)/15.0_glfloat
      OBJECT(IHIT)%COLOUR(3) = (10.0_glfloat*RandomGLfloat() + 5.0_glfloat)/15.0_glfloat
      CALL Display()
      RETURN
      END SUBROUTINE TriangleRecolour
!
!*****************************************************************************
!
      SUBROUTINE TriangleDelete(IHIT)
!
! Delete the selected triangle
!
      USE SELECT_MOD
!
      IMPLICIT NONE
!
      INTEGER, INTENT(IN) :: IHIT
!
      OBJECT(IHIT:IOBJNUM-1) = OBJECT(IHIT+1:IOBJNUM)
      IOBJNUM = IOBJNUM - 1
      CALL Display()
      RETURN
      END SUBROUTINE TriangleDelete
!
!*****************************************************************************
!
      SUBROUTINE TriangleGrow(IHIT)
!
! Increase the size of the selected triangle
!
      USE SELECT_MOD
!
      IMPLICIT NONE
!
      INTEGER, INTENT(IN) :: IHIT
      INTEGER             :: I
!
      REAL(glfloat)   :: VERTEX(2),OLDV(2)
!
      VERTEX = OBJECT(IHIT)%VERTEX1 + OBJECT(IHIT)%VERTEX2 + OBJECT(IHIT)%VERTEX3
      VERTEX = VERTEX / 3.0_glfloat
!
      DO I = 1,3
        SELECT CASE (I)
          CASE (1)
            OLDV = OBJECT(IHIT)%VERTEX1
          CASE (2)
            OLDV = OBJECT(IHIT)%VERTEX2
          CASE (3)
            OLDV = OBJECT(IHIT)%VERTEX3
        END SELECT
        OLDV = 1.5_glfloat * (OLDV - VERTEX) + VERTEX
        SELECT CASE (I)
          CASE (1)
            OBJECT(IHIT)%VERTEX1 = OLDV
          CASE (2)
            OBJECT(IHIT)%VERTEX2 = OLDV
          CASE (3)
            OBJECT(IHIT)%VERTEX3 = OLDV
        END SELECT
      END DO
      CALL Display()
      RETURN
      END SUBROUTINE TriangleGrow
!
!*****************************************************************************
!
      SUBROUTINE DisplaySetup()
!
! Initialise object information (positions and colours)
!
      USE SELECT_MOD
!
      IMPLICIT NONE
!
      REAL(glfloat) :: RWIDTH,RHEIGHT,X,Y
      INTEGER       :: I
!
      RWIDTH  = IWWIDTH  - 100
      RHEIGHT = IWHEIGHT - 100
!
      DO I = 1,IOBJNUM
        X = RWIDTH *RandomGLfloat() - 150.0_glfloat
        Y = RHEIGHT*RandomGlfloat() - 150.0_glfloat
!
        OBJECT(I)%VERTEX1(1) = X + 50.0_glfloat*RandomGlfloat() - 25.0_glfloat
        OBJECT(I)%VERTEX2(1) = X + 50.0_glfloat*RandomGlfloat() - 25.0_glfloat
        OBJECT(I)%VERTEX3(1) = X + 50.0_glfloat*RandomGlfloat() - 25.0_glfloat
!
        OBJECT(I)%VERTEX1(2) = Y + 50.0_glfloat*RandomGlfloat() - 25.0_glfloat
        OBJECT(I)%VERTEX2(2) = Y + 50.0_glfloat*RandomGlfloat() - 25.0_glfloat
        OBJECT(I)%VERTEX3(2) = Y + 50.0_glfloat*RandomGlfloat() - 25.0_glfloat
!
        OBJECT(I)%COLOUR(1) = (10.0_glfloat*RandomGlfloat() + 5.0_glfloat)/15.0_glfloat
        OBJECT(I)%COLOUR(2) = (10.0_glfloat*RandomGlfloat() + 5.0_glfloat)/15.0_glfloat
        OBJECT(I)%COLOUR(3) = (10.0_glfloat*RandomGlfloat() + 5.0_glfloat)/15.0_glfloat
      END DO
      IF (.NOT.fillpoly) CALL glPolygonMode(GL_FRONT_AND_BACK, GL_LINE)
      RETURN
      END SUBROUTINE DisplaySetup
!
!*****************************************************************************
!
      SUBROUTINE DisplayResize(IWIDTH,IHEIGHT)
!
! Resize OpenGL viewport to take account of resized window and then update
!
      USE SELECT_MOD
!
      IMPLICIT NONE
!
      INTEGER, INTENT(IN) :: IWIDTH,IHEIGHT
      INTEGER(glsizei)    :: IGLWIDTH,IGLHEIGHT
!
      IWWIDTH   = IWIDTH
      IWHEIGHT  = IHEIGHT
      IGLWIDTH  = IWIDTH
      IGLHEIGHT = IHEIGHT
      CALL glViewport(0_glint, 0_glint, IGLWIDTH, IGLHEIGHT)
      CALL Display()
      RETURN
      END SUBROUTINE DisplayResize
!
!*****************************************************************************
!
      SUBROUTINE Display()
!
! Draw current display
!
      USE SELECT_MOD
!
      IMPLICIT NONE
!
      CALL glPushMatrix()
      CALL glMatrixMode(GL_PROJECTION)
      CALL glLoadIdentity()
      CALL gluOrtho2D(-175.0_gldouble,175.0_gldouble,-175.0_gldouble,175.0_gldouble)
      CALL glMatrixMode(GL_MODELVIEW)
      CALL glClearColor(0.0_glclampf,0.0_glclampf,0.0_glclampf,0.0_glclampf)
      CALL glClear(GL_COLOR_BUFFER_BIT)
      CALL glScalef(RZOOM,RZOOM,RZOOM)
      CALL glRotatef(RZROTATE,0.0_glfloat,0.0_glfloat,1.0_glfloat)
      CALL DisplayRender(GL_RENDER)
      CALL glPopMatrix()
      CALL glFlush()
      RETURN
      END SUBROUTINE Display
!
!*****************************************************************************
!
      SUBROUTINE DisplayRender(mode)
!
! Render the objects in the display
!
      USE SELECT_MOD
!
      IMPLICIT NONE
!
      INTEGER(glenum), INTENT(IN) :: mode
      INTEGER(gluint)             :: IG
      INTEGER                     :: I
!
      DO I = 1,IOBJNUM
        IG = I
        IF (mode==GL_SELECT) CALL glLoadName(IG)
        CALL glColor3fv(OBJECT(I)%COLOUR)
        CALL glBegin(GL_POLYGON)
        CALL glVertex2fv(OBJECT(I)%VERTEX1)
        CALL glVertex2fv(OBJECT(I)%VERTEX2)
        CALL glVertex2fv(OBJECT(I)%VERTEX3)
        CALL glEnd()
      END DO
      RETURN
      END SUBROUTINE DisplayRender
!
      END PROGRAM SELECT