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 = 512, imageHeight = 512 INTEGER(GLbyte) :: image(4, imageWidth, imageHeight) REAL(GLfloat) :: distance, twist, elevation, azimuth REAL(GLdouble) :: dnearw = 1.0_gldouble, farw = 20.0_gldouble, fovy = 60.0_gldouble INTEGER :: mflag = 1 REAL(GLfloat) :: dist = 0.0_GLfloat ! 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 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.0_GLfloat, dist ) CALL glutSolidSphere( 1.0_GLdouble, 60_GLint, 60_GLint ) CALL glPopMatrix ! CALL glDisable( GL_LIGHTING ) CALL glDIsable( GL_DEPTH_TEST ) CALL glutSwapBuffers() RETURN END SUBROUTINE display !--------------------------------------------------------- SUBROUTINE idle() IMPLICIT NONE IF (mflag == 1) THEN IF (dist < - farw) THEN mflag = 0 dist = -farw ELSE dist = dist - 0.2_GLfloat END IF ELSE IF (dist > 0.0_GLfloat) THEN mflag = 1 dist = 0.0_GLfloat ELSE dist = dist + 0.05_GLfloat END IF END IF CALL glutPostRedisplay() RETURN END SUBROUTINE idle !--------------------------------------------------------- SUBROUTINE myKbd(key, ix, iy) IMPLICIT NONE INTEGER(GLint), INTENT(IN OUT) :: key, ix, iy SELECT CASE(key) CASE (KEY_ESC) STOP CASE DEFAULT CONTINUE END SELECT RETURN END SUBROUTINE myKbd !--------------------------------------------------------- SUBROUTINE makeImage() IMPLICIT NONE INTEGER(GLint) :: i, j INTEGER(GLbyte) :: ic, id REAL :: r DO i = 1, imageHeight DO j = 1, imageWidth CALL RANDOM_NUMBER(r) id = INT(150 * r, GLbyte) ic = id + 50 image(1, j, i) = ic image(2, j, i) = 0_GLbyte image(3, j, i) = 0_GLbyte image(4, j, i) = 200 !_GLbyte END DO END DO DO i = 1, imageHeight, 32 DO j = 1, imageWidth image(1, j, i) = 0_GLbyte image(2, j, i) = 255 !_GLbyte image(3, j, i) = 255 !_GLbyte image(4, j, i) = 255 !_GLbyte END DO END DO RETURN END SUBROUTINE makeImage !--------------------------------------------------------- SUBROUTINE initTexture() IMPLICIT NONE CALL makeImage() CALL glPixelStorei( GL_UNPACK_ALIGNMENT, 1 ) 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) ) !! RESHAPE(image, (/4 * imageWidth * imageHeight/)) ) !<--- Stack Overflow CALL glTexEnvi( GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_DECAL ) CALL glEnable( GL_TEXTURE_GEN_S ) CALL glEnable( GL_TEXTURE_GEN_T ) CALL glEnable( GL_TEXTURE_2D ) RETURN END SUBROUTINE initTexture !--------------------------------------------------------- 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 initTexture() 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 = 3.0_glfloat twist = 0.0_glfloat elevation = 0.0_glfloat azimuth = 0.0_glfloat RETURN END SUBROUTINE resetview !--------------------------------------------------------- END MODULE m_callback !========================================================= PROGRAM GLUT8 USE m_callback IMPLICIT NONE CALL glutInit() CALL myInit( 'GLUT8-2' ) CALL glutReshapeFunc( myReshape ) CALL glutDisplayFunc( display ) CALL glutIdleFunc( idle ) CALL glutMainLoop() STOP END PROGRAM GLUT8