■

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

MODULE m_callback
USE opengl_gl
USE opengl_glu
USE opengl_glut
IMPLICIT NONE
INTEGER(GLCINT), PARAMETER :: KEY_ESC = 27
INTEGER(GLCINT), PARAMETER :: imageWidth = 64, imageHeight = 64
!
INTEGER(GLint) :: ixBegin = 0, iyBegin = 0
REAL(GLfloat) :: xOrigin = 0.0_GLfloat, yOrigin = 0.0_GLfloat
REAL(GLfloat) :: distance, twist, elevation, azimuth
REAL(GLdouble) :: dnearw = 1.0_gldouble, farw = 20.0_gldouble, fovy = 60.0_gldouble
INTEGER(GLint) :: mbutton
REAL(GLfloat) :: tval = 0.0_GLfloat
INTEGER(GLint) :: texname(1) = 1
INTEGER(GLbyte) :: image(4, imageWidth, imageHeight)
!
CONTAINS
!---------------------------------------------------------
SUBROUTINE makeImage()
IMPLICIT NONE
INTEGER(GLint) :: i, j, icolor
CALL glBindTexture(GL_TEXTURE_2D, texname(1))
DO i = 1, imageHeight
 DO j = 1, imageWidth
  icolor = IOR( IAND(i, Z'8'), IAND(j, Z'8') ) * 255
  image(1, j, i) = INT(icolor, GLbyte)
  image(2, j, i) = INT(icolor, GLbyte)
  image(3, j, i) =   0_GLbyte
  image(4, j, i) = 100_GLbyte
 END DO
END DO
CALL glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT)
CALL glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT)
CALL glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST)
CALL glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST)
CALL glTexImage2D(GL_TEXTURE_2D, 0, 4, imageWidth, imageHeight, 0,      &
                   GL_RGBA, GL_UNSIGNED_BYTE, image(:, 1, 1) ) ! pointer
CALL glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_DECAL)
RETURN
END SUBROUTINE makeImage
!---------------------------------------------------------
SUBROUTINE display()
IMPLICIT NONE
REAL(glfloat) :: diffuse(4)  = (/ 0.0_glfloat, 0.0_glfloat, 1.0_glfloat, 1.0_glfloat /)
REAL(glfloat) :: specular(4) = (/ 1.0_glfloat, 1.0_glfloat, 1.0_glfloat, 1.0_glfloat /)
REAL(glfloat) :: ambient(4)  = (/ 0.1_glfloat, 0.1_glfloat, 0.1_glfloat, 1.0_glfloat /)
CALL glClear( IOR(GL_COLOR_BUFFER_BIT, GL_DEPTH_BUFFER_BIT) )
CALL glPushMatrix()
CALL polarview( )
CALL glEnable( GL_DEPTH_TEST )
!
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 glEnable( GL_LIGHTING )
!
CALL glTranslatef( 0.0_GLfloat, 0.6_GLfloat, 0.0_GLfloat )
CALL glutSolidTeapot(1.0_GLdouble)
CALL glPopMatrix()
!
CALL glDisable( GL_LIGHTING  )
CALL glDIsable( GL_DEPTH_TEST )
CALL glutSwapBuffers() 
RETURN
END SUBROUTINE display
!---------------------------------------------------------
SUBROUTINE SetupTextures()
IMPLICIT NONE
CALL glPixelStorei( GL_UNPACK_ALIGNMENT, 1 )
CALL makeImage()
!CALL glTexGeni( GL_S, GL_TEXTURE_GEN_MODE, GL_OBJECT_LINEAR )
!CALL glTexGeni( GL_T, GL_TEXTURE_GEN_MODE, GL_OBJECT_LINEAR )
!CALL glTexGeni( GL_S, GL_TEXTURE_GEN_MODE, GL_EYE_LINEAR )
!CALL glTexGeni( GL_T, GL_TEXTURE_GEN_MODE, GL_EYE_LINEAR )
CALL glTexGeni( GL_S, GL_TEXTURE_GEN_MODE, GL_SPHERE_MAP )
CALL glTexGeni( GL_T, GL_TEXTURE_GEN_MODE, GL_SPHERE_MAP )
CALL glEnable( GL_TEXTURE_GEN_S )
CALL glEnable( GL_TEXTURE_GEN_T )
CALL glEnable( GL_TEXTURE_2D    )
RETURN
END SUBROUTINE SetupTextures
!---------------------------------------------------------
SUBROUTINE DeleteTextures()
IMPLICIT NONE
CALL glDeleteTextures( 1, texname )
RETURN
END SUBROUTINE DeleteTextures
!---------------------------------------------------------
SUBROUTINE myKbd(key, ix, iy)
IMPLICIT NONE
INTEGER(GLint), INTENT(IN OUT) :: key, ix, iy
SELECT CASE(key)
 CASE (KEY_ESC)
  CALL DeleteTextures() 
  STOP
 CASE DEFAULT
  CONTINUE
END SELECT
RETURN
END SUBROUTINE myKbd
!---------------------------------------------------------
SUBROUTINE myMouse( ibutton, istate, ix, iy )
IMPLICIT NONE
INTEGER(GLcint), INTENT(IN OUT) :: ibutton, istate, ix, iy 
IF (istate == GLUT_DOWN) THEN
 ixBegin = ix
 iyBegin = iy
 mButton = ibutton
END IF
RETURN
END SUBROUTINE myMouse
!---------------------------------------------------------
SUBROUTINE myMotion( ix, iy )
IMPLICIT NONE
INTEGER(GLcint), INTENT(IN OUT) :: ix, iy
INTEGER(GLcint) :: ixDisp, iyDisp
ixDisp = ix - ixBegin
iyDisp = iy - iyBegin
SELECT CASE (mButton)
 CASE (GLUT_LEFT_BUTTON)
  azimuth   = azimuth   + ixDisp / 2.0_GLfloat
  elevation = elevation - iyDisp / 2.0_GLfloat
 CASE (GLUT_MIDDLE_BUTTON)
  twist = AMOD( twist + ixDisp, 360.0_GLfloat )
 CASE (GLUT_RIGHT_BUTTON)
  distance = distance - iyDisp / 40.0_GLfloat
 CASE DEFAULT
  CONTINUE
END SELECT 
ixBegin = ix
iyBegin = iy
CALL glutPostRedisplay()
RETURN
END SUBROUTINE myMotion
!---------------------------------------------------------
SUBROUTINE myInit(progname)
IMPLICIT NONE
CHARACTER(LEN = *), INTENT(IN) :: progname
INTEGER(GLcint) :: iwidth = 400, iheight = 400
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 glutMouseFunc( myMouse )
CALL glutMotionFunc( myMotion )
CALL resetview()
CALL SetupTextures()
CALL glShadeModel( GL_SMOOTH )
CALL glEnable( GL_LIGHT0 )
RETURN
END SUBROUTINE myInit
!---------------------------------------------------------
SUBROUTINE myReshape(iwidth, iheight)
IMPLICIT NONE
INTEGER(glcint), INTENT(IN OUT) :: 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( fovy, aspect, dnearw, farw )
CALL glMatrixMode( GL_MODELVIEW )
RETURN
END SUBROUTINE myReshape
!---------------------------------------------------------
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 = -45.0_glfloat
azimuth   =  30.0_glfloat
RETURN
END SUBROUTINE resetview
!---------------------------------------------------------
SUBROUTINE idle()
IMPLICIT NONE
LOGICAL, SAVE :: tflag = .FALSE.
IF (tflag) THEN 
 tval = tval - 0.05_GLfloat
 IF (tval < 0.0_GLfloat) tflag = .FALSE.
ELSE
 tval = tval + 0.05_GLfloat
 IF (tval < 0.2_GLfloat) tflag = .TRUE.
END IF
CALL glutPostRedisplay()
RETURN
END SUBROUTINE idle
!---------------------------------------------------------
END MODULE m_callback
!=========================================================
PROGRAM GLUT8
USE m_callback
IMPLICIT NONE
CALL glutInit()
CALL myInit( 'GLUT8-3' )
CALL glutReshapeFunc( myReshape )
CALL glutDisplayFunc( display )
CALL glutIdleFunc( idle )
CALL glutMainLoop()
STOP
END PROGRAM GLUT8