!  ********************************************************************
!  * 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 SCUBE_MOD
!
!  Global variables
!
      USE WINTERACTER
      USE OPENGL
!
      IMPLICIT NONE
!
!  Intial states for options. Should match check marks on corresponding menu
!  items
!
      LOGICAL, SAVE :: useLighting = .TRUE.
      LOGICAL, SAVE :: useFog      = .FALSE.
      LOGICAL, SAVE :: useDB       = .TRUE.
!
!  Optional features, try experimenting with these two.
!
      LOGICAL, SAVE :: useLogo     = .FALSE.
      LOGICAL, SAVE :: useQuads    = .TRUE.
!
      INTEGER, SAVE :: ITICK  = -1
      INTEGER, SAVE :: ITIME
      LOGICAL, SAVE :: moving = .TRUE.
!
      INTEGER, PARAMETER :: GREY    = 1
      INTEGER, PARAMETER :: RED     = 2
      INTEGER, PARAMETER :: GREEN   = 3
      INTEGER, PARAMETER :: BLUE    = 4
      INTEGER, PARAMETER :: CYAN    = 5
      INTEGER, PARAMETER :: MAGENTA = 6
      INTEGER, PARAMETER :: YELLOW  = 7
      INTEGER, PARAMETER :: BLACK   = 8
!
      REAL(glfloat), SAVE :: materialColour(4,8) = &
          RESHAPE((/0.8,0.8,0.8,1.0,               &
                    0.8,0.0,0.0,1.0,               &
                    0.0,0.8,0.0,1.0,               &
                    0.0,0.0,0.8,1.0,               &
                    0.0,0.8,0.8,1.0,               &
                    0.8,0.0,0.8,1.0,               &
                    0.8,0.8,0.0,1.0,               &
                    0.0,0.0,0.0,0.7/),(/4,8/))
!
      REAL(glfloat), SAVE, DIMENSION(4) :: lightPos  = (/ 2.0,  4.0,  2.0, 1.0/)
      REAL(glfloat), SAVE, DIMENSION(4) :: lightDir  = (/-2.0, -4.0, -2.0, 1.0/)
      REAL(glfloat), SAVE, DIMENSION(4) :: lightAmb  = (/ 0.2,  0.2,  0.2, 1.0/)
      REAL(glfloat), SAVE, DIMENSION(4) :: lightDiff = (/ 0.8,  0.8,  0.8, 1.0/)
      REAL(glfloat), SAVE, DIMENSION(4) :: lightSpec = (/ 0.4,  0.4,  0.4, 1.0/)
!
      REAL(glfloat), SAVE, DIMENSION(4) :: groundPlane = (/0.0, 1.0, 0.0, 1.499/)
      REAL(glfloat), SAVE, DIMENSION(4) :: backPlane   = (/0.0, 0.0, 1.0, 0.899/)
!
      REAL(glfloat), SAVE, DIMENSION(4) :: fogColour = (/0.0, 0.0, 0.0, 0.0/)
      REAL(glfloat), SAVE, DIMENSION(1) :: fogIndex  = (/0.0/)
!
!  SGI Logo
!
      INTEGER(glubyte), SAVE, DIMENSION(128) :: sgiPattern
      DATA sgiPattern / &
          z'ff', z'ff', z'ff', z'ff', z'ff', z'ff', z'ff', z'ff', &
          z'ff', z'bd', z'ff', z'83', z'ff', z'5a', z'ff', z'ef', &
          z'fe', z'db', z'7f', z'ef', z'fd', z'db', z'bf', z'ef', &
          z'fb', z'db', z'df', z'ef', z'f7', z'db', z'ef', z'ef', &
          z'fb', z'db', z'df', z'ef', z'fd', z'db', z'bf', z'83', &
          z'ce', z'db', z'73', z'ff', z'b7', z'5a', z'ed', z'ff', &
          z'bb', z'db', z'dd', z'c7', z'bd', z'db', z'bd', z'bb', &
          z'be', z'bd', z'7d', z'bb', z'bf', z'7e', z'fd', z'b3', &
          z'be', z'e7', z'7d', z'bf', z'bd', z'db', z'bd', z'bf', &
          z'bb', z'bd', z'dd', z'bb', z'b7', z'7e', z'ed', z'c7', &
          z'ce', z'db', z'73', z'ff', z'fd', z'db', z'bf', z'ff', &
          z'fb', z'db', z'df', z'87', z'f7', z'db', z'ef', z'fb', &
          z'f7', z'db', z'ef', z'fb', z'fb', z'db', z'df', z'fb', &
          z'fd', z'db', z'bf', z'c7', z'fe', z'db', z'7f', z'bf', &
          z'ff', z'5a', z'ff', z'bf', z'ff', z'bd', z'ff', z'c3', &
          z'ff', z'ff', z'ff', z'ff', z'ff', z'ff', z'ff', z'ff' /
!
!  Resource identifiers
!
      INTEGER, PARAMETER :: IDR_MENU1                       = 30001
      INTEGER, PARAMETER :: ID_MOTION                       = 40001
      INTEGER, PARAMETER :: ID_LIGHT                        = 40002
      INTEGER, PARAMETER :: ID_FOG                          = 40003
      INTEGER, PARAMETER :: ID_FOG_LINEAR                   = 40004
      INTEGER, PARAMETER :: ID_FOG_EXP                      = 40005
      INTEGER, PARAMETER :: ID_FOG_EXP2                     = 40006
      INTEGER, PARAMETER :: ID_EXIT                         = 40007
!
      END module SCUBE_MOD
!
!******************************************************************************
!
      PROGRAM SCUBE
!
      USE SCUBE_MOD
!
      IMPLICIT NONE
      TYPE(WIN_MESSAGE) :: MESSAGE
      INTEGER           :: ITYPE
!
      INTEGER(glsizei)  :: IWIDTH, IHEIGHT
!
!  Initialise Winteracter.
!
      CALL WInitialise()
!
!  Open root window.
!
      CALL WindowOpen(WIDTH=400,HEIGHT=400,MENUID=IDR_MENU1, &
                      TITLE='Spinning Block With Shadow')
!
!  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 Open-GL
!
      CALL WglSelect(1,0,2)
!
!  Set up display.
!
      CALL SetupDisplay()
!
!  Draw initial display
!
      ITIME = WInfoSystem(SystemTime)
      CALL Display()
!
!  Main message loop
!
      DO
!
!  If animation is turned on the call WMessagePeek instead of WMessage so we
!  can display the next frame of animation when no other messages are waiting.
!
        IF (moving) THEN
            CALL WMessagePeek(ITYPE, MESSAGE)
        ELSE
            CALL WMessage(ITYPE, MESSAGE)
        ENDIF
        SELECT CASE (ITYPE)
          CASE (-1)
            CALL Idle()
          CASE (Expose)
            CALL Display()                                      ! Re-do present display
          CASE (Resize)
            IWIDTH  = MESSAGE%WPIX                              ! Get new window size
            IHEIGHT = MESSAGE%HPIX
            CALL glDrawBuffer(GL_FRONT_AND_BACK)
            CALL glViewPort(0_glsizei,0_glsizei,IWIDTH,IHEIGHT) ! Adjust viewport
            CALL glDrawBuffer(GL_BACK)
            CALL Display()                                      ! Re-do current display
          CASE (MenuSelect)
            IF (MESSAGE%VALUE1 == ID_EXIT) THEN
                EXIT
            ELSE
                CALL ProcessMenu(MESSAGE%VALUE1)
            ENDIF
          CASE (CloseRequest)
            EXIT                                                ! Exit program
        END SELECT
      END DO
!
!  Terminate Open-GL and Winteracter
!
      CALL WglSelect(0)
      CALL WindowClose()
      STOP
!
      CONTAINS
!
!******************************************************************************
!
      SUBROUTINE ProcessMenu(IDENT)
!
!  Process menu selections
!
      USE SCUBE_MOD
!
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: IDENT ! Identifier of chosen option.
!
!  Branch depending on option chosen
!
      SELECT CASE (IDENT)
        CASE (ID_MOTION)
          moving = .NOT. moving
          IF (moving) THEN
              CALL WMenuSetState(ID_MOTION,ItemChecked,1)
          ELSE
              CALL WMenuSetState(ID_MOTION,ItemChecked,0)
          ENDIF
        CASE (ID_LIGHT)
          useLighting = .not. useLighting
          IF (useLighting) THEN
              CALL WMenuSetState(ID_LIGHT,ItemChecked,1)
              CALL glEnable(GL_LIGHTING)
          ELSE
              CALL WMenuSetState(ID_LIGHT,ItemChecked,0)
              CALL glDisable(GL_LIGHTING)
          ENDIF
          CALL Display()
        CASE (ID_FOG)
          useFog = .not. useFog
          IF (useFog) THEN
              CALL glEnable(GL_FOG)
              CALL WMenuSetState(ID_FOG,ItemChecked,1)
          ELSE
              CALL WMenuSetState(ID_FOG,ItemChecked,0)
              CALL glDisable(GL_FOG)
          ENDIF
          CALL Display()
        CASE (ID_FOG_LINEAR)
          CALL WMenuSetState(ID_FOG_LINEAR,ItemChecked,1)
          CALL WMenuSetState(ID_FOG_EXP,   ItemChecked,0)
          CALL WMenuSetState(ID_FOG_EXP2,  ItemChecked,0)
          CALL glFogi(GL_FOG_MODE,GL_LINEAR)
          CALL Display()
        CASE (ID_FOG_EXP)
          CALL WMenuSetState(ID_FOG_LINEAR,ItemChecked,0)
          CALL WMenuSetState(ID_FOG_EXP,   ItemChecked,1)
          CALL WMenuSetState(ID_FOG_EXP2,  ItemChecked,0)
          CALL glFogi(GL_FOG_MODE,GL_EXP)
          CALL Display()
        CASE (ID_FOG_EXP2)
          CALL WMenuSetState(ID_FOG_LINEAR,ItemChecked,0)
          CALL WMenuSetState(ID_FOG_EXP,   ItemChecked,0)
          CALL WMenuSetState(ID_FOG_EXP2,  ItemChecked,1)
          CALL glFogi(GL_FOG_MODE,GL_EXP2)
          CALL Display()
      END SELECT
      RETURN
      END SUBROUTINE ProcessMenu
!
!******************************************************************************
!
      SUBROUTINE SetColour(ICOL)
!
!  Set colour to use
!
      USE SCUBE_MOD
!
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: ICOL  ! Colour to select
!
      IF (useLighting) THEN
          CALL glMaterialfv(GL_FRONT_AND_BACK,      &
                            GL_AMBIENT_AND_DIFFUSE, &
                            materialColour(:,ICOL))
      ELSE
          CALL glColor4fv(materialColour(:,ICOL))
      ENDIF
      RETURN
      END SUBROUTINE SetColour
!
!******************************************************************************
!
      SUBROUTINE DrawCube(ICOL)
!
!  Draw a cube in the specified colour.
!
      USE SCUBE_MOD
!
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: ICOL ! Colour to draw cube in
!
      INTEGER :: I
      REAL(glfloat), SAVE, DIMENSION(4,4,6) :: cube_vertexes = &
          RESHAPE((/-1.0, -1.0, -1.0, 1.0,                     &
                    -1.0, -1.0,  1.0, 1.0,                     &
                    -1.0,  1.0,  1.0, 1.0,                     &
                    -1.0,  1.0, -1.0, 1.0,                     &
!
                     1.0,  1.0,  1.0, 1.0,                     &
                     1.0, -1.0,  1.0, 1.0,                     &
                     1.0, -1.0, -1.0, 1.0,                     &
                     1.0,  1.0, -1.0, 1.0,                     &
!
                    -1.0, -1.0, -1.0, 1.0,                     &
                     1.0, -1.0, -1.0, 1.0,                     &
                     1.0, -1.0,  1.0, 1.0,                     &
                    -1.0, -1.0,  1.0, 1.0,                     &
!
                     1.0,  1.0,  1.0, 1.0,                     &
                     1.0,  1.0, -1.0, 1.0,                     &
                    -1.0,  1.0, -1.0, 1.0,                     &
                    -1.0,  1.0,  1.0, 1.0,                     &
!
                    -1.0, -1.0, -1.0, 1.0,                     &
                    -1.0,  1.0, -1.0, 1.0,                     &
                     1.0,  1.0, -1.0, 1.0,                     &
                     1.0, -1.0, -1.0, 1.0,                     &
!
                     1.0,  1.0,  1.0, 1.0,                     &
                    -1.0,  1.0,  1.0, 1.0,                     &
                    -1.0, -1.0,  1.0, 1.0,                     &
                     1.0, -1.0,  1.0, 1.0/),(/4,4,6/))
!
      REAL(glfloat), SAVE, DIMENSION(4,6) :: cube_normals = &
          RESHAPE((/-1.0,  0.0,  0.0, 0.0,                  &
                     1.0,  0.0,  0.0, 0.0,                  &
                     0.0, -1.0,  0.0, 0.0,                  &
                     0.0,  1.0,  0.0, 0.0,                  &
                     0.0,  0.0, -1.0, 0.0,                  &
                     0.0,  0.0,  1.0, 0.0/),(/4,6/))
!
!  Set colour for cube
!
       CALL SetColour(ICOL)
!
!  Draw cube
!
       DO I=1,6
         CALL glNormal3fv(cube_normals(:,I))
         CALL glBegin(GL_POLYGON)
         CALL glVertex4fv(cube_vertexes(:,1,I))
         CALL glVertex4fv(cube_vertexes(:,2,I))
         CALL glVertex4fv(cube_vertexes(:,3,I))
         CALL glVertex4fv(cube_vertexes(:,4,I))
         CALL glEnd()
       END DO
       RETURN
       END SUBROUTINE DrawCube
!
!******************************************************************************
!
       SUBROUTINE DrawCheck(w,h,evenColour,oddColour)
!
!  Draw checkered plane
!
       USE SCUBE_MOD
!
       IMPLICIT NONE
       INTEGER, INTENT (IN)       :: w,h,evenColour,oddColour
       LOGICAL,              SAVE :: initialized  = .FALSE.
       LOGICAL,              SAVE :: usedLighting = .FALSE.
       INTEGER(gluint),      SAVE :: checklist = 0
       REAL, DIMENSION(4),   SAVE :: square_normal = (/0.0, 0.0, 1.0, 0.0/)
       REAL, DIMENSION(4,4), SAVE :: square
       INTEGER                    :: i,j
!
       IF (.NOT. initialized .OR. (usedLighting .EQV. useLighting)) THEN
           IF (checklist == 0) THEN
               checklist = glGenLists(1)
           ENDIF
           CALL glNewList(checklist, GL_COMPILE_AND_EXECUTE)
!
           IF (useQuads) THEN
               CALL glNormal3fv(square_normal)
               CALL glBegin(GL_QUADS)
           ENDIF
           DO j=0,h-1
             DO i=0,w-1
               square(1,1) = -1.0 + 2.0/w * i
               square(2,1) = -1.0 + 2.0/h * (j+1)
               square(3,1) =  0.0
               square(4,1) =  1.0
!
               square(1,2) = -1.0 + 2.0/w * i
               square(2,2) = -1.0 + 2.0/h * j
               square(3,2) =  0.0
               square(4,2) =  1.0
!
               square(1,3) = -1.0 + 2.0/w * (i+1)
               square(2,3) = -1.0 + 2.0/h * j
               square(3,3) =  0.0
               square(4,3) =  1.0
!
               square(1,4) = -1.0 + 2.0/w * (i+1)
               square(2,4) = -1.0 + 2.0/h * (j+1)
               square(3,4) =  0.0
               square(4,4) =  1.0
!
               IF (ieor(iand(i,1),iand(j,1)) /= 0) THEN
                   CALL setColour(oddColour)
               ELSE
                   CALL setColour(evenColour)
               ENDIF
!
               IF (.NOT.useQuads) CALL glBegin(GL_POLYGON)
               CALL glVertex4fv(square(:,1))
               CALL glVertex4fv(square(:,2))
               CALL glVertex4fv(square(:,3))
               CALL glVertex4fv(square(:,4))
               IF (.NOT.useQuads) CALL glEnd()
             END DO
           END DO
!
           IF (useQuads) CALL glEnd()
           CALL glEndList()
!
           initialized = .TRUE.
           usedLighting = useLighting
       ELSE
           CALL glCallList(checklist)
       ENDIF
       RETURN
       END SUBROUTINE DrawCheck
!
!******************************************************************************
!
       SUBROUTINE myShadowMatrix(ground,light)
!
       USE SCUBE_MOD
!
       IMPLICIT NONE
       REAL, DIMENSION(4), INTENT (IN) :: ground
       REAL, DIMENSION(4), INTENT (IN) :: light
       REAL                            :: dot
       REAL(glfloat)                   :: shadowMat(4,4)
       INTEGER                         :: i
!
       dot = dot_product(ground,light)
!
       DO i=1,4
         shadowMat(i,:) = -light(i)*ground
         shadowMat(i,i) = shadowMat(i,i) + dot
       END DO
       CALL glMultMatrixf(shadowMat)
       RETURN
       END SUBROUTINE myShadowMatrix
!
!******************************************************************************
!
       SUBROUTINE Idle()
!
!  Called to update display when no messages are waiting to be processed.
!
       USE SCUBE_MOD
!
       INTEGER :: NOW
       INTEGER, PARAMETER :: FPS = 30
!
       NOW = WInfoSystem(SystemTime)
       IF (NOW-ITIME>1000/FPS) THEN
           ITIME = NOW
           ITICK = MOD(ITICK+1,120)
           CALL Display()
       END IF
       RETURN
       END SUBROUTINE Idle
!
!******************************************************************************
!
       SUBROUTINE Display()
!
!  Draws current display
!
       USE SCUBE_MOD
!
       IMPLICIT NONE
       REAL(glfloat), DIMENSION(16) :: cubeXform
!
       CALL glClear(ior(GL_COLOR_BUFFER_BIT,GL_DEPTH_BUFFER_BIT))
!
       CALL glPushMatrix()
       CALL glTranslatef(0.0, -1.5, 0.0)    ! taking a chance that glfloat is
       CALL glRotatef(-90.0, 1., 0., 0.)    ! the same as the default real
       CALL glScalef(2.0, 2.0, 2.0)
!
       CALL DrawCheck(6, 6, BLUE, YELLOW)  ! draw ground
       CALL glPopMatrix()
!
       CALL glPushMatrix()
       CALL glTranslatef(0.0, 0.0, -0.9)
       CALL glScalef(2.0, 2.0, 2.0)
!
       CALL DrawCheck(6, 6, BLUE, YELLOW)  ! draw back
       CALL glPopMatrix()
!
       CALL glPushMatrix()
       CALL glTranslatef(0.0, 0.2, 0.0)
       CALL glScalef(0.3, 0.3, 0.3)
       CALL glRotatef((360.0 / (30 * 1)) * ITICK, 1., 0., 0.)
       CALL glRotatef((360.0 / (30 * 2)) * ITICK, 0., 1., 0.)
       CALL glRotatef((360.0 / (30 * 4)) * ITICK, 0., 0., 1.)
       CALL glScalef(1.0, 2.0, 1.0)
       CALL glGetFloatv(GL_MODELVIEW_MATRIX, cubeXform)
!
       CALL DrawCube(RED)        ! draw cube
       CALL glPopMatrix()
!
       CALL glDepthMask(.FALSE._glboolean)
       CALL glEnable(GL_BLEND)
       IF (useLogo) CALL glEnable(GL_POLYGON_STIPPLE)
       IF (useFog) CALL glDisable(GL_FOG)
       CALL glPushMatrix()
       CALL myShadowMatrix(groundPlane, lightPos)
       CALL glTranslatef(0.0, 0.0, 2.0)
       CALL glMultMatrixf(RESHAPE(cubeXform,(/4,4/)))
!
       CALL DrawCube(BLACK)      ! draw ground shadow
       CALL glPopMatrix()
!
       CALL glPushMatrix()
       CALL myShadowMatrix(backPlane, lightPos)
       CALL glTranslatef(0.0, 0.0, 2.0)
       CALL glMultMatrixf(RESHAPE(cubeXform,(/4,4/)))
!
       CALL DrawCube(BLACK)      ! draw back shadow
       CALL glPopMatrix()
!
       CALL glDepthMask(.TRUE._glboolean)
       CALL glDisable(GL_BLEND)
       IF (useLogo) CALL glDisable(GL_POLYGON_STIPPLE)
       IF (useFog) CALL glEnable(GL_FOG)
       IF (useDB) THEN
           CALL WglSwapBuffers()
       ELSE
           CALL glFlush()
       ENDIF
       RETURN
       END SUBROUTINE display
!
!******************************************************************************
!
       SUBROUTINE SetupDisplay()
!
!  Do display setup that only needs to be done once.
!
       USE SCUBE_MOD
!
       IMPLICIT NONE
       REAL(glfloat) rGL_EXP
!
!  Since we are using animation we will use double-buffering to eliminate flicker.
!  To do this we should set the Draw and Read buffers to the back buffer.
!
      CALL glReadBuffer(GL_BACK)
      CALL glDrawBuffer(GL_BACK)
!
      CALL glLoadIdentity()
!
      CALL glMatrixMode(GL_PROJECTION)
      CALL glLoadIdentity()
      CALL glFrustum(-1.0_gldouble, 1.0_gldouble, -1.0_gldouble, &
                      1.0_gldouble, 1.0_gldouble,  3.0_gldouble)
!
      CALL glMatrixMode(GL_MODELVIEW)
      CALL glLoadIdentity()
      CALL glTranslatef(0.0, 0.0, -2.0)
!
      CALL glEnable(GL_DEPTH_TEST)
!
      IF (useLighting) CALL glEnable(GL_LIGHTING)
      CALL glEnable(GL_LIGHT0)
      CALL glLightfv(GL_LIGHT0, GL_POSITION, lightPos)
      CALL glLightfv(GL_LIGHT0, GL_AMBIENT,  lightAmb)
      CALL glLightfv(GL_LIGHT0, GL_DIFFUSE,  lightDiff)
      CALL glLightfv(GL_LIGHT0, GL_SPECULAR, lightSpec)
!
      CALL glEnable(GL_NORMALIZE)
!
      IF (useFog) CALL glEnable(GL_FOG)
      CALL glFogfv(GL_FOG_COLOR, fogColour)
      CALL glFogfv(GL_FOG_INDEX, fogIndex)
      rGL_EXP = GL_EXP
      CALL glFogf(GL_FOG_MODE, rGL_EXP)
      CALL glFogf(GL_FOG_DENSITY, 0.5)
      CALL glFogf(GL_FOG_START, 1.0)
      CALL glFogf(GL_FOG_END, 3.0)
!
      CALL glEnable(GL_CULL_FACE)
      CALL glCullFace(GL_BACK)
!
      CALL glShadeModel(GL_SMOOTH)
!
      CALL glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA)
      IF (useLogo) CALL glPolygonStipple(sgiPattern)
!
      CALL glClearColor(0.0, 0.0, 0.0, 1.0)
      CALL glClearIndex(0.)
      CALL glClearDepth(1._gldouble)
      RETURN
      END SUBROUTINE SetupDisplay
!
      END PROGRAM SCUBE