■

OpenGLによる3次元CGプログラミング
作者: 林武文, 加藤清敬
出版社/メーカー: コロナ社

MODULE m_callback
USE opengl_gl
USE opengl_glu
USE opengl_glut
IMPLICIT NONE
INTEGER(GLCINT), PARAMETER :: KEY_ESC = 27
REAL(glfloat) :: distance, twist, elevation, azimuth
REAL(glfloat) :: spin = 0.0_glfloat
LOGICAL :: rotateFlag = GL_TRUE
CONTAINS
!---------------------------------------------------------
SUBROUTINE display()
IMPLICIT NONE
REAL(glfloat) :: diffuse(4)  = (/ 1.0_glfloat, 1.0_glfloat, 1.0_glfloat, 1.0_glfloat /)
REAL(glfloat) :: specular(4) = (/ 0.8_glfloat, 0.8_glfloat, 0.8_glfloat, 1.0_glfloat /)
REAL(glfloat) :: ambient(4)  = (/ 0.1_glfloat, 0.1_glfloat, 0.1_glfloat, 1.0_glfloat /)
REAL(glfloat) :: light0(4)   = (/-3.0_glfloat, 0.0_glfloat, 0.0_glfloat, 1.0_glfloat /)
REAL(glfloat) :: light1(4)   = (/ 0.0_glfloat, 1.0_glfloat, 0.0_glfloat, 0.0_glfloat /)
REAL(glfloat) :: blueEmission(4) = (/ 0.3_glfloat, 0.3_glfloat, 1.0_glfloat, 1.0_glfloat /)
CALL glClear( IOR(GL_COLOR_BUFFER_BIT, GL_DEPTH_BUFFER_BIT) )
CALL glEnable( GL_DEPTH_TEST )
CALL glEnable( GL_LIGHTING   )

CALL glPushMatrix()
CALL polarview( )
CALL glLightfv( GL_LIGHT1, GL_POSITION, light1 )
CALL glPushMatrix()

CALL glRotatef( spin, 0.0_glfloat, 1.0_glfloat, 0.0_glfloat )
CALL glLightfv( GL_LIGHT0, GL_POSITION, light0 )
CALL glTranslatef( -3.0_glfloat, 0.0_glfloat, 0.0_glfloat )
CALL glPushAttrib(GL_LIGHTING_BIT)
CALL glMaterialfv( GL_FRONT, GL_EMISSION, blueEMission )
CALL glutSolidCube( 0.1_gldouble )
CALL glPopAttrib()
CALL glPopMatrix()

CALL glMaterialfv( GL_FRONT, GL_DIFFUSE  , diffuse   )
CALL glMaterialfv( GL_FRONT, GL_SPECULAR , specular  )
CALL glMaterialfv( GL_FRONT, GL_AMBIENT  , ambient   )
CALL glMaterialf ( GL_FRONT, GL_SHININESS, 128.0_glfloat )

CALL glRotatef( 90.0_glfloat, 1.0_glfloat, 0.0_glfloat, 0.0_glfloat )
CALL glutSolidSphere( 1.0_gldouble, 100, 100 )
CALL glPopMatrix()

CALL glDisable( GL_LIGHTING   )
CALL glDisable( GL_DEPTH_TEST )
CALL glutSwapBuffers()
RETURN
END SUBROUTINE display
!---------------------------------------------------------
SUBROUTINE idle()
IMPLICIT NONE
IF ( rotateFlag == GL_TRUE ) spin = AMOD( spin + 1.0_glfloat, 360.0_glfloat )
CALL glutPostRedisplay()
RETURN
END SUBROUTINE idle
!---------------------------------------------------------
SUBROUTINE initLighting()
IMPLICIT NONE
REAL(glfloat) :: diffuse(4)    = (/ 0.0_glfloat, 0.0_glfloat, 1.0_glfloat, 1.0_glfloat /)
REAL(glfloat) :: specular(4)   = (/ 0.8_glfloat, 0.8_glfloat, 0.8_glfloat, 1.0_glfloat /)
REAL(glfloat) :: ambient(4)    = (/ 0.2_glfloat, 0.2_glfloat, 0.2_glfloat, 1.0_glfloat /)
REAL(glfloat) :: whiteColor(4) = (/ 0.8_glfloat, 0.8_glfloat, 0.8_glfloat, 1.0_glfloat /)
CALL glLightfv( GL_LIGHT0, GL_DIFFUSE , diffuse  )
CALL glLightfv( GL_LIGHT0, GL_SPECULAR, specular )
CALL glLightfv( GL_LIGHT0, GL_AMBIENT , ambient  )

CALL glLightfv( GL_LIGHT1, GL_DIFFUSE , whiteColor )
CALL glLightfv( GL_LIGHT1, GL_SPECULAR, specular )
CALL glLightfv( GL_LIGHT1, GL_AMBIENT , ambient  )

CALL glEnable ( GL_LIGHT0 )
CALL glEnable ( GL_LIGHT1 )
RETURN
END SUBROUTINE initLighting
!---------------------------------------------------------
SUBROUTINE myKbd(key, ix, iy)
IMPLICIT NONE
INTEGER(GLCINT), INTENT(IN OUT) :: key, ix, iy
SELECT CASE(key)
 CASE (ICHAR('r'))
 rotateFlag = .NOT. rotateFlag
 CASE (KEY_ESC)
 STOP
 CASE DEFAULT
 CONTINUE
END SELECT
RETURN
END SUBROUTINE myKbd
!---------------------------------------------------------
SUBROUTINE polarview()
IMPLICIT NONE
CALL glTranslatef( 0.0_glfloat, 0.0_glfloat, -distance )
CALL glRotatef(-twist    , 0.0_glfloat, 0.0_glfloat, 1.0_glfloat )
CALL glRotatef(-elevation, 1.0_glfloat, 0.0_glfloat, 0.0_glfloat )
CALL glRotatef(-azimuth  , 0.0_glfloat, 1.0_glfloat, 0.0_glfloat )
RETURN
END SUBROUTINE polarview
!---------------------------------------------------------
SUBROUTINE resetview()
IMPLICIT NONE
distance  = 5.0_glfloat
twist     = 0.0_glfloat
elevation = 0.0_glfloat
azimuth   = 0.0_glfloat
RETURN
END SUBROUTINE resetview
!---------------------------------------------------------
END MODULE m_callback
!=========================================================
MODULE m_subs
USE m_callback
IMPLICIT NONE
CONTAINS
!---------------------------------------------------------
SUBROUTINE myInit(progname)
IMPLICIT NONE
CHARACTER(LEN = *), INTENT(IN) :: progname
INTEGER(GLCINT) :: iwidth = 1000, iheight = 600
INTEGER(GLCINT) :: iwin
CALL glutInitWindowPosition( 0_glfloat, 0_glfloat )
CALL glutInitWindowSize( iwidth, iheight )
CALL glutInitDisplayMode( IOR(IOR(GLUT_RGBA, GLUT_DEPTH), GLUT_DOUBLE) )
iwin = glutCreateWindow( progname )
CALL glClearColor( 0.0_glfloat, 0.0_glfloat, 0.0_glfloat, 1.0_glfloat )
CALL glutKeyboardFunc( myKbd )
CALL resetview()
CALL glShadeModel( GL_SMOOTH )
CALL initLighting()
RETURN
END SUBROUTINE myInit
!---------------------------------------------------------
SUBROUTINE myReshape(iwidth, iheight)
IMPLICIT NONE
INTEGER(glcint), INTENT(IN) :: iwidth, iheight
REAL(GLDOUBLE) :: aspect
aspect = REAL(iwidth, glfloat) / REAL(iheight, glfloat)
CALL glViewport( 0, 0, iwidth, iheight )
CALL glMatrixMode( GL_PROJECTION )
CALL glLoadIdentity()
CALL gluPerspective( 40.0_gldouble, aspect, 1.0_gldouble, 10.0_gldouble )
CALL glMatrixMode( GL_MODELVIEW )
RETURN
END SUBROUTINE myReshape
!---------------------------------------------------------
END MODULE m_subs
!=========================================================
PROGRAM GLUT7
USE m_subs
IMPLICIT NONE
CALL glutInit()
CALL myInit( 'GLUT7' )
CALL glutReshapeFunc( myReshape )
CALL glutIdleFunc(idle)
CALL glutDisplayFunc( display )
CALL glutMainLoop()
STOP
END PROGRAM GLUT7