!  ********************************************************************
!  * 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.                   *
!  *                                                                  *
!  ********************************************************************
!
      PROGRAM GEARS
!
! Animated 3D Gear Wheels
!
      USE WINTERACTER
      USE OPENGL
!
      IMPLICIT NONE
!
      LOGICAL            :: doubleBuffer = .TRUE.   ! Use double buffering
!
      REAL(glfloat)      :: pos(4)       = (/5.0, 5.0, 10.0, 0.0/)
      REAL(glfloat)      :: red(4)       = (/0.8, 0.1, 0.0, 1.0/)
      REAL(glfloat)      :: green(4)     = (/0.0, 0.8, 0.2, 1.0/)
      REAL(glfloat)      :: blue(4)      = (/0.2, 0.2, 1.0, 1.0/)
!
!
      REAL(glfloat)      :: view_rotx    = 20.0
      REAL(glfloat)      :: view_roty    = 30.0
      REAL(glfloat)      :: view_rotz    =  0.0
!
      INTEGER(glint)     :: theGear1,theGear2,theGear3
!
      REAL(glfloat)      :: angle        =  0.0
      INTEGER, PARAMETER :: frames       = 10     ! Animation frame
      INTEGER            :: curFrame     =  1     ! information
      INTEGER            :: nextFrame    =  0
      INTEGER            :: ITIME
!
      TYPE(WIN_MESSAGE)  :: MESSAGE
      INTEGER            :: IFLAGS,ITYPE
!
!  Initialise Winteracter.
!
      CALL WInitialise()
!
!  Open root window.
!
      CALL WindowOpen(FLAGS=SysMenuOn+MinButton+MaxButton+StatusBar,  &
                      WIDTH=400,HEIGHT=400,TITLE='Animated Gear Wheels')
!
!  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
          IFLAGS = 2
      ELSE
          IFLAGS = 0
      END IF
      CALL WglSelect(1,0,IFLAGS)
!
!  Display prompt in status bar
!
      CALL WindowOutStatusBar(1,"Use the cursor keys, 'z' and 'Z' to rotate image")
!
!  Set up display
!
      CALL DisplaySetup()
      CALL DisplayResize(400,400)
!
!  Draw initial display
!
      ITIME = WInfoSystem(SystemTime)
      CALL Display()
!
! Main message loop
!
      DO
        CALL WMessagePeek(ITYPE,MESSAGE)
        SELECT CASE (ITYPE)
          CASE (-1) ! No message
            CALL Idle()
          CASE (Expose)
            CALL Display()
          CASE (Resize)
            CALL DisplayResize(MESSAGE%WPIX,MESSAGE%HPIX)
          CASE (KeyDown)
            CALL ProcessKey(MESSAGE%VALUE1)
          CASE (CloseRequest)
            EXIT
        END SELECT
      END DO
!
!  Terminate Open-GL and Winteracter
!
      CALL WglSelect(0)
      CALL WindowClose()
!
      STOP
!
      CONTAINS
!
!*****************************************************************************
!
      SUBROUTINE ProcessKey(IDENT)
!
! Process keydown events
!
      INTEGER, INTENT(IN) :: IDENT
!
      SELECT CASE (IDENT)
          CASE (KeyCursorUp)
              view_rotx = view_rotx + 5.0
          CASE (KeyCursorDown)
              view_rotx = view_rotx - 5.0
          CASE (KeyCursorRight)
              view_roty = view_roty + 5.0
          CASE (KeyCursorLeft)
              view_roty = view_roty - 5.0
          CASE (122)   ! If the letter 'z' is pressed
              view_rotz = view_rotz + 5.0
          CASE (90)    ! If the letter 'Z' is pressed
              view_rotz = view_rotz - 5.0
      END SELECT
!
      RETURN
      END SUBROUTINE ProcessKey
!
!*****************************************************************************
!
      SUBROUTINE Display()
!
! Draw the display list
!
      CALL glClear(ior(GL_COLOR_BUFFER_BIT,GL_DEPTH_BUFFER_BIT))
!
      CALL glPushMatrix()
      CALL glRotatef(view_rotx, 1.0_glfloat, 0.0_glfloat, 0.0_glfloat)
      CALL glRotatef(view_roty, 0.0_glfloat, 1.0_glfloat, 0.0_glfloat)
      CALL glRotatef(view_rotz, 0.0_glfloat, 0.0_glfloat, 1.0_glfloat)
!
      CALL glPushMatrix()
      CALL glTranslatef(-3.0_glfloat, -2.0_glfloat, 0.0_glfloat)
      CALL glRotatef(angle, 0.0_glfloat, 0.0_glfloat, 1.0_glfloat)
      CALL glCallList(theGear1)
      CALL glPopMatrix()
!
      CALL glPushMatrix()
      CALL glTranslatef(3.1_glfloat, -2.0_glfloat, 0.0_glfloat)
      CALL glRotatef(-2.0_glfloat*angle-9.0_glfloat, 0.0_glfloat, 0.0_glfloat, 1.0_glfloat)
      CALL glCallList(theGear2)
      CALL glPopMatrix()
!
      CALL glPushMatrix()
      CALL glTranslatef(-3.1_glfloat, 4.2_glfloat, 0.0_glfloat)
      CALL glRotatef(-2.0_glfloat*angle-25.0_glfloat, 0.0_glfloat, 0.0_glfloat, 1.0_glfloat)
      CALL glCallList(theGear3)
      CALL glPopMatrix()
!
      CALL glPopMatrix()
!
      IF (doubleBuffer) THEN
          CALL WglSwapBuffers()
      ELSE
          CALL glFlush()
      END IF
!
!  The following call ensures better keyboard response under X Windows.
!  Specifically, XFree86 v4 seems to give much worse response without
!  this call than earlier releases. Including this call has some impact
!  on animation speed under X however. (Note : this is simply a 'null'
!  call under Microsoft Windows)
!
      CALL WFlushBuffer()
!
      RETURN
      END SUBROUTINE Display
!
!*****************************************************************************
!
      SUBROUTINE DisplaySetup()
!
! Initialise the objects that are drawn
!
! 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
!
      CALL glLightfv(GL_LIGHT0,GL_POSITION, pos)
      CALL glEnable(GL_CULL_FACE)
      CALL glEnable(GL_LIGHTING)
      CALL glEnable(GL_LIGHT0)
      CALL glEnable(GL_DEPTH_TEST)
!
! Create the gears
!
      theGear1 = glGenLists(1)
      CALL glNewList(theGear1,GL_COMPILE)
      CALL glMaterialfv(GL_FRONT,GL_AMBIENT_AND_DIFFUSE,red)
      CALL Gear(1.0,4.0,1.0,20,0.7)
      CALL glEndList()
!
      theGear2 = glGenLists(1)
      CALL glNewList(theGear2,GL_COMPILE)
      CALL glMaterialfv(GL_FRONT,GL_AMBIENT_AND_DIFFUSE,green)
      CALL Gear(0.5,2.0,2.0,10,0.7)
      CALL glEndList()
!
      theGear3 = glGenLists(1)
      CALL glNewList(theGear3,GL_COMPILE)
      CALL glMaterialfv(GL_FRONT,GL_AMBIENT_AND_DIFFUSE,blue)
      CALL Gear(1.3,2.0,0.5,10,0.7)
      CALL glEndList()
!
      CALL glEnable(GL_NORMALIZE)
      RETURN
      END SUBROUTINE DisplaySetup
!
!*****************************************************************************
!
      SUBROUTINE DisplayResize(IWIDTH,IHEIGHT)
!
! Resize the OpenGL image to fit the window
!
      INTEGER,  INTENT(IN) :: IWIDTH
      INTEGER,  INTENT(IN) :: IHEIGHT
!
      INTEGER(glsizei)     :: IGWIDTH,IGHEIGHT
      REAL(gldouble)       :: RGWIDTH,RGHEIGHT,RGASPECT
!
      IGWIDTH  = IWIDTH
      IGHEIGHT = IHEIGHT
!
      RGWIDTH  = IWIDTH
      RGHEIGHT = IHEIGHT
!
      RGASPECT = RGHEIGHT/RGWIDTH
!
      IF (doubleBuffer) CALL glDrawBuffer(GL_FRONT_AND_BACK)
      CALL glViewport(0_glsizei,0_glsizei,IGWIDTH,IGHEIGHT)
      IF (doubleBuffer) CALL glDrawBuffer(GL_BACK)
!
      CALL glMatrixMode(GL_PROJECTION)
      CALL glLoadIdentity()
      CALL glFrustum(-1.0_gldouble, &
                      1.0_gldouble, &
                     -RGASPECT,     &
                      RGASPECT,     &
                      5.0_gldouble, &
                     60.0_gldouble)
      CALL glMatrixMode(GL_MODELVIEW)
      CALL glLoadIdentity()
      CALL glTranslatef( 0.0_glfloat, 0.0_glfloat, -40.0_glfloat)
      CALL glClear(ior(GL_COLOR_BUFFER_BIT,GL_DEPTH_BUFFER_BIT))
!
      CALL Display()
      RETURN
      END SUBROUTINE DisplayResize
!
!*****************************************************************************
!
      SUBROUTINE Idle()
!
! If there are no messages to process, draw another frame of the animation
!
      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
          angle = angle + 2.0_glfloat
          CALL Display()
      END IF
      RETURN
      END SUBROUTINE Idle
!
!*****************************************************************************
!
      SUBROUTINE Gear(INNRADIUS,OUTRADIUS,WIDTH,TEETH,TOOTHDEPTH)
!
! Draw a gear wheel.
!
      REAL,    INTENT(IN) :: INNRADIUS  ! Radius of hole at center
      REAL,    INTENT(IN) :: OUTRADIUS  ! Radius at center of teeth
      REAL,    INTENT(IN) :: WIDTH      ! Width of gear
      INTEGER, INTENT(IN) :: TEETH      ! Number of teeth
      REAL,    INTENT(IN) :: TOOTHDEPTH ! Depth of tooth
!
      REAL                :: R0,R1,R2
      REAL                :: ANGL,DA
      REAL                :: U,V,LEN
      INTEGER             :: I
      REAL(glfloat)       :: x, y, z
      REAL, PARAMETER     :: PI = 3.14159265
!
      R0 = INNRADIUS
      R1 = OUTRADIUS - TOOTHDEPTH/2.0
      R2 = OUTRADIUS + TOOTHDEPTH/2.0
      DA = 2.0*PI/(TEETH*4.0)
!
      CALL glShadeModel(GL_FLAT)
      CALL glNormal3f(0.0_glfloat, 0.0_glfloat, 1.0_glfloat)
!
! Draw the front face
!
      CALL glBegin(GL_QUAD_STRIP)
!
      DO I = 0,TEETH
        ANGL = I*2.0*PI/TEETH
        CALL Vertex(R0,ANGL,WIDTH)
        CALL Vertex(R1,ANGL,WIDTH)
        CALL Vertex(R0,ANGL,WIDTH)
        CALL Vertex(R1,ANGL+3.0*DA,WIDTH)
      END DO
!
      CALL glEnd()
!
! Draw front sides of teeth
!
      CALL glBegin(GL_QUADS)
!
      DO I = 0,TEETH-1
          ANGL = I*2.0*PI/TEETH
!
          CALL Vertex(R1,ANGL,WIDTH)
          CALL Vertex(R2,ANGL+DA,WIDTH)
          CALL Vertex(R2,ANGL+2.0*DA,WIDTH)
          CALL Vertex(R1,ANGL+3.0*DA,WIDTH)
      END DO
!
      CALL glEnd()
!
      CALL glNormal3f( 0.0_glfloat, 0.0_glfloat, -1.0_glfloat)
!
! Draw back face
!
      CALL glBegin(GL_QUAD_STRIP)
!
      DO I = 0, TEETH
        ANGL = I*2.0*PI/TEETH
        CALL Vertex(R1,ANGL,-WIDTH)
        CALL Vertex(R0,ANGL,-WIDTH)
        CALL Vertex(R1,ANGL+3.0*DA,-WIDTH)
        CALL Vertex(R0,ANGL,-WIDTH)
      END DO
!
      CALL glEnd()
!
! Draw back sides of teeth
!
      CALL glBegin(GL_QUADS)
!
      DO I= 0, TEETH-1
        ANGL = I*2.0*PI/TEETH
        CALL Vertex(R1,ANGL+3.0*DA,-WIDTH)
        CALL Vertex(R2,ANGL+2.0*DA,-WIDTH)
        CALL Vertex(R2,ANGL+DA,-WIDTH)
        CALL Vertex(R1,ANGL,-WIDTH)
      END DO
!
      CALL glEnd()
!
! Draw outward faces of teeth
!
      CALL glBegin(GL_QUAD_STRIP)
!
      DO I = 0, TEETH-1
        ANGL = I*2.0*PI/TEETH
!
        CALL Vertex(R1,ANGL,WIDTH)
        CALL Vertex(R1,ANGL,-WIDTH)
!
        U   = R2*COS(ANGL+DA) - R1*COS(ANGLE)
        V   = R2*SIN(ANGL+DA) - R1*SIN(ANGLE)
        LEN = SQRT( U*U + V*V )
!
        x = U/LEN
        y = V/LEN
        z = 0.0
!
        CALL glNormal3f(y,-x,z)
!
        CALL Vertex(R2,ANGL+DA,WIDTH)
        CALL Vertex(R2,ANGL+DA,-WIDTH)
!
        x = COS(ANGL)
        y = SIN(ANGL)
        z = 0.0
        CALL glNormal3f(x,y,z)
!
        CALL Vertex(R2,ANGL+2.0*DA,WIDTH)
        CALL Vertex(R2,ANGL+2.0*DA,-WIDTH)
!
        x = R1*COS(ANGL+3.0*DA) - R2*COS(ANGL+2.0*DA)
        y = R1*SIN(ANGL+3.0*DA) - R2*SIN(ANGL+2.0*DA)
        z = 0.0
        CALL glNormal3f( y, -x, z)
!
        CALL Vertex(R1,ANGL+3.0*DA,WIDTH)
        CALL Vertex(R1,ANGL+3.0*DA,-WIDTH)
!
        x = COS(ANGL)
        y = SIN(ANGL)
        z = 0.0
        CALL glNormal3f(x, y, z)
      END DO
!
      CALL Vertex(R1,0.0,WIDTH)
      CALL Vertex(R1,0.0,-WIDTH)
!
      CALL glEnd()
!
      CALL glShadeModel(GL_SMOOTH)
!
! Draw inside radius cylinder
!
      CALL glBegin(GL_QUAD_STRIP)
!
      DO I = 0,TEETH
          ANGL = I*2.0*PI/TEETH
          x = -COS(ANGL)
          y = -SIN(ANGL)
          z = 0.0
          CALL glNormal3f(x,y,z)
          CALL Vertex(R0,ANGL,-WIDTH)
          CALL Vertex(R0,ANGL,WIDTH)
      END DO
!
      CALL glEnd()
      RETURN
      END SUBROUTINE Gear
!
!*****************************************************************************
!
      SUBROUTINE Vertex(R,ANGL,WIDTH)
!
! Specify a vertex
!
      REAL, INTENT(IN) :: R,ANGL,WIDTH
!
      REAL(glfloat) :: x, y, z
!
      x = R*COS(ANGL)
      y = R*SIN(ANGL)
      z = WIDTH*0.5
      CALL glVertex3f(x, y, z)
      RETURN
      END SUBROUTINE Vertex
!
      END PROGRAM GEARS