!  ********************************************************************
!  * 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 OLYMPIC_MOD
!
      USE WINTERACTER
      USE OPENGL
!
      IMPLICIT NONE
!
      INTEGER, PARAMETER :: NRINGS     =   5
      INTEGER, PARAMETER :: BLUERING   =   1
      INTEGER, PARAMETER :: BLACKRING  =   2
      INTEGER, PARAMETER :: REDRING    =   3
      INTEGER, PARAMETER :: YELLOWRING =   4
      INTEGER, PARAMETER :: GREENRING  =   5
      INTEGER, PARAMETER :: BLACK      =   0
      INTEGER, PARAMETER :: RED        =   1
      INTEGER, PARAMETER :: GREEN      =   2
      INTEGER, PARAMETER :: YELLOW     =   3
      INTEGER, PARAMETER :: BLUE       =   4
      INTEGER, PARAMETER :: MAGENTA    =   5
      INTEGER, PARAMETER :: CYAN       =   6
      INTEGER, PARAMETER :: WHITE      =   7
!
      REAL(glfloat), PARAMETER :: BACKGROUND = 8.0
!
!  Options - experiment with these parameters
!
      LOGICAL, PARAMETER :: rgb          = .TRUE.
      LOGICAL, PARAMETER :: doubleBuffer = .TRUE.
!
      INTEGER(glubyte), DIMENSION(NRINGS,3) :: rgb_colours
      INTEGER(glint)  , DIMENSION(NRINGS)   :: mapped_colours
      REAL(glfloat)   , DIMENSION(NRINGS,3) :: dests
      REAL(glfloat)   , DIMENSION(NRINGS,3) :: offsets
      REAL(glfloat)   , DIMENSION(NRINGS)   :: angs
      REAL(glfloat)   , DIMENSION(NRINGS,3) :: rotAxis
      INTEGER         , DIMENSION(NRINGS)   :: iters
!
      INTEGER(gluint) :: theTorus
!
      END MODULE OLYMPIC_MOD
!
!******************************************************************************
!
      PROGRAM OLYMPIC
!
      USE OLYMPIC_MOD
!
      IMPLICIT NONE
      TYPE(WIN_MESSAGE) :: MESSAGE
      INTEGER           :: ITYPE
!
      INTEGER(glsizei)  :: IWIDTH,IHEIGHT
!
!  Initialise Winteracter
!
      CALL WInitialise()
!
!  Open root window
!
      CALL WindowOpen(FLAGS=SysMenuOn+MinButton+MaxButton+StatusBar,  &
                      WIDTH=512,HEIGHT=384,TITLE='Olympic Rings')
!
!  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
!
      IF (doubleBuffer) THEN
          CALL WglSelect(1,0,2)
      ELSE
          CALL WglSelect(1)
      END IF
!
!  Display prompt in status bar
!
      CALL WindowOutStatusBar(1,'Press SPACE to restart animation')
!
!  Set up display
!
      CALL SetupDisplay()
!
!  Draw initial display
!
      CALL Display()
!
!  Main message loop
!
      DO
        CALL WMessagePeek(ITYPE, MESSAGE)
        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
            IF (doubleBuffer) CALL glDrawBuffer(GL_FRONT_AND_BACK)
            CALL glViewPort(0_glsizei,0_glsizei,IWIDTH,IHEIGHT) ! Adjust viewport
            IF (doubleBuffer) CALL glDrawBuffer(GL_BACK)
            CALL Display()                                      ! Re-do current display
          CASE (KeyDown)
            IF (MESSAGE%VALUE1 == 32) CALL ReInit()
          CASE (CloseRequest)
            EXIT
        END SELECT
      END DO
!
!  Terminate Open-GL and Winteracter
!
      CALL WglSelect(0)
      CALL WindowClose()
      STOP
!
      CONTAINS
!
!******************************************************************************
!
      SUBROUTINE FillTorus(rc, numc, rt, numt)
!
!  Fills a torus
!
      USE OLYMPIC_MOD
!
      IMPLICIT NONE
      REAL,    INTENT(IN) :: rc, rt
      INTEGER, INTENT(IN) :: numc, numt
!
      INTEGER         :: i, j, k
      REAL            :: s, t
      REAL(glfloat)   :: x, y, z
!
      REAL, PARAMETER :: pi    = 3.141592654
      REAL, PARAMETER :: twopi = 2.0 * PI
!
      DO i = 0, numc-1
        CALL glBegin(GL_QUAD_STRIP)
        DO j = 0, numt
          DO k = 1, 0, -1
            s = mod((i + k), numc) + 0.5
            t = mod(j, numt)
            x = cos(t * twopi / numt) * cos(s * twopi / numc)
            y = sin(t * twopi / numt) * cos(s * twopi / numc)
            z = sin(s * twopi / numc)
            CALL glNormal3f(x, y, z)
            x = (rt + rc * cos(s * twopi / numc)) * cos(t * twopi / numt)
            y = (rt + rc * cos(s * twopi / numc)) * sin(t * twopi / numt)
            z = rc * sin(s * twopi / numc)
            CALL glVertex3f(x, y, z)
          END DO
        END DO
        CALL glEnd()
      END DO
      RETURN
      END SUBROUTINE FillTorus
!
!******************************************************************************
!
      SUBROUTINE ReInit()
!
!  Restarts the animation
!
      USE OLYMPIC_MOD
!
      IMPLICIT NONE
      REAL    :: deviation
      INTEGER :: IRING
!
      deviation = rMyRand()/2.
      deviation = deviation * deviation
      do IRING = 1, NRINGS
        offsets(IRING,1) = rMyRand()
        offsets(IRING,2) = rMyRand()
        offsets(IRING,3) = rMyRand()
        angs(IRING) = 260.0 * rMyRand()
        rotAxis(IRING,1) = rMyRand()
        rotAxis(IRING,2) = rMyRand()
        rotAxis(IRING,3) = rMyRand()
        iters(IRING) = (deviation * rMyRand() + 60.0)
      END DO
      RETURN
      END SUBROUTINE ReInit
!
!******************************************************************************
!
      SUBROUTINE Idle()
!
      USE OLYMPIC_MOD
!
      IMPLICIT NONE
      LOGICAL :: MORE
      INTEGER :: IRING,J
!
      MORE = .FALSE.
!
!  Called when no messages are waiting to be processed.
!  Calculates and displays next frame of animation, if not already finished.
!
      DO IRING = 1, NRINGS
          IF (iters(IRING) /= 0) THEN
              DO J = 1, 3
                  offsets(IRING,J) = Clamp(iters(IRING), offsets(IRING,J))
              END DO
              angs(IRING) = Clamp(iters(IRING), angs(IRING))
              iters(IRING) = iters(IRING) - 1
              MORE = .TRUE.
          END IF
      END DO
!
      IF (MORE) CALL Display()
      RETURN
      END SUBROUTINE Idle
!
!******************************************************************************
!
      SUBROUTINE Display()
!
!  Display current frame of animation
!
      USE OLYMPIC_MOD
!
      IMPLICIT NONE
      INTEGER :: IRING
!
      CALL glPushMatrix()
!
      CALL glClear(ior(GL_COLOR_BUFFER_BIT,GL_DEPTH_BUFFER_BIT))
      CALL gluLookAt(0._gldouble, 0._gldouble, 10._gldouble, &
                     0._gldouble, 0._gldouble,  0._gldouble, &
                     0._gldouble, 1._gldouble,  0._gldouble)
!
      DO IRING = 1, NRINGS
          IF (rgb) THEN
              CALL glColor3ubv(rgb_colours(IRING,:))
          ELSE
              CALL glIndexi(mapped_colours(IRING))
          END IF
          CALL glPushMatrix()
          CALL glTranslatef(dests(IRING,1) + offsets(IRING,1), &
                            dests(IRING,2) + offsets(IRING,2), &
                            dests(IRING,3) + offsets(IRING,3))
          CALL glRotatef(angs(IRING),rotAxis(IRING,1),rotAxis(IRING,2),rotAxis(IRING,3))
          CALL glCallList(theTorus)
          CALL glPopMatrix()
      END DO
!
      CALL glPopMatrix()
!
!  Either swap buffers or flush pending operations depending on if we are
!  using double-buffering or not.
!
      IF (doubleBuffer) THEN
          CALL WglSwapBuffers()
      ELSE
          CALL glFlush()
      END IF
      RETURN
      END SUBROUTINE Display
!
!******************************************************************************
!
      SUBROUTINE SetupDisplay()
!
!  Sets up display
!
!  This routine doesn't actually produce any output.
!  that is done by the Display() routine.
!
      USE OLYMPIC_MOD
!
      IMPLICIT NONE
      REAL(glfloat)       :: top_y = 1.0
      REAL(glfloat)       :: bottom_y = 0.0
      REAL(glfloat)       :: top_z = 0.15
      REAL(glfloat)       :: bottom_z = 0.69
      REAL(glfloat)       :: spacing = 2.5
      REAL(glfloat), SAVE :: lmodel_ambient(4) = (/0.0, 0.0, 0.0, 0.0/)
      REAL(glfloat), SAVE :: lmodel_twoside(1) = (/GL_FALSE/)
      REAL(glfloat), SAVE :: lmodel_local(1) = (/GL_FALSE/)
      REAL(glfloat), SAVE :: light0_ambient(4) = (/0.1, 0.1, 0.1, 1.0/)
      REAL(glfloat), SAVE :: light0_diffuse(4) = (/1.0, 1.0, 1.0, 0.0/)
      REAL(glfloat), SAVE :: light0_position(4) = (/0.8660254, 0.5, 1.0, 0.0/)
      REAL(glfloat), SAVE :: light0_specular(4) = (/1.0, 1.0, 1.0, 0.0/)
      REAL(glfloat), SAVE :: bevel_mat_ambient(4) = (/0.0, 0.0, 0.0, 1.0/)
      REAL(glfloat), SAVE :: bevel_mat_shininess(1) = (/40.0/)
      REAL(glfloat), SAVE :: bevel_mat_specular(4) = (/1.0, 1.0, 1.0, 0.0/)
      REAL(glfloat), SAVE :: bevel_mat_diffuse(4) = (/1.0, 0.0, 0.0, 0.0/)
!
!  If double-buffering is enabled the 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
!
      CALL RANDOM_SEED()
      CALL ReInit()
!
      rgb_colours(BLUERING,  :)  = (/  0,  0,255/)
      rgb_colours(REDRING,   :)  = (/255,  0,  0/)
      rgb_colours(GREENRING, :)  = (/  0,255,  0/)
      rgb_colours(YELLOWRING,:)  = (/255,255,  0/)
      rgb_colours(BLACKRING, :)  = (/  0,  0,  0/)
!
      mapped_colours(BLUERING)   = BLUE
      mapped_colours(REDRING)    = RED
      mapped_colours(GREENRING)  = GREEN
      mapped_colours(YELLOWRING) = YELLOW
      mapped_colours(BLACKRING)  = BLACK
!
      dests(BLUERING,:)   = (/-spacing, top_y, top_z/)
      dests(BLACKRING,:)  = (/0.0, top_y, top_z/)
      dests(REDRING,:)    = (/spacing, top_y, top_z/)
      dests(YELLOWRING,:) = (/-spacing / 2.0, bottom_y, bottom_z/)
      dests(GREENRING,:)  = (/spacing / 2.0, bottom_y, bottom_z/)
!
      theTorus = glGenLists(1)
      CALL glNewList(theTorus,GL_COMPILE)
      CALL FillTorus(0.1,8,1.0,25)
      CALL glEndList()
!
      CALL glEnable(GL_CULL_FACE)
      CALL glCullFace(GL_BACK)
      CALL glEnable(GL_DEPTH_TEST)
      CALL glClearDepth(1.0_glclampd)
!
      IF (rgb) THEN
          CALL glClearColor(0.5_glclampf,0.5_glclampf,0.5_glclampf,0.0_glclampf)
          CALL glLightfv(GL_LIGHT0,GL_AMBIENT ,light0_ambient)
          CALL glLightfv(GL_LIGHT0,GL_DIFFUSE ,light0_diffuse)
          CALL glLightfv(GL_LIGHT0,GL_SPECULAR,light0_specular)
          CALL glLightfv(GL_LIGHT0,GL_POSITION,light0_position)
          CALL glEnable(GL_LIGHT0)
!
          CALL glLightModelfv(GL_LIGHT_MODEL_LOCAL_VIEWER,lmodel_local)
          CALL glLightModelfv(GL_LIGHT_MODEL_TWO_SIDE    ,lmodel_twoside)
          CALL glLightModelfv(GL_LIGHT_MODEL_AMBIENT     ,lmodel_ambient)
          CALL glEnable(GL_LIGHTING)
!
          CALL glMaterialfv(GL_FRONT,GL_AMBIENT  ,bevel_mat_ambient)
          CALL glMaterialfv(GL_FRONT,GL_SHININESS,bevel_mat_shininess)
          CALL glMaterialfv(GL_FRONT,GL_SPECULAR ,bevel_mat_specular)
          CALL glMaterialfv(GL_FRONT,GL_DIFFUSE  ,bevel_mat_diffuse)
!
          CALL glColorMaterial(GL_FRONT_AND_BACK,GL_DIFFUSE)
          CALL glEnable(GL_COLOR_MATERIAL)
          CALL glShadeModel(GL_SMOOTH)
      ELSE
          CALL glClearIndex(BACKGROUND)
          CALL glShadeModel(GL_FLAT)
      END IF
!
      CALL glMatrixMode(GL_PROJECTION)
      CALL gluPerspective(45._gldouble,1.33_gldouble,0.1_gldouble,100.0_gldouble)
      CALL glMatrixMode(GL_MODELVIEW)
      RETURN
      END SUBROUTINE SetupDisplay
!
!******************************************************************************
!
      REAL FUNCTION Clamp(iters_left,t)
!
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: iters_left
      REAL,    INTENT(IN) :: t
!
      IF (iters_left < 3) THEN
          clamp = 0.0
      ELSE
          clamp = (iters_left - 2) * t / iters_left
      END IF
      RETURN
      END FUNCTION clamp
!
!******************************************************************************
!
      REAL FUNCTION rMyRand()
!
      IMPLICIT NONE
      REAL :: RVAL
!
      CALL RANDOM_NUMBER(RVAL)
      rMyRand = 10.0 * (RVAL - 0.5)
      RETURN
      END FUNCTION rMyRand
!
      END PROGRAM OLYMPIC