Fortranへの移植。
MODULE m_callback USE opengl_gl USE opengl_glu USE opengl_glut IMPLICIT NONE REAL(GLdouble), PARAMETER :: pi = 3.141592653589793238_GLdouble REAL(GLdouble), PARAMETER :: G = 9.80665_GLdouble REAL(GLdouble), PARAMETER :: TICK = 1.0e-3_GLdouble ! INTEGER(GLint), PARAMETER :: KEY_ESC = 27 REAL(GLfloat) :: xOrigin = 0.0_GLfloat, yOrigin = 0.0_GLfloat INTEGER(GLint) :: ixStart = 0, iyStart = 0 INTEGER(GLint) :: mButton REAL(GLfloat) :: distance, twist, elevation, azimuth REAL(GLdouble) :: xnear = 1.0_gldouble, farw = 30.0_gldouble, fovy = 60.0_gldouble REAL(glfloat) :: greenDiffuse(4) = (/ 0.0_glfloat, 1.0_glfloat, 0.5_glfloat, 1.0_glfloat /) REAL(glfloat) :: whiteSpecular(4) = (/ 1.0_glfloat, 1.0_glfloat, 1.0_glfloat, 1.0_glfloat /) REAL(glfloat) :: whiteAmbient(4) = (/ 0.1_glfloat, 0.1_glfloat, 0.1_glfloat, 1.0_glfloat /) ! TYPE :: t_pendulum REAL(GLdouble) :: m_x, m_y, m_z REAL(GLdouble) :: m_dia REAL(GLdouble) :: m_length REAL(GLdouble) :: m_mass REAL(GLdouble) :: m_th REAL(GLdouble) :: m_dth END TYPE TYPE (t_pendulum) :: pdlm0, pdlm1, pdlm2, pdlm3, pdlm4 ! CONTAINS !--------------------------------------------------------- SUBROUTINE createPendulum( x, y, z, dia, dlength, dmass, p ) IMPLICIT NONE REAL(GLdouble), INTENT(IN) :: x, y, z, dia, dlength, dmass TYPE (t_pendulum), INTENT(OUT) :: p p = t_pendulum(x, y, z, dia, dlength, dmass, & 60.0_GLdouble / 180.0_GLdouble * pi, 0.0_GLdouble ) RETURN END SUBROUTINE createPendulum !--------------------------------------------------------- SUBROUTINE stepPendulum( p ) IMPLICIT NONE TYPE (t_pendulum), INTENT(IN OUT) :: p REAL(GLdouble) :: theta, omega theta = p%m_th omega = p%m_dth p%m_th = p%m_th + omega * TICK p%m_dth = p%m_dth + TICK * (-G / p%m_length) * SIN(theta) RETURN END SUBROUTINE stepPendulum !--------------------------------------------------------- SUBROUTINE drawPendulum( p ) IMPLICIT NONE TYPE (t_pendulum), INTENT(IN) :: p CALL glPushMatrix() CALL glDisable( GL_LIGHTING ) CALL glColor3f( 1.0_glfloat, 0.0_glfloat, 0.0_glfloat ) CALL glBegin( GL_LINES ) CALL glVertex3d( p%m_x, p%m_y, p%m_z ) CALL glVertex3d( p%m_x + p%m_length * SIN(p%m_th), & p%m_y - p%m_length * COS(p%m_th), p%m_z ) CALL glEnd() CALL glEnable( GL_LIGHTING ) CALL glTranslated( p%m_x, p%m_y, p%m_z ) CALL glutSolidCube( 0.02_gldouble ) CALL glRotated( p%m_th * 180.0_gldouble / pi, 0.0_gldouble, 0.0_gldouble, 1.0_gldouble ) CALL glTranslated( 0.0_gldouble, - p%m_length, 0.0_gldouble ) CALL glutSolidSphere( p%m_dia, 10, 10 ) CALL glPopMatrix() RETURN END SUBROUTINE drawPendulum !--------------------------------------------------------- SUBROUTINE createWorld() IMPLICIT NONE CALL createPendulum( 0.0_gldouble, 1.0_gldouble, 0.0_gldouble, 0.10_gldouble, & 2.0_gldouble, 0.1_gldouble, pdlm0 ) CALL createPendulum( 0.0_gldouble, 1.0_gldouble, 0.2_gldouble, 0.10_gldouble, & 1.0_gldouble, 0.1_gldouble, pdlm1 ) CALL createPendulum( 0.0_gldouble, 1.0_gldouble, 0.4_gldouble, 0.05_gldouble, & 1.0_gldouble, 0.1_gldouble, pdlm2 ) CALL createPendulum( 0.0_gldouble, 1.0_gldouble, 0.6_gldouble, 0.05_gldouble, & 0.4_gldouble, 0.1_gldouble, pdlm3 ) CALL createPendulum( 0.0_gldouble, 1.0_gldouble, 0.8_gldouble, 0.05_gldouble, & 0.2_gldouble, 0.1_gldouble, pdlm4 ) RETURN END SUBROUTINE createWorld !--------------------------------------------------------- SUBROUTINE drawWorld() IMPLICIT NONE INTEGER :: i REAL(glfloat) :: x, y, z DO i = 1, 30 CALL stepPendulum( pdlm0 ) CALL stepPendulum( pdlm1 ) CALL stepPendulum( pdlm2 ) CALL stepPendulum( pdlm3 ) CALL stepPendulum( pdlm4 ) END DO CALL drawPendulum( pdlm0 ) CALL drawPendulum( pdlm1 ) CALL drawPendulum( pdlm2 ) CALL drawPendulum( pdlm3 ) CALL drawPendulum( pdlm4 ) RETURN END SUBROUTINE drawWorld !--------------------------------------------------------- SUBROUTINE display() IMPLICIT NONE CALL glClear( IOR(GL_COLOR_BUFFER_BIT, GL_DEPTH_BUFFER_BIT) ) CALL glPushMatrix() CALL polarview( ) CALL glEnable( GL_DEPTH_TEST ) CALL glEnable( GL_LIGHTING ) ! CALL glMaterialfv( GL_FRONT_AND_BACK, GL_DIFFUSE , greenDiffuse ) CALL glMaterialfv( GL_FRONT_AND_BACK, GL_SPECULAR, whiteSpecular ) CALL glMaterialfv( GL_FRONT_AND_BACK, GL_AMBIENT , whiteAmbient ) CALL glMaterialf ( GL_FRONT_AND_BACK, GL_SHININESS, 128.0_glfloat ) ! CALL glEnable( GL_NORMALIZE ) CALL glEnable( GL_AUTO_NORMAL ) ! CALl drawWorld() ! CALL glPopMatrix() CALL glDisable( GL_LIGHTING ) CALL glDisable( GL_DEPTH_TEST ) CALL glutSwapBuffers() RETURN END SUBROUTINE display !--------------------------------------------------------- SUBROUTINE myKbd(key, ix, iy) IMPLICIT NONE INTEGER(GLcint), INTENT(IN OUT) :: key, ix, iy SELECT CASE(key) CASE (KEY_ESC) STOP CASE DEFAULT 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 ixStart = ix iyStart = iy mButton = ibutton END IF RETURN END SUBROUTINE myMouse !--------------------------------------------------------- SUBROUTINE myMotion( ix, iy ) IMPLICIT NONE INTEGER(GLcint), INTENT(IN OUT) :: ix, iy INTEGER(GLcint) :: ixOffset, iyOffset ixOffset = ix - ixStart iyOffset = iy - iyStart SELECT CASE (mButton) CASE (GLUT_LEFT_BUTTON) azimuth = azimuth + ixOffset / 2.0_GLfloat ! elevation = elevation - iyOffset / 2.0_GLfloat CASE (GLUT_MIDDLE_BUTTON) twist = AMOD( twist + ixOffset, 360.0_GLfloat ) CASE (GLUT_RIGHT_BUTTON) distance = distance - iyOffset / 40.0_GLfloat CASE DEFAULT END SELECT ixStart = ix iyStart = 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 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, xnear, 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 = 3.0_glfloat twist = 0.0_glfloat elevation = -45.0_glfloat azimuth = 30.0_glfloat RETURN END SUBROUTINE resetview !--------------------------------------------------------- RECURSIVE SUBROUTINE timer( ivalue ) IMPLICIT NONE INTEGER(GLint), INTENT(IN) :: ivalue IF (ivalue == 1) THEN CALL glutTimerFunc( 30, timer, 1 ) CALL glutPostRedisplay() END IF RETURN END SUBROUTINE timer !--------------------------------------------------------- END MODULE m_callback !========================================================= PROGRAM GLUT10 USE m_callback IMPLICIT NONE CALL glutInit() CALL myInit( 'GLUT10-2ex' ) CALL createWorld() CALL glutReshapeFunc( myReshape ) CALL glutDisplayFunc( display ) CALL glutTimerFunc( 30, timer, 1 ) CALL glutMainLoop() STOP END PROGRAM GLUT10
