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 = 8, imageHeight = 8 INTEGER(GLbyte) :: image1(4, imageWidth, imageHeight) INTEGER(GLbyte) :: image2(4, imageWidth, imageHeight) INTEGER(GLcint) :: ixBegin = 0, iyBegin = 0 INTEGER(GLcint) :: mButton REAL(GLfloat) :: distance, twist, elevation, azimuth REAL(GLdouble) :: dnear = 1.0_gldouble, far = 30.0_gldouble, fovy = 60.0_gldouble ! INTEGER(GLbyte) :: bitmap1(imageWidth, imageHeight) = & (/ & (/255, 255, 255, 255, 0, 0, 0, 0 /), & (/255, 255, 255, 255, 0, 0, 0, 0 /), & (/255, 255, 255, 255, 0, 0, 0, 0 /), & (/255, 255, 255, 255, 0, 0, 0, 0 /), & (/ 0, 0, 0, 0, 255, 255, 255, 255 /), & (/ 0, 0, 0, 0, 255, 255, 255, 255 /), & (/ 0, 0, 0, 0, 255, 255, 255, 255 /), & (/ 0, 0, 0, 0, 255, 255, 255, 255 /) & /) INTEGER(GLbyte) :: bitmap2(imageWidth, imageHeight) = & (/ & (/ 0, 0, 0, 255, 255, 0, 0, 0 /), & (/ 0, 0, 255, 255, 255, 255, 0, 0 /), & (/ 0, 255, 255, 255, 255, 255, 255, 0 /), & (/255, 255, 255, 255, 255, 255, 255, 255 /), & (/255, 255, 255, 255, 255, 255, 255, 255 /), & (/ 0, 255, 255, 255, 255, 255, 255, 0 /), & (/ 0, 0, 255, 255, 255, 255, 0, 0 /), & (/ 0, 0, 0, 255, 255, 0, 0, 0 /) & /) 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) = (/ 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 glEnable( GL_TEXTURE_2D ) ! 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 glBindTexture( GL_TEXTURE_2D, 1 ) CALL glBegin( GL_QUADS ) CALL glTexCoord2f( 0.0_glfloat, 0.0_glfloat ) CALL glVertex3f (-0.5_glfloat,-0.5_glfloat, 0.5_glfloat ) CALL glTexCoord2f( 0.0_glfloat, 5.0_glfloat ) CALL glVertex3f (-0.5_glfloat, 0.5_glfloat, 0.5_glfloat ) CALL glTexCoord2f( 5.0_glfloat, 5.0_glfloat ) CALL glVertex3f ( 0.5_glfloat, 0.5_glfloat, 0.5_glfloat ) CALL glTexCoord2f( 5.0_glfloat, 0.0_glfloat ) CALL glVertex3f ( 0.5_glfloat,-0.5_glfloat, 0.5_glfloat ) CALL glEnd() ! CALL glBindTexture( GL_TEXTURE_2D, 2 ) CALL glBegin( GL_QUADS ) CALL glTexCoord2f( 0.0_glfloat, 0.0_glfloat ) CALL glVertex3f ( 0.5_glfloat,-0.5_glfloat, 0.5_glfloat ) CALL glTexCoord2f( 0.0_glfloat, 5.0_glfloat ) CALL glVertex3f ( 0.5_glfloat,-0.5_glfloat,-0.5_glfloat ) CALL glTexCoord2f( 5.0_glfloat, 5.0_glfloat ) CALL glVertex3f ( 0.5_glfloat, 0.5_glfloat,-0.5_glfloat ) CALL glTexCoord2f( 5.0_glfloat, 0.0_glfloat ) CALL glVertex3f ( 0.5_glfloat, 0.5_glfloat, 0.5_glfloat ) CALL glEnd() ! CALL glDisable( GL_TEXTURE_2D ) CALL glPopMatrix() CALL glDisable( GL_LIGHTING ) CALL glDIsable( GL_DEPTH_TEST ) CALL glutSwapBuffers() RETURN END SUBROUTINE display !--------------------------------------------------------- SUBROUTINE makeImage1() IMPLICIT NONE INTEGER(GLcint) :: i, j DO i = 1, imageHeight DO j = 1, imageWidth image1(1, j, i) = bitmap1(j, i) image1(2, j, i) = bitmap1(j, i) image1(3, j, i) = bitmap1(j, i) image1(4, j, i) = 128 !_GLbyte END DO END DO RETURN END SUBROUTINE makeImage1 !--------------------------------------------------------- SUBROUTINE makeImage2() IMPLICIT NONE INTEGER(GLcint) :: i, j DO i = 1, imageHeight DO j = 1, imageWidth image2(1, j, i) = bitmap2(j, i) image2(2, j, i) = 0 image2(3, j, i) = 0 image2(4, j, i) = 128 !_GLbyte END DO END DO RETURN END SUBROUTINE makeImage2 !--------------------------------------------------------- SUBROUTINE initTexture1() IMPLICIT NONE CALL makeImage1() CALL glPixelStorei( GL_UNPACK_ALIGNMENT, 1 ) CALL glBindTexture( GL_TEXTURE_2D, 1 ) 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, image1(:, 1, 1)) ! GL_RGBA, GL_UNSIGNED_BYTE, RESHAPE(image, (/4 * imageWidth * imageHeight/))) CALL glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_DECAL) RETURN END SUBROUTINE initTexture1 !--------------------------------------------------------- SUBROUTINE initTexture2() IMPLICIT NONE CALL makeImage2() CALL glPixelStorei( GL_UNPACK_ALIGNMENT, 1 ) CALL glBindTexture( GL_TEXTURE_2D, 2 ) 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, image2(:, 1, 1)) ! GL_RGBA, GL_UNSIGNED_BYTE, RESHAPE(image, (/4 * imageWidth * imageHeight/))) CALL glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_DECAL) RETURN END SUBROUTINE initTexture2 !--------------------------------------------------------- SUBROUTINE myKbd(key, ix, iy) IMPLICIT NONE INTEGER(GLcint), INTENT(IN OUT) :: key, ix, iy SELECT CASE(key) CASE (KEY_ESC) STOP CASE DEFAULT CONTINUE END SELECT CALL glutPostRedisplay() RETURN END SUBROUTINE myKbd !--------------------------------------------------------- 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 resetview() CALL initTexture1() CALL initTexture2() 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, dnear, far ) 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 = -30.0_glfloat azimuth = 30.0_glfloat RETURN END SUBROUTINE resetview !--------------------------------------------------------- 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 !--------------------------------------------------------- END MODULE m_callback !========================================================= PROGRAM GLUT8 USE m_callback IMPLICIT NONE CALL glutInit() CALL myInit( 'GLUT8-4' ) CALL glutReshapeFunc( myReshape ) CALL glutDisplayFunc( display ) CALL glutMouseFunc ( myMouse ) CALL glutMotionFunc ( myMotion ) CALL glutMainLoop() STOP END PROGRAM GLUT8
