Quelle scube.f90 Sprache: Fortran

module scube_mod
use opengl_gl
use opengl_glut
implicit none

logical, save :: &
   useRGB      = .true., &
   useLighting = .true., &
   useFog      = .false., &
   useDB       = .true., &
   useLogo     = .true., &
   useQuads    = .true.

integer, save :: tick = -1
logical, save :: moving = .true.

integer, parameter :: &
   GREY    = 0, &
   RED     = 1, &
   GREEN   = 2, &
   BLUE    = 3, &
   CYAN    = 4, &
   MAGENTA = 5, &
   YELLOW  = 6, &
   BLACK   = 7

real(glfloat), save :: materialColor(8,4) = reshape( &
  (/ 0.8, 0.8, 0.0, 0.0, 0.0, 0.8, 0.8, 0.0, &
     0.8, 0.0, 0.8, 0.0, 0.8, 0.0, 0.8, 0.0, &
     0.8, 0.0, 0.0, 0.8, 0.8, 0.8, 0.0, 0.0, &
     1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.6 /), &
     (/8,4/))

real(glfloat), save :: &
lightPos(4) = (/2.0, 4.0, 2.0, 1.0/), &
lightDir(4) = (/-2.0, -4.0, -2.0, 1.0/), &
lightAmb(4) = (/0.2, 0.2, 0.2, 1.0/), &
lightDiff(4) = (/0.8, 0.8, 0.8, 1.0/), &
lightSpec(4) = (/0.4, 0.4, 0.4, 1.0/)

real(glfloat), save :: &
groundPlane(4) = (/0.0, 1.0, 0.0, 1.499/), &
backPlane(4) = (/0.0, 0.0, 1.0, 0.899/)

real(glfloat), save :: &
fogColor(4) = (/0.0, 0.0, 0.0, 0.0/), &
fogIndex(1) = (/0.0/)

integer(glubyte), save :: shadowPattern(128) ! 50% Grey
data shadowPattern / &
  z'aa', z'aa', z'aa', z'aa', z'55', z'55', z'55', z'55', &
  z'aa', z'aa', z'aa', z'aa', z'55', z'55', z'55', z'55', &
  z'aa', z'aa', z'aa', z'aa', z'55', z'55', z'55', z'55', &
  z'aa', z'aa', z'aa', z'aa', z'55', z'55', z'55', z'55', &
  z'aa', z'aa', z'aa', z'aa', z'55', z'55', z'55', z'55', &
  z'aa', z'aa', z'aa', z'aa', z'55', z'55', z'55', z'55', &
  z'aa', z'aa', z'aa', z'aa', z'55', z'55', z'55', z'55', &
  z'aa', z'aa', z'aa', z'aa', z'55', z'55', z'55', z'55', &
  z'aa', z'aa', z'aa', z'aa', z'55', z'55', z'55', z'55', &
  z'aa', z'aa', z'aa', z'aa', z'55', z'55', z'55', z'55', &
  z'aa', z'aa', z'aa', z'aa', z'55', z'55', z'55', z'55', &
  z'aa', z'aa', z'aa', z'aa', z'55', z'55', z'55', z'55', &
  z'aa', z'aa', z'aa', z'aa', z'55', z'55', z'55', z'55', &
  z'aa', z'aa', z'aa', z'aa', z'55', z'55', z'55', z'55', &
  z'aa', z'aa', z'aa', z'aa', z'55', z'55', z'55', z'55', &
  z'aa', z'aa', z'aa', z'aa', z'55', z'55', z'55', z'55' /

integer(glubyte), save :: sgiPattern(128) ! SGI Logo
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' /

character(len=30), save :: windowNameRGBDB = "shadow cube (OpenGL RGB DB)"
character(len=30), save :: windowNameRGB = "shadow cube (OpenGL RGB)"
character(len=30), save :: windowNameIndexDB = "shadow cube (OpenGL Index DB)"
character(len=30), save :: windowNameIndex = "shadow cube (OpenGL Index)"

end module scube_mod

subroutine buildColormap()
use scube_mod

integer mapSize,rampSize,entry,i,hue
real(glfloat) val,r,g,b

mapSize = 2**glutGet(GLUT_WINDOW_BUFFER_SIZE)
rampSize = mapSize / 8

  if (useRGB) then
    return
  else

    do entry=0,mapSize-1
      hue = entry / rampSize
      val = mod(entry,rampSize) * (1.0 / (rampSize - 1))

      if (hue==0 .or. hue==1 .or. hue==5 .or. hue==6) then
         r = val
      else
         r = 0
      endif
      if (hue==0 .or. hue==2 .or. hue==4 .or. hue==6) then
         g = val
      else
         g = 0
      endif
      if (hue==0 .or. hue==3 .or. hue==4 .or. hue==5) then
         b = val
      else
         b = 0
      endif

      call glutSetColor(entry, r, g, b);
    end do

    do i=1,8
      materialColor(i,1) = i * rampSize + 0.2 * (rampSize - 1)
      materialColor(i,2) = i * rampSize + 0.8 * (rampSize - 1)
      materialColor(i,3) = i * rampSize + 1.0 * (rampSize - 1)
      materialColor(i,4) = 0.0
    end do

    fogIndex(1) = -0.2 * (rampSize - 1)
  endif
end subroutine buildColormap

subroutine setColor(c)
use scube_mod
integer c
! had to move materialColor to here because of bug in SGI f90 compiler
real(glfloat), save :: materialCol(8,4) = reshape( &
  (/ 0.8, 0.8, 0.0, 0.0, 0.0, 0.8, 0.8, 0.0, &
     0.8, 0.0, 0.8, 0.0, 0.8, 0.0, 0.8, 0.0, &
     0.8, 0.0, 0.0, 0.8, 0.8, 0.8, 0.0, 0.0, &
     1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.6 /), &
     (/8,4/))

  if (useLighting) then
    if (useRGB) then
      call glMaterialfv(GL_FRONT_AND_BACK, &
        GL_AMBIENT_AND_DIFFUSE, materialCol(c+1,:))
    else
      call glMaterialfv(GL_FRONT_AND_BACK, &
        GL_COLOR_INDEXES, materialColor(c+1,:))
    endif
  else
    if (useRGB) then
      call glColor4fv(materialCol(c+1,:))
    else
      call glIndexf(materialColor(c+1,1))
    endif
  endif
end subroutine setColor

subroutine drawCube(color)
use scube_mod
integer color

real(glfloat), save :: cube_vertexes(4,4,6) = 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 :: cube_normals(4,6) = 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/) )

  integer i

  call setColor(color)

  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
end subroutine drawCube

subroutine drawCheck(w,h,evenColor,oddColor)
use scube_mod
integer w,h,evenColor,oddColor

  logical, save :: initialized = .false., &
                   usedLighting = .false.
  integer(gluint), save :: checklist = 0
  real, save :: square_normal(4) = (/0.0, 0.0, 1.0, 0.0/)
  real, save :: square(4,4)
  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.0 + 2.0/w * i, -1.0 + 2.0/h * (j+1), 0.0, 1.0/)
        square(:,2) = (/ -1.0 + 2.0/w * i, -1.0 + 2.0/h * j, 0.0, 1.0/)
        square(:,3) = (/ -1.0 + 2.0/w * (i+1), -1.0 + 2.0/h * j, 0.0, 1.0/)
        square(:,4) = (/ -1.0 + 2.0/w * (i+1), -1.0 + 2.0/h * (j+1), 0.0, 1.0/)

        if (ieor(iand(i,1),iand(j,1)) /= 0) then
          call setColor(oddColor)
        else
          call setColor(evenColor)
        endif

        if (.not.useQuads) then
          call glBegin(GL_POLYGON)
        endif
        call glVertex4fv(square(:,1))
        call glVertex4fv(square(:,2))
        call glVertex4fv(square(:,3))
        call glVertex4fv(square(:,4))
        if (.not.useQuads) then
          call glEnd()
        endif
      end do
    end do

    if (useQuads) then
      call glEnd()
    endif
    call glEndList()

    initialized = .true.
    usedLighting = useLighting
  else
    call glCallList(checklist)
  endif
end subroutine drawCheck

subroutine myShadowMatrix(ground,light)
use scube_mod
real ground(4), light(4)

  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)
end subroutine myShadowMatrix

subroutine idle()
use scube_mod

  tick = tick + 1
  if (tick >= 120) then
    tick = 0
  endif
  call glutPostRedisplay()
end subroutine idle

subroutine keyboard(ich, x, y)
use scube_mod
integer, intent(inout) :: ich,x,y

  character ch
  real(glfloat) rGL_LINEAR, rGL_EXP, rGL_EXP2

  ch = achar(ich)
  select case(ch)
  case (achar(27))      ! escape
    stop
  case ('L','l')
    useLighting = .not. useLighting
    if (useLighting) then
       call glEnable(GL_LIGHTING)
    else
       call glDisable(GL_LIGHTING)
    endif
    call glutPostRedisplay()
  case ('F','f')
    useFog = .not. useFog
    if (useFog) then
       call glEnable(GL_FOG)
    else
       call glDisable(GL_FOG)
    endif
    call glutPostRedisplay()
  case ('1')
    rGL_LINEAR = GL_LINEAR
    call glFogf(GL_FOG_MODE, rGL_LINEAR)
    call glutPostRedisplay()
  case ('2')
    rGL_EXP = GL_EXP
    call glFogf(GL_FOG_MODE, rGL_EXP)
    call glutPostRedisplay()
  case ('3')
    rGL_EXP2 = GL_EXP2
    call glFogf(GL_FOG_MODE, rGL_EXP2)
    call glutPostRedisplay()
  case (' ')
    if (.not. moving) then
      call idle()
      call glutPostRedisplay()
    endif
  end select
end subroutine keyboard

subroutine display()
use scube_mod

  real(glfloat) cubeXform(16)

  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)) * tick, 1., 0., 0.)
  call glRotatef((360.0 / (30 * 2)) * tick, 0., 1., 0.)
  call glRotatef((360.0 / (30 * 4)) * tick, 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)
  if (useRGB) then
    call glEnable(GL_BLEND)
  else
    call glEnable(GL_POLYGON_STIPPLE)
  endif
  if (useFog) then
    call glDisable(GL_FOG)
  endif
  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)
  if (useRGB) then
    call glDisable(GL_BLEND)
  else
    call glDisable(GL_POLYGON_STIPPLE)
  endif
  if (useFog) then
    call glEnable(GL_FOG)
  endif
  if(useDB) then
    call glutSwapBuffers()
  else
    call glFlush()
  endif
end subroutine display

subroutine fog_select(fog)
use scube_mod
integer, intent(inout) :: fog

  real(glfloat) rfog
  rfog = fog
  call glFogf(GL_FOG_MODE, rfog)
  call glutPostRedisplay()
end subroutine fog_select

subroutine menu_select(mode)
use scube_mod
integer, intent(inout) :: mode

  interface
    subroutine idle()
    end subroutine idle
  end interface

  select case (mode)
  case (1)
    moving = .true.
    call glutIdleFunc(idle)
  case (2)
    moving = .false.
    call glutIdleFunc(glutnullfunc)
  case (3)
    useFog = .not. useFog
    if (useFog) then
       call glEnable(GL_FOG)
    else
       call glDisable(GL_FOG)
    endif
    call glutPostRedisplay()
  case (4)
    useLighting = .not. useLighting
    if (useLighting) then
       call glEnable(GL_LIGHTING)
    else
       call glDisable(GL_LIGHTING)
    endif
    call glutPostRedisplay()
  case (5)
    stop
  end select
end subroutine menu_select

subroutine visible(state)
use scube_mod
integer, intent(inout) :: state

  interface
    subroutine idle()
    end subroutine idle
  end interface

  if (state == GLUT_VISIBLE) then
    if (moving) then
      call glutIdleFunc(idle)
    endif
  else
    if (moving) then
      call glutIdleFunc(glutnullfunc)
    endif
  endif
end subroutine visible

program main
use scube_mod
implicit none
interface
  subroutine keyboard(ich, x, y)
  integer, intent(inout):: ich,x,y
  end subroutine keyboard

  subroutine display()
  end subroutine display

  subroutine visible(state)
  integer, intent(inout):: state
  end subroutine visible

  subroutine fog_select(fog)
  integer, intent(inout):: fog
  end subroutine fog_select

  subroutine menu_select(mode)
  integer, intent(inout):: mode
  end subroutine menu_select
end interface

  integer :: width = 350, height = 350
  integer i, win
  character(len=30) name
  integer fog_menu
  real(glfloat) rGL_EXP

  call glutInitWindowSize(width, height)
  call glutInit

  ! choose visual
  if (useRGB) then
    if (useDB) then
      call glutInitDisplayMode(ior(ior(GLUT_DOUBLE,GLUT_RGB),GLUT_DEPTH))
      name = windowNameRGBDB
    else
      call glutInitDisplayMode(ior(ior(GLUT_SINGLE,GLUT_RGB),GLUT_DEPTH))
      name = windowNameRGB
    endif
  else
    if (useDB) then
      call glutInitDisplayMode(ior(ior(GLUT_DOUBLE,GLUT_INDEX),GLUT_DEPTH))
      name = windowNameIndexDB
    else
      call glutInitDisplayMode(ior(ior(GLUT_SINGLE,GLUT_INDEX),GLUT_DEPTH))
      name = windowNameIndex
    endif
  endif

  win = glutCreateWindow(name)

  call buildColormap()

  call glutKeyboardFunc(keyboard)
  call glutDisplayFunc(display)
  call glutVisibilityFunc(visible)

  fog_menu = glutCreateMenu(fog_select)
  call glutAddMenuEntry("Linear fog", GL_LINEAR)
  call glutAddMenuEntry("Exp fog", GL_EXP)
  call glutAddMenuEntry("Exp^2 fog", GL_EXP2)

  i = glutCreateMenu(menu_select)
  call glutAddMenuEntry("Start motion", 1)
  call glutAddMenuEntry("Stop motion", 2)
  call glutAddMenuEntry("Toggle fog", 3)
  call glutAddMenuEntry("Toggle lighting", 4)
  call glutAddSubMenu("Fog type", fog_menu)
  call glutAddMenuEntry("Quit", 5)
  call glutAttachMenu(GLUT_RIGHT_BUTTON)

  ! setup context
  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) then
    call glEnable(GL_LIGHTING)
  endif
  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 glLightfv(GL_LIGHT0, GL_SPOT_DIRECTION, lightDir);
   ! call glLightf(GL_LIGHT0, GL_SPOT_EXPONENT, 80);
   ! call glLightf(GL_LIGHT0, GL_SPOT_CUTOFF, 25);

  call glEnable(GL_NORMALIZE)

  if (useFog) then
    call glEnable(GL_FOG)
  endif
  call glFogfv(GL_FOG_COLOR, fogColor)
  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) then
    call glPolygonStipple(sgiPattern)
  else
    call glPolygonStipple(shadowPattern)
  endif

  call glClearColor(0.0, 0.0, 0.0, 1.0)
  call glClearIndex(0.)
  call glClearDepth(1._gldouble)

  call glutMainLoop()
end program main

quality96%

¤ Dauer der Verarbeitung: 0.12 Sekunden (vorverarbeitet) ¤

Wurzel

Suchen

Beweissystem der NASA

Beweissystem Isabelle

NIST Cobol Testsuite

Cephes Mathematical Library

Wiener Entwicklungsmethode

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.