■

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

MODULE m_callback
USE opengl_gl
USE opengl_glu
USE opengl_glut
IMPLICIT NONE
INTEGER(GLCINT), PARAMETER :: KEY_ESC = 27
LOGICAL :: wireFlag = GL_TRUE, revolveFlag = GL_FALSE
INTEGER(GLCINT) :: ixBegin, iyBegin, mButton
REAL(glfloat) :: distance, twist, elevation, azimuth
REAL(glfloat) :: theta = 15.0_glfloat
REAL(glfloat) :: rColor = 1.0_glfloat, gColor = 1.0_glfloat, bColor = 1.0_glfloat
CONTAINS
!---------------------------
SUBROUTINE display()
IMPLICIT NONE
CALL glClear( GL_COLOR_BUFFER_BIT )
CALL glPushMatrix()
CALL polarview()
CALL glRotatef( theta, 0.0_glfloat, 1.0_glfloat, 0.0_glfloat )
CALL glColor3f( rColor, gColor, bColor )
IF (wireFlag == GL_TRUE) THEN
 CALL glutWireCube( 1.0_gldouble )
ELSE
 CALL glutSolidCube( 1.0_gldouble )
END IF
CALL glPopMatrix()
CALL glutSwapBuffers()
RETURN
END SUBROUTINE display
!---------------------------
SUBROUTINE idle()
IMPLICIT NONE
theta = AMOD(theta + 0.05_glfloat, 360.0_glfloat)
CALL glutPostRedisplay()
RETURN
END SUBROUTINE idle
!---------------------------
SUBROUTINE myKbd(key, ix, iy)
IMPLICIT NONE
INTEGER(GLCINT), INTENT(IN OUT) :: key, ix, iy
SELECT CASE(key)
 CASE (ICHAR('w'))
 wireFlag = .NOT. wireFlag
 CASE (ICHAR('R'))
 CALL resetview()
 CASE (KEY_ESC)
 STOP
 CASE DEFAULT
 CONTINUE
END SELECT
CALL glutPostRedisplay()
RETURN
END SUBROUTINE myKbd
!---------------------------
SUBROUTINE myMouse(ibutton, istate, ix, iy)
IMPLICIT NONE
INTEGER, INTENT(IN OUT) :: ibutton, ix, iy
LOGICAL, INTENT(IN OUT) :: istate
IF (istate == GLUT_DOWN) THEN
 SELECT CASE(ibutton)
 CASE (GLUT_LEFT_BUTTON)
  mButton = ibutton
 CASE (GLUT_MIDDLE_BUTTON)
  revolveFlag = .NOT. revolveFlag
  IF (revolveFlag) THEN
   CALL glutIdleFunc( idle )
  ELSE
   CALL glutIdleFunc( 0 )
  END IF
 CASE (GLUT_RIGHT_BUTTON)

 CASE DEFAULT
  CONTINUE
 END SELECT
 ixBegin = ix
 iyBegin = iy
END IF
RETURN
END SUBROUTINE myMouse
!---------------------------
SUBROUTINE myMotion(ix, iy)
IMPLICIT NONE
INTEGER, INTENT(IN) :: ix, iy
INTEGER :: 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)
 CALL changeColor()
 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 changeColor()
IMPLICIT NONE
CALL RANDOM_NUMBER(rColor)
CALL RANDOM_NUMBER(gColor)
CALL RANDOM_NUMBER(bColor)
RETURN
END SUBROUTINE changeColor
!---------------------------
SUBROUTINE resetview()
IMPLICIT NONE
distance  = 5.0_glfloat
twist     = 0.0_glfloat
elevation = 0.0_glfloat
azimuth   = 0.0_glfloat
RETURN
END SUBROUTINE resetview
!---------------------------
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
!---------------------------
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 = 600, iheight = 600
INTEGER(GLCINT) :: iwin
REAL(GLDOUBLE) :: aspect
aspect = REAL(iwidth, glfloat) / REAL(iheight, glfloat)
CALL glutInitWindowPosition( 0_glfloat, 0_glfloat )
CALL glutInitWindowSize( iwidth, iheight )
CALL glutInitDisplayMode( IOR(GLUT_RGBA, 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 glMatrixMode( GL_PROJECTION )
CALL glLoadIdentity()
CALL gluPerspective( 45.0_gldouble, aspect, 1.0_gldouble, 20.0_gldouble )
CALL glMatrixMode( GL_MODELVIEW )
RETURN
END SUBROUTINE myInit
!---------------------------
END MODULE m_subs
!=========================================================
PROGRAM GLUT5
USE m_subs
IMPLICIT NONE
CALL glutInit()
CALL myInit( 'GLUT5-2' )
CALL glutDisplayFunc( display )
CALL glutMainLoop()
STOP
END PROGRAM GLUT5