OpenGLによる3次元CGプログラミング
作者: 林武文, 加藤清敬
出版社/メーカー: コロナ社
MODULE m_bitmap IMPLICIT NONE INTEGER, PARAMETER :: DWORD = 4, LONG = 4, WORD = 2, kBYTE = 1 TYPE :: T_BITMAPINFOHEADER SEQUENCE integer(DWORD) biSize ! knowns DWORD integer(LONG) biWidth ! knowns LONG integer(LONG) biHeight ! knowns LONG integer(WORD) biPlanes ! knowns WORD integer(WORD) biBitCount ! knowns WORD integer(DWORD) biCompression ! knowns DWORD integer(DWORD) biSizeImage ! knowns DWORD integer(LONG) biXPelsPerMeter ! knowns LONG integer(LONG) biYPelsPerMeter ! knowns LONG integer(DWORD) biClrUsed ! knowns DWORD integer(DWORD) biClrImportant ! knowns DWORD END TYPE ! TYPE :: T_RGBQUAD SEQUENCE integer(kBYTE) rgbBlue ! knowns BYTE integer(kBYTE) rgbGreen ! knowns BYTE integer(kBYTE) rgbRed ! knowns BYTE integer(kBYTE) rgbReserved ! knowns BYTE END TYPE ! TYPE :: T_BITMAPFILEHEADER SEQUENCE CHARACTER(2) :: bfType INTEGER(DWORD) :: bfSize INTEGER(WORD) :: bfReserved1 INTEGER(WORD) :: bfReserved2 INTEGER(DWORD) :: bfOffBits END TYPE CONTAINS !---------------------------------------------------- SUBROUTINE ReadBitmapFile(text, bih, bcolmap, itmp) IMPLICIT NONE CHARACTER(*), INTENT(IN) :: text TYPE (T_BITMAPINFOHEADER) , INTENT(OUT) :: bih TYPE (T_RGBQUAD), ALLOCATABLE, INTENT(OUT) :: bcolmap(:) INTEGER(1) , ALLOCATABLE, INTENT(OUT) :: itmp(:) TYPE (T_BITMAPFILEHEADER) :: bfh INTEGER :: i, len INTEGER :: ir = 10 OPEN(ir, file = text, FORM = 'BINARY') READ(ir) bfh READ(ir) bih len = bih%biWidth * bih%biHeight IF (bih%biBitCount == 8) THEN ALLOCATE(bcolmap(256)) READ(ir) bcolmap ALLOCATE( itmp(len) ) READ(ir) itmp ELSE IF (bih%biBitCount == 4) THEN ALLOCATE(bcolmap(16)) READ(ir) bcolmap ALLOCATE( itmp(len) ) itmp = 0 READ(ir) itmp DO i = 1, len, 2 itmp( (i + 1) / 2) = itmp(i + 1) * 16 + itmp(i) END DO END IF CLOSE(ir) RETURN END SUBROUTINE ReadBitmapFile !---------------------------------------------------- SUBROUTINE ReadBitMapData(text, iwidth, iheight, ipixel) IMPLICIT NONE CHARACTER(*), INTENT(IN) :: text INTEGER, INTENT(OUT) :: iwidth, iheight INTEGER(1), ALLOCATABLE, INTENT(OUT) :: ipixel(:) TYPE (T_BITMAPINFOHEADER) :: bih INTEGER :: istatus, isel INTEGER :: i, j, k, m INTEGER :: icounter, icolor TYPE (T_RGBQUAD), ALLOCATABLE :: bcolmap(:) INTEGER(1) , ALLOCATABLE :: idata(:) ! CALL ReadBitmapFile('tmp.bmp', bih, bcolmap, idata) iwidth = bih%biWidth iheight = bih%biHeight ALLOCATE( ipixel( 4 * iwidth * iheight ) ) IF (bih%biBitCount == 8) THEN DO j = 0, iheight - 1 DO i = 0, iwidth - 1 k = 4 * (j * iwidth + i) + 1 m = idata(j * iwidth + i + 1) IF (m < 0) m = 256 + m m = m + 1 ipixel(k ) = bcolmap(m)%rgbRed ipixel(k + 1) = bcolmap(m)%rgbGreen ipixel(k + 2) = bcolmap(m)%rgbBlue ipixel(k + 3) = 255 END DO END DO ELSE IF (bih%biBitCount == 4) THEN icounter = 0 DO j = 0, iheight - 1 DO i = 0, iwidth - 1 icounter = icounter + 1 icolor = idata(icounter) ! IF (icolor < 0) icolor = icolor + 256 ! ipixel(k ) = bcolmap(icolor)%rgbRed ipixel(k + 1) = bcolmap(icolor)%rgbGreen ipixel(k + 2) = bcolmap(icolor)%rgbBlue ipixel(k + 3) = 255 END DO END DO END IF DEALLOCATE(bcolmap, idata) RETURN END SUBROUTINE ReadBitMapData !---------------------------------------------------- END MODULE m_bitmap !==================================================== MODULE m_callback USE opengl_gl USE opengl_glu USE opengl_glut USE :: m_bitmap IMPLICIT NONE INTEGER(GLCINT), PARAMETER :: KEY_ESC = 27 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 CONTAINS !--------------------------------------------------------- SUBROUTINE display() IMPLICIT NONE REAL(glfloat) :: diffuse(4) = (/ 0.0_glfloat, 0.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, 1.0_glfloat ) CALL glVertex3f (-0.5_glfloat, 0.5_glfloat, 0.5_glfloat ) CALL glTexCoord2f( 1.0_glfloat, 1.0_glfloat ) CALL glVertex3f ( 0.5_glfloat, 0.5_glfloat, 0.5_glfloat ) CALL glTexCoord2f( 1.0_glfloat, 0.0_glfloat ) CALL glVertex3f ( 0.5_glfloat,-0.5_glfloat, 0.5_glfloat ) CALL glEnd() 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, 1.0_glfloat ) CALL glVertex3f (-0.5_glfloat, 0.5_glfloat,-0.5_glfloat ) CALL glTexCoord2f( 1.0_glfloat, 1.0_glfloat ) CALL glVertex3f ( 0.5_glfloat, 0.5_glfloat,-0.5_glfloat ) CALL glTexCoord2f( 1.0_glfloat, 0.0_glfloat ) CALL glVertex3f ( 0.5_glfloat,-0.5_glfloat,-0.5_glfloat ) CALL glEnd() 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, 1.0_glfloat ) CALL glVertex3f ( 0.5_glfloat,-0.5_glfloat,-0.5_glfloat ) CALL glTexCoord2f( 1.0_glfloat, 1.0_glfloat ) CALL glVertex3f ( 0.5_glfloat, 0.5_glfloat,-0.5_glfloat ) CALL glTexCoord2f( 1.0_glfloat, 0.0_glfloat ) CALL glVertex3f ( 0.5_glfloat, 0.5_glfloat, 0.5_glfloat ) CALL glEnd() 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, 1.0_glfloat ) CALL glVertex3f (-0.5_glfloat,-0.5_glfloat,-0.5_glfloat ) CALL glTexCoord2f( 1.0_glfloat, 1.0_glfloat ) CALL glVertex3f (-0.5_glfloat, 0.5_glfloat,-0.5_glfloat ) CALL glTexCoord2f( 1.0_glfloat, 0.0_glfloat ) CALL glVertex3f (-0.5_glfloat, 0.5_glfloat, 0.5_glfloat ) CALL glEnd() 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, 1.0_glfloat ) CALL glVertex3f (-0.5_glfloat, 0.5_glfloat, 0.5_glfloat ) CALL glTexCoord2f( 1.0_glfloat, 1.0_glfloat ) CALL glVertex3f ( 0.5_glfloat, 0.5_glfloat, 0.5_glfloat ) CALL glTexCoord2f( 1.0_glfloat, 0.0_glfloat ) CALL glVertex3f ( 0.5_glfloat, 0.5_glfloat,-0.5_glfloat ) CALL glEnd() 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, 1.0_glfloat ) CALL glVertex3f (-0.5_glfloat,-0.5_glfloat, 0.5_glfloat ) CALL glTexCoord2f( 1.0_glfloat, 1.0_glfloat ) CALL glVertex3f ( 0.5_glfloat,-0.5_glfloat, 0.5_glfloat ) CALL glTexCoord2f( 1.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 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 makeImage() IMPLICIT NONE INTEGER :: iheight, iwidth INTEGER(1), ALLOCATABLE :: image(:) INTEGER :: iret CALL ReadBitMapData("tmp.bmp", iwidth, iheight, image) 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, iwidth, iheight,0, & GL_RGBA, GL_UNSIGNED_BYTE, image ) CALL glTexEnvi( GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_DECAL ) CALL glEnable ( GL_TEXTURE_2D ) RETURN END SUBROUTINE makeImage !--------------------------------------------------------- SUBROUTINE myInit(progname) IMPLICIT NONE CHARACTER(LEN = *), INTENT(IN) :: progname INTEGER(GLcint) :: iwidth = 700, iheight = 700 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 makeImage() 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-5' ) CALL glutReshapeFunc( myReshape ) CALL glutDisplayFunc( display ) CALL glutMouseFunc ( myMouse ) CALL glutMotionFunc ( myMotion ) CALL glutMainLoop() STOP END PROGRAM GLUT8
