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) :: image(4, imageWidth, imageHeight) INTEGER(GLcint) :: ixBegin = 0, iyBegin = 0 INTEGER(GLcint) :: mButton REAL(GLfloat) :: distance, twist, elevation, azimuth REAL(GLdouble) :: znear = 1.0_gldouble, zfar = 80.0_gldouble, fovy = 40.0_gldouble INTEGER(GLcint) :: ibitmapNo = 0 INTEGER(GLcint) :: ifilterNo = 0 INTEGER(GLcint) :: itexmodeNo = 3 ! 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 /) & /) INTEGER(GLbyte) :: bitmap3(imageWidth, imageHeight) = & (/ & (/255, 255, 255, 0, 255, 255, 255, 255 /), & (/255, 255, 255, 0, 255, 255, 255, 255 /), & (/255, 255, 255, 0, 255, 255, 255, 255 /), & (/ 0, 0, 0, 0, 0, 0, 0, 0 /), & (/255, 255, 255, 0, 255, 255, 255, 255 /), & (/255, 255, 255, 0, 255, 255, 255, 255 /), & (/255, 255, 255, 0, 255, 255, 255, 255 /), & (/255, 255, 255, 0, 255, 255, 255, 255 /) & /) 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 /) REAL(glfloat) :: texcolor(4) = (/ 1.0_glfloat, 0.0_glfloat, 0.0_glfloat, 1.0_glfloat /) CALL glClear( IOR(GL_COLOR_BUFFER_BIT, GL_DEPTH_BUFFER_BIT) ) SELECT CASE (itexmodeNo) CASE (1) CALL glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE) CASE (2) CALL glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_DECAL ) CASE (3) CALL glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_BLEND ) CASE (4) CALL glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE ) CASE DEFAULT CONTINUE END SELECT CALL glTexEnvfv( GL_TEXTURE_ENV, GL_TEXTURE_ENV_COLOR, texcolor) CALL glEnable( GL_TEXTURE_2D ) ! CALL glPushMatrix() CALL polarview( ) ! 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 glEnable( GL_DEPTH_TEST ) CALL glNormal3f( 0.0_glfloat, 1.0_glfloat, 0.0_glfloat ) CALL glBegin( GL_QUADS ) CALL glTexCoord2f( 0.0_glfloat, 0.0_glfloat ) CALL glVertex3f( 1.0_glfloat, 0.0_glfloat, 1.0_glfloat ) CALL glTexCoord2f( 0.0_glfloat, 5.0_glfloat ) CALL glVertex3f( 1.0_glfloat, 0.0_glfloat, -1.0_glfloat ) CALL glTexCoord2f( 5.0_glfloat, 5.0_glfloat ) CALL glVertex3f(-1.0_glfloat, 0.0_glfloat, -1.0_glfloat ) CALL glTexCoord2f( 5.0_glfloat, 0.0_glfloat ) CALL glVertex3f(-1.0_glfloat, 0.0_glfloat, 1.0_glfloat ) CALL glEnd() CALL glPopMatrix() ! CALL glDisable( GL_TEXTURE_2D ) 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 (ICHAR('R')) CALL resetview() CASE (ICHAR('s')) CALL glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP) PRINT *, "GL_TEXTURE_WRAP_S ... GL_CLAMP" CASE (ICHAR('S')) CALL glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT) PRINT *, "GL_TEXTURE_WRAP_S ... GL_REPEAT" CASE (ICHAR('t')) CALL glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP) PRINT *, "GL_TEXTURE_WRAP_T ... GL_CLAMP" CASE (ICHAR('T')) CALL glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT) PRINT *, "GL_TEXTURE_WRAP_T ... GL_REPEAT" CASE (ICHAR(' ')) ibitmapNo = ibitmapNo + 1 print *, ibitmapNo IF ( ibitmapNo >= 3 ) ibitmapNo = 0 CALL initTexture() CASE (ICHAR('f')) ifilterNo = ifilterNo + 1 IF ( ifilterNo >= 2 ) THEN ifilterNo = 0; PRINT *, "GL_TEXTURE_FILTER ... GL_NEAREST " ELSE PRINT *, "GL_TEXTURE_FILTER ... GL_LINEAR " END IF CALL initTexture() CASE (ICHAR('h')) CALL printHelp() CASE (ICHAR('1')) itexmodeNo = 1 PRINT *, "TGL_EXTURE_ENV_MODE ... GL_MODULATE" CASE (ICHAR('2')) itexmodeNo = 2 PRINT *, "GL_TEXTURE_ENV_MODE ... GL_DECAL" CASE (ICHAR('3')) itexmodeNo = 3 PRINT *, "GL_TEXTURE_ENV_MODE ... GL_BLEND" CASE (ICHAR('4')) itexmodeNo = 4 PRINT *, "GL_TEXTURE_ENV_MODE ... GL_REPLACE" CASE (KEY_ESC) STOP CASE DEFAULT CONTINUE END SELECT CALL glutPostRedisplay() 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 / 3.0_GLfloat, 360.0_GLfloat ) CASE (GLUT_RIGHT_BUTTON) distance = distance - iyDisp / 60.0_GLfloat CASE DEFAULT CONTINUE END SELECT ixBegin = ix iyBegin = iy CALL glutPostRedisplay() RETURN END SUBROUTINE myMotion !--------------------------------------------------------- SUBROUTINE makeImage() IMPLICIT NONE INTEGER(GLcint) :: i, j SELECT CASE (ibitmapNo) CASE(0) DO i = 1, imageHeight DO j = 1, imageWidth image(1, j, i) = bitmap1(j, i) image(2, j, i) = bitmap1(j, i) image(3, j, i) = bitmap1(j, i) image(4, j, i) = 50_GLbyte END DO END DO CASE(1) DO i = 1, imageHeight DO j = 1, imageWidth image(1, j, i) = bitmap2(j, i) image(2, j, i) = bitmap2(j, i) image(3, j, i) = bitmap2(j, i) image(4, j, i) = 50_GLbyte END DO END DO CASE(2) DO i = 1, imageHeight DO j = 1, imageWidth image(1, j, i) = bitmap3(j, i) image(2, j, i) = bitmap3(j, i) image(3, j, i) = bitmap3(j, i) image(4, j, i) = 50_GLbyte END DO END DO CASE DEFAULT CONTINUE END SELECT RETURN END SUBROUTINE makeImage !--------------------------------------------------------- SUBROUTINE initTexture() IMPLICIT NONE CALL makeImage() CALL glPixelStorei(GL_UNPACK_ALIGNMENT, 1) CALL glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT) CALL glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT) IF (ifilterNo == 0) THEN CALL glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST) CALL glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST) ELSE CALL glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR) CALL glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR) END IF CALL glTexImage2D(GL_TEXTURE_2D, 0, 4, imageWidth, imageHeight, 0, & GL_RGBA, GL_UNSIGNED_BYTE, RESHAPE(image, (/4 * imageWidth * imageHeight/))) RETURN END SUBROUTINE initTexture !--------------------------------------------------------- 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 printHelp() IMPLICIT NONE PRINT * PRINT *, "* t key ... GL_CLAMP t-direction *" PRINT *, "* T key ... GL_REPEAT t-direction *" PRINT *, "* s key ... GL_CLAMP s-direction *" PRINT *, "* S key ... GL_REPEAT s-direction *" PRINT *, "* 1 key ... GL_MODULATE *" PRINT *, "* 2 key ... GL_DECAL *" PRINT *, "* 3 key ... GL_BLEND *" PRINT *, "* 4 key ... GL_REPLACE *" PRINT *, "* SPACE key ... -> bitmap2 -> bitmap3 -> bitmap1 -> *" PRINT *, "* f key ... GL_NEAREST <---> GL_LINEAR *" PRINT *, "* h key ... Print this help message. *" PRINT * RETURN END SUBROUTINE printHelp !--------------------------------------------------------- SUBROUTINE resetview() IMPLICIT NONE distance = 6.0_glfloat twist = 0.0_glfloat elevation = -45.0_glfloat azimuth = 30.0_glfloat RETURN END SUBROUTINE resetview !--------------------------------------------------------- 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, znear, zfar ) CALL glMatrixMode( GL_MODELVIEW ) RETURN END SUBROUTINE myReshape !--------------------------------------------------------- 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 initTexture() CALL resetview() CALL glEnable( GL_LIGHT0 ) RETURN END SUBROUTINE myInit !--------------------------------------------------------- END MODULE m_callback !========================================================= PROGRAM GLUT8 USE m_callback IMPLICIT NONE CALL glutInit() CALL printHelp() CALL myInit( 'GLUT8' ) CALL glutReshapeFunc( myReshape ) CALL glutDisplayFunc( display ) CALL glutMainLoop() STOP END PROGRAM GLUT8
