!  ********************************************************************
!  * 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 WAVE_MOD
!
      USE WINTERACTER
      USE OPENGL
!
      IMPLICIT NONE
      LOGICAL            :: doublebuffer = .TRUE. ! Rendering parameters
      LOGICAL            :: directRender = .TRUE.
      INTEGER            :: clearMask    = ior(GL_COLOR_BUFFER_BIT, &
                                               GL_DEPTH_BUFFER_BIT)
!
      INTEGER, PARAMETER :: frames       = 10     ! Animation frame
      INTEGER            :: curFrame     =  1     ! information
!
      INTEGER, PARAMETER :: widthX       = 10     ! Size of grid
      INTEGER, PARAMETER :: widthY       = 10
      INTEGER            :: numFacets    = widthX * widthY
      INTEGER            :: numCoord     = (widthX + 1) * (widthY + 1)
!
      INTEGER            :: checkerSize  =  2
      REAL               :: height       =  0.2   ! Oscillation amplitude
!
      REAL,    PARAMETER :: PI           = 3.141592654
!
      INTEGER            :: CheckerCol1(3) = (/1.0, 0.2, 0.2/)
      INTEGER            :: CheckerCol2(3) = (/0.2, 1.0, 0.2/)
      INTEGER(glint)     :: mapped_colours(2) = (/1,2/)
!
      LOGICAL            :: smooth   = .TRUE.
      LOGICAL            :: stepMode = .FALSE.
      LOGICAL            :: spinMode = .TRUE.
      INTEGER            :: ITIME
!
      TYPE :: facet
          REAL(glfloat)  :: colour(3)
          REAL(glfloat)  :: normal(3)
      END TYPE facet
!
      TYPE :: coord
          REAL(glfloat)  :: vertex(3)
          REAL(glfloat)  :: normal(3)
      END TYPE coord
!
      TYPE(coord)        :: coords(frames,widthX+1,widthY+1)
      TYPE(facet)        :: facets(frames,widthX,widthY)
!
      INTEGER, PARAMETER :: IDR_MENU1       = 30001
      INTEGER, PARAMETER :: ID_ITEM1        = 40001
      INTEGER, PARAMETER :: ID_STEP         = 40002
      INTEGER, PARAMETER :: ID_EXIT         = 40003
      INTEGER, PARAMETER :: ID_SPIN         = 40004
      INTEGER, PARAMETER :: ID_SMOOTH       = 40005
      INTEGER, PARAMETER :: ID_ITEM6        = 40006
!
      END MODULE WAVE_MOD
!
!*****************************************************************************
!
      PROGRAM WAVE
!
! Animated 3D wave
!
      USE WAVE_MOD
!
      IMPLICIT NONE
      TYPE(WIN_MESSAGE) :: MESSAGE
      INTEGER           :: ITYPE
!
!  Initialise Winteracter.
!
      CALL WInitialise()
!
!  Open root window.
!
      CALL WindowOpen(WIDTH=400,HEIGHT=400,MENUID=IDR_MENU1, &
                      TITLE='3D Wave Animation')
!
!  Check screen colour depth.
!  OpenGL doesn't work particularly well on 16-colour displays
!
      IF (WInfoScreen(ScreenColours).LE.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 some menu options
!
      IF (.NOT.stepMode) CALL WMenuSetState(ID_STEP  ,ItemChecked,1)
      IF (stepMode)      CALL WMenuSetState(ID_SPIN  ,ItemEnabled,0)
      IF (spinMode)      CALL WMenuSetState(ID_SPIN  ,ItemChecked,1)
      IF (smooth)        CALL WMenuSetState(ID_SMOOTH,ItemChecked,1)
!
!  Initialise Open-GL
!
      CALL WglSelect(1,0,2)
!
!  Set up display
!
      CALL DisplaySetup()
      CALL DisplayResize(400,400)
!
!  Draw initial display
!
      ITIME = WInfoSystem(SystemTime)
      CALL Display()
!
! Main message loop
!
      DO
        IF (stepMode) THEN
            CALL WMessage(ITYPE,MESSAGE)
        ELSE
            CALL WMessagePeek(ITYPE,MESSAGE)
        END IF
!
        SELECT CASE (ITYPE)
          CASE (-1) ! No message
            CALL Idle()
          CASE (Expose)
            CALL Display()
          CASE (Resize)
            CALL DisplayResize(MESSAGE%WPIX,MESSAGE%HPIX)
            CALL Display()
          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
!
!*****************************************************************************
!
      SUBROUTINE ProcessMenu(IDENT)
!
! Process menu messages
!
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: IDENT
!
      SELECT CASE (IDENT)
        CASE (ID_STEP)
          stepMode = .NOT.stepMode
          IF (stepMode) THEN
              CALL WMenuSetState(ID_STEP ,ItemChecked,0)
              CALL WMenuSetState(ID_SPIN ,ItemEnabled,0)
          ELSE
              CALL WMenuSetState(ID_STEP ,ItemChecked,1)
              CALL WMenuSetState(ID_SPIN ,ItemEnabled,1)
          END IF
        CASE (ID_SPIN)
          spinMode = .NOT.spinMode
          IF (spinMode) THEN
              CALL WMenuSetState(ID_SPIN ,ItemChecked,1)
          ELSE
              CALL WMenuSetState(ID_SPIN ,ItemChecked,0)
          END IF
        CASE (ID_SMOOTH)
          smooth = .NOT.smooth
          IF (smooth) THEN
              CALL WMenuSetState(ID_SMOOTH,ItemChecked,1)
              CALL glShadeModel(GL_SMOOTH)
          ELSE
              CALL WMenuSetState(ID_SMOOTH,ItemChecked,0)
              CALL glShadeModel(GL_FLAT)
          END IF
          CALL Display()
      END SELECT
      RETURN
      END SUBROUTINE ProcessMenu
!
!*****************************************************************************
!
      SUBROUTINE DisplaySetup()
!
! Main initialisation routine
!
! If double-buffering is enabled then we need to set the Read and Draw buffers
! to the back buffer. Using double-buffering eliminates flicker.
!
      IF (doublebuffer) THEN
          CALL glReadBuffer(GL_BACK)
          CALL glDrawBuffer(GL_BACK)
      END IF
!
      IF (smooth) THEN
          CALL glShadeModel(GL_SMOOTH)
      ELSE
          CALL glShadeModel(GL_FLAT)
      END IF
!
      CALL glClearColor(0.0_glclampf, 0.0_glclampf, 0.0_glclampf, 0.0_glclampf)
      CALL glFrontFace(GL_CW)
      CALL glEnable(GL_DEPTH_TEST)
!
      CALL DisplaySetupMaterials()
      CALL DisplaySetupMesh()
!
      CALL glMatrixMode(GL_MODELVIEW)
      CALL glTranslatef(0.0_glfloat, 0.4_glfloat, -1.8_glfloat)
      CALL glScalef(2.0_glfloat, 2.0_glfloat, 2.0_glfloat)
      CALL glRotatef(-35.0_glfloat, 1.0_glfloat, 0.0_glfloat, 0.0_glfloat)
      CALL glRotatef(35.0_glfloat, 0.0_glfloat, 0.0_glfloat, 1.0_glfloat)
      RETURN
      END SUBROUTINE DisplaySetup
!
!*****************************************************************************
!
      SUBROUTINE DisplaySetupMaterials()
!
! Initialise materials
!
      IMPLICIT NONE
      REAL(glfloat) :: ambient(4)             = (/ 0.1,  0.1,   0.1, 1.0/)
      REAL(glfloat) :: diffuse(4)             = (/ 0.5,  1.0,   1.0, 1.0/)
      REAL(glfloat) :: position(4)            = (/90.0, 90.0, 150.0, 0.0/)
      REAL(glfloat) :: front_mat_shininess(1) = (/60.0/)
      REAL(glfloat) :: front_mat_specular(4)  = (/0.2, 0.2, 0.2, 1.0/)
      REAL(glfloat) :: front_mat_diffuse(4)   = (/0.5, 0.28, 0.38, 1.0/)
      REAL(glfloat) :: back_mat_shininess(1)  = (/60.0/)
      REAL(glfloat) :: back_mat_specular(4)   = (/0.5, 0.5, 0.2, 1.0/)
      REAL(glfloat) :: back_mat_diffuse(4)    = (/1.0, 1.0, 0.2, 1.0/)
      REAL(glfloat) :: lmodel_ambient(4)      = (/1.0, 1.0, 1.0, 1.0/)
      REAL(glfloat) :: lmodel_twoside(1)      = (/GL_TRUE/)
!
      CALL glMatrixMode(GL_PROJECTION)
      CALL gluPerspective(90.0_gldouble, 1.0_gldouble, 0.5_gldouble, 10.0_gldouble)
!
      CALL glLightfv(GL_LIGHT0, GL_AMBIENT, ambient)
      CALL glLightfv(GL_LIGHT0, GL_DIFFUSE, diffuse)
      CALL glLightfv(GL_LIGHT0, GL_POSITION, position)
      CALL glLightModelfv(GL_LIGHT_MODEL_AMBIENT, lmodel_ambient)
      CALL glLightModelfv(GL_LIGHT_MODEL_TWO_SIDE, lmodel_twoside)
      CALL glEnable(GL_LIGHTING)
      CALL glEnable(GL_LIGHT0)
!
      CALL glMaterialfv(GL_FRONT, GL_SHININESS, front_mat_shininess)
      CALL glMaterialfv(GL_FRONT, GL_SPECULAR, front_mat_specular)
      CALL glMaterialfv(GL_FRONT, GL_DIFFUSE, front_mat_diffuse)
      CALL glMaterialfv(GL_BACK, GL_SHININESS, back_mat_shininess)
      CALL glMaterialfv(GL_BACK, GL_SPECULAR, back_mat_specular)
      CALL glMaterialfv(GL_BACK, GL_DIFFUSE, back_mat_diffuse)
!
      CALL glColorMaterial(GL_FRONT_AND_BACK, GL_DIFFUSE)
!
      CALL glEnable(GL_COLOR_MATERIAL)
      RETURN
      END SUBROUTINE DisplaySetupMaterials
!
!*****************************************************************************
!
      SUBROUTINE DisplaySetupMesh()
!
! Initialise the mesh
!
      IMPLICIT NONE
      REAL          :: ANGLE,D,X,Y
      REAL(glfloat) :: dp1(3), dp2(3),D2
      INTEGER       :: frameNum,I,J
!
      DO frameNum = 1,frames
        DO I = 1, widthX+1
          X = REAL(I-1)/REAL(widthX)
          DO J = 1, widthY+1
            Y = REAL(J-1)/REAL(widthY)
            D = SQRT(X*X+Y*Y)
            IF (D.LE.0.0) D = 0.0001
            ANGLE = 2.0*PI*D+(2*PI*frameNum/frames)
!
            coords(frameNum,I,J)%vertex(1) = X - 0.5
            coords(frameNum,I,J)%vertex(2) = Y - 0.5
            coords(frameNum,I,J)%vertex(3) = height*(1.0-D)*COS(ANGLE)
!
            coords(frameNum,I,J)%normal(1) = -(height/D)*X*((1-D)*2.0*PI*SIN(ANGLE)+COS(ANGLE))
            coords(frameNum,I,J)%normal(2) = -(height/D)*Y*((1-D)*2.0*PI*SIN(ANGLE)+COS(ANGLE))
            coords(frameNum,I,J)%normal(3) = -1
!
            D2 = 1.0 / SQRT(coords(frameNum,I,J)%normal(1)**2+ &
                            coords(frameNum,I,J)%normal(2)**2+1.0_glfloat)
!
            coords(frameNum,I,J)%normal = coords(frameNum,I,J)%normal*D2
          END DO
        END DO
!
        DO I = 1,widthX
          DO J = 1,widthY
            IF (IEOR(MOD(I/checkerSize,2),MOD(J/checkerSize,2))>0) THEN
                facets(frameNum,I,J)%colour = CheckerCol1
            ELSE
                facets(frameNum,I,J)%colour = CheckerCol2
            END IF
!
            dp1 = coords(frameNum,I  ,J+1)%vertex - coords(frameNum,I,J  )%vertex
            dp2 = coords(frameNum,I+1,J+1)%vertex - coords(frameNum,I,J+1)%vertex
!
            facets(frameNum,I,J)%normal(1) = dp1(2) * dp2(3) - dp1(3) * dp2(1)
            facets(frameNum,I,J)%normal(2) = dp1(3) * dp2(1) - dp1(1) * dp2(3)
            facets(frameNum,I,J)%normal(3) = dp1(1) * dp2(2) - dp1(2) * dp2(1)
!
            D2 = 1.0 / SQRT(facets(frameNum,I,J)%normal(1)**2+  &
                            facets(frameNum,I,J)%normal(2)**2+  &
                            facets(frameNum,I,J)%normal(3)**2)
!
            facets(frameNum,I,J)%normal = facets(frameNum,I,J)%normal*D2
          END DO
        END DO
      END DO
      RETURN
      END SUBROUTINE DisplaySetupMesh
!
!*****************************************************************************
!
      SUBROUTINE DisplayResize(IWIDTH,IHEIGHT)
!
! Resize the display
!
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: IWIDTH,IHEIGHT
!
      INTEGER(glsizei)    :: GWIDTH,GHEIGHT
!
      GWIDTH  = IWIDTH
      GHEIGHT = IHEIGHT
      IF (doubleBuffer) CALL glDrawBuffer(GL_FRONT_AND_BACK)
      CALL glViewport(0_glsizei, 0_glsizei, GWIDTH, GHEIGHT)
      IF (doubleBuffer) CALL glDrawBuffer(GL_BACK)
      RETURN
      END SUBROUTINE DisplayResize
!
!*****************************************************************************
!
      SUBROUTINE Display()
!
! Render the current frame of the animation
!
      IMPLICIT NONE
      REAL(glfloat) :: lastColour(3)
      REAL(glfloat) :: thisColour(3)
      LOGICAL       :: storedColour
      INTEGER       :: I,J
!
      CALL glClear(clearMask)
!
! Render the surface
!
      DO I = 1,widthX
        CALL glBegin(GL_QUAD_STRIP)
        storedColour = .FALSE.
        DO J = 1,widthY
          IF (.NOT.smooth) CALL glNormal3fv(facets(curFrame,I,J)%normal)
          thisColour = facets(curFrame,I,J)%colour
          CALL glColor3fv(facets(curFrame,I,J)%colour)
!
          IF ((.NOT.storedColour).OR.((thisColour(1).NE.lastColour(1)) &
              .AND.smooth)) THEN
              IF (storedColour) THEN
                  CALL glEnd()
                  CALL glBegin(GL_QUAD_STRIP)
              END IF
!
! Require more points to be defined when plotting a 'smooth' surface, since
! model requires more points
!
              IF (smooth) CALL glNormal3fv(coords(curFrame,I,J)%normal)
              CALL glVertex3fv(coords(curFrame,I,J)%vertex)
!
              IF (smooth) CALL glNormal3fv(coords(curFrame,I+1,J)%normal)
              CALL glVertex3fv(coords(curFrame,I+1,J)%vertex)
          END IF
!
          IF (smooth) CALL glNormal3fv(coords(curFrame,I,J+1)%normal)
          CALL glVertex3fv(coords(curFrame,I,J+1)%vertex)
!
          IF (smooth) CALL glNormal3fv(coords(curFrame,I+1,J+1)%normal)
          CALL glVertex3fv(coords(curFrame,I+1,J+1)%vertex)
!
          lastColour   = thisColour
          storedColour = .TRUE.
        END DO
        CALL glEnd()
      END DO
!
      IF (doubleBuffer) THEN
          CALL WglSwapBuffers()
      ELSE
          CALL glFlush()
      END IF
      RETURN
      END SUBROUTINE Display
!
!*****************************************************************************
!
      SUBROUTINE Idle()
!
! Animate the wave - show consecutive frames
!
      IMPLICIT NONE
      INTEGER :: NOW
!
      INTEGER, PARAMETER :: FPS = 30
!
      NOW = WInfoSystem(SystemTime)
      IF (NOW-ITIME>1000/FPS) THEN
          ITIME = NOW
          curFrame = curFrame + 1
          IF (curFrame>frames) curFrame = 1
          IF (spinMode) CALL glRotatef(5.0_glfloat, 0.0_glfloat, &
                                       0.0_glfloat, 1.0_glfloat)
          CALL Display()
      END IF
      RETURN
      END SUBROUTINE Idle
!
      END PROGRAM WAVE