Quellcode-Bibliothek

^© Kompilation durch diese Firma

[Weder Korrektheit noch Funktionsfähigkeit der Software werden zugesichert.]

Datei: olympic.f90 Sprache: Fortran

Original von: f90gl^©

! In addition to modifications for the F and ELF90 subsets, rgb_colors was
! changed from glubyte to glfloat

module olympic_mod
use opengl_gl
use opengl_glu
use opengl_glut
implicit none
private

public :: fReshape, Key, visible, DrawScene, Init
private :: FillTorus, Clamp, MyRand, ReInit, Idle

integer, parameter, private :: &
   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(kind=glfloat), parameter, private :: BACKGROUND = 8.0

integer, parameter, private :: double = kind(0.0_gldouble)

real, parameter, private :: M_PI = 3.141592654

integer(kind=glenum), public :: rgb, doubleBuffer

!integer(kind=glubyte), private, dimension(0:RINGS-1,0:2) :: rgb_colors
real(kind=glfloat),   private, dimension(0:RINGS-1,0:2) :: rgb_colors
integer(kind=glint), private, dimension(0:RINGS-1) :: mapped_colors
real(kind=glfloat), private, dimension(0:RINGS-1,0:2) :: dests
real(kind=glfloat), private, dimension(0:RINGS-1,0:2) :: offsets
real(kind=glfloat), private, dimension(0:RINGS-1) :: angs
real(kind=glfloat), private, dimension(0:RINGS-1,0:2) :: rotAxis
integer, private, dimension(0:RINGS-1) :: iters
integer(kind=gluint), private :: 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(kind=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 = modulo((i + k), numc) + 0.5
        t = modulo(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) result(resClamp)
integer, intent(in) :: iters_left
real, intent(in) :: t
real :: resClamp

  if (iters_left < 3) then
    resClamp = 0.0
  else
    resClamp = (iters_left - 2) * t / iters_left
  end if
return
end function Clamp

subroutine MyRand(resMyRand)
real, intent(out) :: resMyRand
real :: rval

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

return
end subroutine MyRand

subroutine ReInit()

  integer :: i
  real :: deviation, temp

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

return
end subroutine ReInit

subroutine Init()

  real(kind=glfloat), save :: top_y = 1.0
  real(kind=glfloat), save :: bottom_y = 0.0
  real(kind=glfloat), save :: top_z = 0.15
  real(kind=glfloat), save :: bottom_z = 0.69
  real(kind=glfloat), save :: fspacing = 2.5
  real(kind=glfloat), save, dimension(4) :: lmodel_ambient = (/0.0, 0.0, 0.0, 0.0/)
  real(kind=glfloat), save, dimension(1) :: lmodel_twoside = (/GL_FALSE/)
  real(kind=glfloat), save, dimension(1) :: lmodel_local = (/GL_FALSE/)
  real(kind=glfloat), save, dimension(4) :: light0_ambient = (/0.1, 0.1, 0.1, 1.0/)
  real(kind=glfloat), save, dimension(4) :: light0_diffuse = (/1.0, 1.0, 1.0, 0.0/)
  real(kind=glfloat), save, dimension(4) :: light0_position = (/0.8660254, 0.5, 1.0, 0.0/)
  real(kind=glfloat), save, dimension(4) :: light0_specular = (/1.0, 1.0, 1.0, 0.0/)
  real(kind=glfloat), save, dimension(4) :: bevel_mat_ambient = (/0.0, 0.0, 0.0, 1.0/)
  real(kind=glfloat), save, dimension(1) :: bevel_mat_shininess = (/40.0/)
  real(kind=glfloat), save, dimension(4) :: bevel_mat_specular = (/1.0, 1.0, 1.0, 0.0/)
  real(kind=glfloat), save, dimension(4) :: bevel_mat_diffuse = (/1.0, 0.0, 0.0, 0.0/)

  call random_seed()
  call ReInit()
! changed for glfloat rgb_colors
  rgb_colors = 0.0_glfloat
  rgb_colors(BLUERING,2) = 1.0_glfloat
  rgb_colors(REDRING,0) = 1.0_glfloat
  rgb_colors(GREENRING,1) = 1.0_glfloat
  rgb_colors(YELLOWRING,0) = 1.0_glfloat
  rgb_colors(YELLOWRING,1) = 1.0_glfloat
  mapped_colors(BLUERING) = BLUE
  mapped_colors(REDRING) = RED
  mapped_colors(GREENRING) = GREEN
  mapped_colors(YELLOWRING) = YELLOW
  mapped_colors(BLACKRING) = BLACK

  dests(BLUERING,:) = (/-fspacing, top_y, top_z/)
  dests(BLACKRING,:) = (/0.0, top_y, top_z/)
  dests(REDRING,:) = (/fspacing, top_y, top_z/)
  dests(YELLOWRING,:) = (/-fspacing / 2.0, bottom_y, bottom_z/)
  dests(GREENRING,:) = (/fspacing / 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)
  end if

  call glmatrixmode(GL_PROJECTION)
  call gluperspective(45.0_gldouble, 1.33_gldouble, 0.1_gldouble, 100.0_gldouble)
  call glmatrixmode(GL_MODELVIEW)

return
end subroutine Init

subroutine Idle()

  integer :: i, j
  integer(kind=glenum), save :: 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()
  end if

return
end subroutine Idle

subroutine fReshape(width,height)
integer(kind=glcint), intent(in out) ::  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 fReshape

subroutine Key(ikey, x, y)
integer(kind=glcint), intent(in out) :: ikey, x, y

  select case(ikey)
  case (27) ! esc
    stop
  case (ichar(" "))
    call ReInit()
    call glutidlefunc(Idle)
  end select

return
end subroutine Key

! fortran handling of command line arguments is nonstandard, so
! this feature is omitted.  Here is the original C code.

!GLenum
!Args(int argc, char **argv)
!{
!  GLint i;
!
!  rgb = GL_TRUE;
!  doubleBuffer = GL_TRUE;
!
!  for (i = 1; i < argc; i++) {
!    if (strcmp(argv[i], "-ci") == 0) {
!      rgb = GL_FALSE;
!    } else if (strcmp(argv[i], "-rgb") == 0) {
!      rgb = GL_TRUE;
!    } else if (strcmp(argv[i], "-sb") == 0) {
!      doubleBuffer = GL_FALSE;
!    } else if (strcmp(argv[i], "-db") == 0) {
!      doubleBuffer = GL_TRUE;
!    } else {
!      printf("%s (Bad option).\n", argv[i]);
!      return GL_FALSE;
!    }
!  }
!  return GL_TRUE;
!}

subroutine visible(vis)
integer(kind=glcint), intent(in out) :: vis

  if (vis == GLUT_VISIBLE) then
    call glutidlefunc(Idle)
  else
    call glutidlefunc()
  end if

return
end subroutine visible

subroutine DrawScene()

  integer :: i

  call glpushmatrix()

  call glclear(ior(GL_COLOR_BUFFER_BIT,GL_DEPTH_BUFFER_BIT))
  call glulookat(0.0_gldouble, 0.0_gldouble, 10.0_gldouble, &
                    0.0_gldouble, 0.0_gldouble, 0.0_gldouble, &
                    0.0_gldouble, 1.0_gldouble, 0.0_gldouble)

  do i = 0, RINGS-1
    if (rgb == GL_TRUE) then
!      call glcolor3ubv(rgb_colors(i,:))
      call glcolor3fv(rgb_colors(i,:))
    else
      call glindexi(mapped_colors(i))
    end if
    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()
  end if
return
end subroutine DrawScene

end module olympic_mod

program main

  use opengl_gl
  use opengl_glu
  use opengl_glut
  use olympic_mod
  implicit none

  integer(kind=glenum) :: ftype
  integer :: i

  call glutinitwindowsize(400_glcint, 300_glcint)

! not checking command line arguments
!  glutInit(&argc, argv);
!  if (Args(argc, argv) == GL_FALSE) {
!    exit(1);
!  }
  call glutinit()
  rgb = GL_TRUE           ! default values which could have been
  doubleBuffer = GL_TRUE  ! overwritten by command line arguments

  if (rgb == GL_TRUE) then
     ftype = GLUT_RGB
  else
     ftype = GLUT_INDEX
  end if

  if (doubleBuffer == GL_TRUE) then
     ftype = ior(ftype,GLUT_DOUBLE)
  else
     ftype = ior(ftype,GLUT_SINGLE)
  end if
  call glutinitdisplaymode(ftype)

  i = glutcreatewindow("Olympic")

  call Init()

  call glutreshapefunc(fReshape)
  call glutkeyboardfunc(Key)
  call glutdisplayfunc(DrawScene)

  call glutvisibilityfunc(visible)

  call glutmainloop()

  stop
end program main

¤ Dauer der Verarbeitung: 0.6 Sekunden (vorverarbeitet) ¤

Download des Quellennavigators
Download des sprechenden Kalenders
in der Quellcodebibliothek suchen

Haftungshinweis

Die Informationen auf dieser Webseite wurden nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit, noch Qualität der bereit gestellten Informationen zugesichert.

Bemerkung:

Die farbliche Syntaxdarstellung ist noch experimentell.