Quelle  olympic3.f90

! This variant of olympic allows command line arguments.  Handling command line
! arguments in Fortran is a nonstandard extension that is done differently
! by different compilers.  This routine uses the form that SGI uses.  It can
! be used with other compilers that use the same convention, or can be
! modified for other conventions.

module olympic_mod
use opengl_gl
use opengl_glu
use opengl_glut

integer, parameter :: &
   XSIZE      = 100, &
   YSIZE      = 75, &
   RINGS      = 5, &
   BLUERING   = 0, &
   BLACKRING  = 1, &
   REDRING    = 2, &
   YELLOWRING = 3, &
   GREENRING  = 4, &
   BLACK      = 0, &
   RED        = 1, &
   GREEN      = 2, &
   YELLOW     = 3, &
   BLUE       = 4, &
   MAGENTA    = 5, &
   CYAN       = 6, &
   WHITE      = 7

real(glfloat), parameter :: BACKGROUND = 8.

integer, parameter :: double = kind(0.0d0)

real, parameter :: M_PI = 3.141592654

integer(glenum) rgb, doubleBuffer, directRender

integer(glubyte) rgb_colors(0:RINGS-1,0:2)
integer(glint) mapped_colors(0:RINGS-1)
real(glfloat) dests(0:RINGS-1,0:2)
real(glfloat) offsets(0:RINGS-1,0:2)
real(glfloat) angs(0:RINGS-1)
real(glfloat) rotAxis(0:RINGS-1,0:2)
integer iters(0:RINGS-1)
integer(gluint) theTorus

contains

subroutine FillTorus(rc, numc, rt, numt)
real, intent(in) :: rc, rt
integer, intent(in) :: numc, numt

  integer :: i, j, k
  real :: s, t
  real(glfloat) x, y, z
  real pi, twopi

  pi = M_PI
  twopi = 2 * 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

function Clamp(iters_left,t)
real :: clamp
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
  endif
return
end function clamp

function MyRand()
real :: myrand
real :: rval

  call random_number(rval)
  myrand = 10.0 * (rval - 0.5)

return
end function myrand

subroutine ReInit()

  integer :: i
  real :: deviation

  deviation = MyRand() / 2
  deviation = deviation * deviation
  do i = 0, RINGS-1
    offsets(i,0) = MyRand()
    offsets(i,1) = MyRand()
    offsets(i,2) = MyRand()
    angs(i) = 260.0 * MyRand()
    rotAxis(i,0) = MyRand()
    rotAxis(i,1) = MyRand()
    rotAxis(i,2) = MyRand()
    iters(i) = (deviation * MyRand() + 60.0)
  end do

return
end subroutine reinit

subroutine Init()

  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/)

  call random_seed()
  call ReInit()
  rgb_colors = 0
  rgb_colors(BLUERING,2) = ibset(127,7)
  rgb_colors(REDRING,0) = ibset(127,7)
  rgb_colors(GREENRING,1) = ibset(127,7)
  rgb_colors(YELLOWRING,0) = ibset(127,7)
  rgb_colors(YELLOWRING,1) = ibset(127,7)
  mapped_colors(BLUERING) = BLUE
  mapped_colors(REDRING) = RED
  mapped_colors(GREENRING) = GREEN
  mapped_colors(YELLOWRING) = YELLOW
  mapped_colors(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 == GL_TRUE) 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)
  endif

  call glMatrixMode(GL_PROJECTION)
  call gluPerspective(45._gldouble, 1.33_gldouble, 0.1_gldouble, 100.0_gldouble)
  call glMatrixMode(GL_MODELVIEW)

return
end subroutine init

end module olympic_mod

subroutine Idle()
use olympic_mod

  integer :: i, j
  integer(glenum) :: more = GL_FALSE

  do i = 0, RINGS-1
    if (iters(i) /= 0) then
      do j = 0, 2
        offsets(i,j) = Clamp(iters(i), offsets(i,j))
      end do
      angs(i) = Clamp(iters(i), angs(i))
      iters(i) = iters(i) - 1
      more = GL_TRUE
    end if
  end do
  if (more == GL_TRUE) then
    call glutPostRedisplay()
  else
    call glutIdleFunc(glutnullfunc)
  endif

return
end subroutine idle

subroutine Reshape(width,height)
use olympic_mod
integer(glcint) width, height

! if glcint is not the same as glsizei, width and height will
! need to be copied to variables of the later kind

  call glViewport(0_glint, 0_glint, width, height)

return
end subroutine reshape

subroutine Key(ikey, x, y)
use olympic_mod
integer(glcint) ikey, x, y
interface
  subroutine idle()
  end subroutine idle
end interface

  select case(ikey)
  case (27) ! esc
    stop
  case (iachar(' '))
    call ReInit()
    call glutIdleFunc(Idle)
  end select

return
end subroutine key

subroutine visible(vis)
use olympic_mod
integer(glcint) vis
interface
  subroutine idle()
  end subroutine idle
end interface

  if (vis == GLUT_VISIBLE) then
    call glutIdleFunc(Idle)
  else
    call glutIdleFunc(glutnullfunc)
  endif

return
end subroutine visible

subroutine DrawScene()
use olympic_mod

  integer :: i

  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 i = 0, RINGS-1
    if (rgb == GL_TRUE) then
      call glColor3ubv(rgb_colors(i,:))
    else
      call glIndexi(mapped_colors(i))
    endif
    call glPushMatrix()
    call glTranslatef(dests(i,0) + offsets(i,0), dests(i,1) + offsets(i,1), &
      dests(i,2) + offsets(i,2))
    call glRotatef(angs(i), rotAxis(i,0), rotAxis(i,1), rotAxis(i,2))
    call glCallList(theTorus)
    call glPopMatrix()
  end do

  call glPopMatrix()
  if (doubleBuffer == GL_TRUE) then
    call glutSwapBuffers()
  else
    call glFlush()
  endif
return
end subroutine drawscene

program main

  use olympic_mod

  integer(glenum) :: type
  integer :: i
  interface
    subroutine Reshape(width,height)
    use olympic_mod
    integer(glcint), intent(inout):: width, height
    end subroutine reshape

    subroutine Key(ikey, x, y)
    use olympic_mod
    integer(glcint), intent(inout):: ikey, x, y
    end subroutine key

    subroutine visible(vis)
    use olympic_mod
    integer(glcint), intent(inout):: vis
    end subroutine visible

    subroutine drawscene
    end subroutine drawscene
  end interface

! declarations for command line arguments
  integer(kind=glcint) :: num_arg
  character(len=32), allocatable, dimension(:) :: args
  integer, external :: iargc

  call glutInitWindowSize(400_glcint, 300_glcint)

  rgb = GL_TRUE
  doubleBuffer = GL_TRUE
  num_arg = iargc()+1
  allocate(args(num_arg))
  args(1) = "olympic"
  do i=2,num_arg
    call getarg(i-1,args(i))
    if (args(i) == "-ci") then
      rgb = GL_FALSE
    else if (args(i) == "-rgb") then
      rgb = GL_TRUE
    else if (args(i) == "-sb") then
      doubleBuffer = GL_FALSE
    else if (args(i) == "-db") then
      doubleBuffer = GL_TRUE
    end if
  end do
  call glutinit(num_arg,args)

  if (rgb == GL_TRUE) then
     type = GLUT_RGB
  else
     type = GLUT_INDEX
  endif

  if (doubleBuffer == GL_TRUE) then
     type = ior(type,GLUT_DOUBLE)
  else
     type = ior(type,GLUT_SINGLE)
  endif
  call glutInitDisplayMode(type)

  i = glutCreateWindow("Olympic")

  call Init()

  call glutReshapeFunc(Reshape)
  call glutKeyboardFunc(Key)
  call glutDisplayFunc(DrawScene)

  call glutVisibilityFunc(visible)

  call glutMainLoop()

end program main