MODULE m_bitmap
IMPLICIT NONE
INTEGER, PARAMETER :: DWORD = 4, LONG = 4, WORD = 2, kBYTE = 1
TYPE :: T_BITMAPINFOHEADER
SEQUENCE
integer(DWORD) biSize
integer(LONG) biWidth
integer(LONG) biHeight
integer(WORD) biPlanes
integer(WORD) biBitCount
integer(DWORD) biCompression
integer(DWORD) biSizeImage
integer(LONG) biXPelsPerMeter
integer(LONG) biYPelsPerMeter
integer(DWORD) biClrUsed
integer(DWORD) biClrImportant
END TYPE
TYPE :: T_RGBQUAD
SEQUENCE
integer(kBYTE) rgbBlue
integer(kBYTE) rgbGreen
integer(kBYTE) rgbRed
integer(kBYTE) rgbReserved
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(text, 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)
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_interface
USE, INTRINSIC :: ISO_C_BINDING
USE opengl_gl
USE opengl_glu
USE opengl_glut
IMPLICIT NONE
TYPE, BIND(C) :: t_ARParam
INTEGER(C_INT) :: ixsize, iysize
REAL(C_DOUBLE) :: dmat(4, 3)
REAL(C_DOUBLE) :: dist_factor(4)
END TYPE
TYPE, BIND(C) :: t_ARMarkerInfo
INTEGER(C_INT) :: iarea
INTEGER(C_INT) :: id
INTEGER(C_INT) :: dir
REAL(C_DOUBLE) :: cf
REAL(C_DOUBLE) :: pos(2)
REAL(C_DOUBLE) :: dline(3, 4)
REAL(C_DOUBLE) :: vertex(2, 4)
END TYPE
INTEGER(C_INT) :: ithresh = 100
INTEGER(C_INT) :: icount = 0
INTEGER(C_INT) :: ipatt_id
REAL(C_DOUBLE) :: patt_width = 80.0_c_double
REAL(C_DOUBLE) :: patt_center(2) = (/0.0_c_double, 0.0_c_double/)
REAL(C_DOUBLE) :: patt_trans(3, 4)
INTEGER(C_INT) :: ixsize, iysize
TYPE(t_ARParam) :: cparam
INTERFACE
SUBROUTINE arVideoCapStop() BIND(C, NAME = 'arVideoCapStop')
END SUBROUTINE arVideoCapStop
SUBROUTINE arVideoClose() BIND(C, NAME = 'arVideoClose')
END SUBROUTINE arVideoClose
SUBROUTINE argCleanup() BIND(C, NAME = 'argCleanup')
END SUBROUTINE argCleanup
INTEGER(C_INT) FUNCTION arVideoGetImage() BIND(C, NAME = 'arVideoGetImage')
USE, INTRINSIC :: ISO_C_BINDING
END
SUBROUTINE arUtilSleep(i) BIND(C, NAME = 'arUtilSleep')
USE, INTRINSIC :: ISO_C_BINDING
INTEGER(C_INT), VALUE :: i
END
SUBROUTINE arUtilTimerReset() BIND(C, NAME = 'arUtilTimerReset')
USE, INTRINSIC :: ISO_C_BINDING
END
SUBROUTINE argDrawMode2D() BIND(C, NAME = 'argDrawMode2D')
END
SUBROUTINE argDispImage( iptr, i, j ) BIND(C, NAME = 'argDispImage')
USE, INTRINSIC :: ISO_C_BINDING
INTEGER(C_INTPTR_T), VALUE :: iptr
INTEGER, VALUE :: i, j
END
INTEGER(C_INT) FUNCTION arDetectMarker( iptr, i, mark, k ) BIND(C, NAME = 'arDetectMarker')
USE, INTRINSIC :: ISO_C_BINDING
import
INTEGER(C_INTPTR_T), VALUE :: iptr
INTEGER(C_INT) , VALUE :: i
TYPE(t_ARMarkerInfo), POINTER :: mark(:)
INTEGER(C_INT) :: k
END
SUBROUTINE arVideoCapNext() BIND(C, NAME = 'arVideoCapNext')
END
SUBROUTINE argSwapBuffers() BIND(C, NAME = 'argSwapBuffers')
END
SUBROUTINE arGetTransMat(ptr, d1, d, d2) BIND(C, NAME = 'arGetTransMat')
USE, INTRINSIC :: ISO_C_BINDING
TYPE(C_PTR), VALUE :: ptr
REAL(C_DOUBLE), VALUE :: d
REAL(C_DOUBLE):: d1(2), d2(3, 4)
END
SUBROUTINE argDrawMode3D() BIND(C, NAME = 'argDrawMode3D')
END SUBROUTINE argDrawMode3D
SUBROUTINE argDraw3dCamera(ix, iy) BIND(C, NAME = 'argDraw3dCamera')
USE, INTRINSIC :: ISO_C_BINDING
INTEGER(C_INT), VALUE :: ix, iy
END
SUBROUTINE argConvGlpara(x, y) BIND(C, NAME = 'argConvGlpara')
USE, INTRINSIC :: ISO_C_BINDING
REAL(C_DOUBLE) :: x(4, 3), y(4, 4)
END
SUBROUTINE arVideoCapStart() BIND(C, NAME = 'arVideoCapStart')
END
SUBROUTINE argMainLoop( i, j, k ) BIND(C, NAME = 'argMainLoop')
USE, INTRINSIC :: ISO_C_BINDING
INTEGER, VALUE :: i
TYPE(C_FUNPTR), VALUE :: j, k
END
INTEGER(4) FUNCTION arVideoOpen(text) BIND(C, NAME = 'arVideoOpen')
USE, INTRINSIC :: ISO_C_BINDING
CHARACTER(c_char) :: text(*)
END
INTEGER(C_INT) FUNCTION arVideoInqSize(ix, iy) BIND(C, NAME = 'arVideoInqSize')
USE, INTRINSIC :: ISO_C_BINDING
INTEGER(C_INT) :: ix, iy
END
INTEGER(C_INT) FUNCTION arParamLoad(text, i, xparam) BIND(C, NAME = 'arParamLoad')
USE, INTRINSIC :: ISO_C_BINDING
import :: t_ARParam
CHARACTER(c_char) :: text(*)
TYPE(t_ARParam) :: xparam
INTEGER(C_INT), VALUE :: i
END
SUBROUTINE arParamChangeSize(xparam, i, j, yparam) BIND(C, NAME = 'arParamChangeSize')
USE, INTRINSIC :: ISO_C_BINDING
import :: t_ARParam
TYPE(t_ARParam) :: xparam, yparam
INTEGER(C_INT), VALUE :: i, j
END
SUBROUTINE arInitCparam(xparam) BIND(C, NAME = 'arInitCparam' )
import :: t_ARParam
TYPE(t_ARParam) :: xparam
END
SUBROUTINE arParamDisp(xparam) BIND(C, NAME = 'arParamDisp')
import :: t_ARParam
TYPE(t_ARParam) :: xparam
END
INTEGER(4) FUNCTION arLoadPatt(text) BIND(C, NAME = 'arLoadPatt')
USE, INTRINSIC :: ISO_C_BINDING
CHARACTER(c_char) :: text(*)
END
SUBROUTINE argInit(iptr, d, i1, i2, i3, i4) BIND(C, NAME = 'argInit')
USE, INTRINSIC :: ISO_C_BINDING
INTEGER(C_INTPTR_T), VALUE :: iptr
REAL(C_DOUBLE) , VALUE :: d
INTEGER(C_INT) , VALUE :: i1, i2, i3, i4
END
REAL(8) FUNCTION arUtilTimer() BIND(C, NAME = 'arUtilTimer')
END FUNCTION arUtilTimer
END INTERFACE
END MODULE m_interface
MODULE m_ART
USE :: m_interface
LOGICAL :: qaniki = .FALSE.
CONTAINS
SUBROUTINE init() BIND(C)
USE, INTRINSIC :: ISO_C_BINDING
IMPLICIT NONE
TYPE(t_ARParam) :: wparam
CHARACTER (LEN = 35) :: vconf = "Data\\WDM_camera_flipV.xml" // c_null_char
CHARACTER (LEN = 35) :: cparam_name = "Data/camera_para.dat" // c_null_char
CHARACTER (LEN = 35) :: patt_name = "Data/patt.hiro" // c_null_char
IF( arVideoOpen( vconf ) < 0 ) STOP
IF( arVideoInqSize( ixsize, iysize ) < 0 ) STOP
PRINT *, "Image size (x,y) = ", ixsize, iysize
IF ( arParamLoad( cparam_name, 1, wparam ) < 0 ) THEN
PRINT *, "Camera parameter load error !!"
STOP
END IF
CALL arParamChangeSize( wparam, ixsize, iysize, cparam )
CALL arInitCparam( cparam )
PRINT *, "*** Camera Parameter ***"
CALL arParamDisp( cparam )
ipatt_id = arLoadPatt( patt_name )
IF ( ipatt_id < 0 ) THEN
PRINT *, "pattern load error !!"
STOP
END IF
CALL argInit( LOC(cparam), 1.0_c_double, 0, 0, 0, 0 )
RETURN
END SUBROUTINE init
SUBROUTINE mainLoop() BIND(C, NAME = 'mainLoop')
IMPLICIT NONE
INTEGER(C_INTPTR_T) :: dataPtr
TYPE(t_ARMarkerInfo), POINTER:: marker_info(:)
INTEGER(C_INT) :: marker_num
INTEGER(C_INT) :: j, k
LOGICAL, SAVE :: qfirst = .TRUE.
IF (qfirst) THEN
ALLOCATE(marker_info(50))
qfirst = .FALSE.
END IF
dataPtr = arVideoGetImage()
IF (dataPtr == 0) THEN
CALL arUtilSleep(2)
RETURN
END IF
IF (icount == 0) CALL arUtilTimerReset()
icount = icount + 1
CALL argDrawMode2D()
CALL argDispImage( dataPtr, 0, 0 )
IF ( arDetectMarker( dataPtr, ithresh, marker_info, marker_num ) < 0 ) THEN
CALL cleanup()
RETURN
END IF
CALL arVideoCapNext()
k = -1
DO j = 1, marker_num
IF (ipatt_id == marker_info(j)%id) THEN
IF (k == -1) THEN
k = j
ELSE
IF (marker_info(k)%cf < marker_info(j)%cf ) k = j
END IF
END IF
END DO
IF ( k == -1 ) THEN
CALL argSwapBuffers()
RETURN
END IF
CALL arGetTransMat( C_LOC(marker_info(k)), patt_center, patt_width, patt_trans )
CALL draw()
CALL argSwapBuffers()
RETURN
END SUBROUTINE mainLoop
SUBROUTINE cleanup() BIND(C)
USE, INTRINSIC :: ISO_C_BINDING
IMPLICIT NONE
CALL arVideoCapStop()
CALL arVideoClose()
CALL argCleanup()
RETURN
END SUBROUTINE cleanup
SUBROUTINE keyEvent( key, ix, iy ) BIND(C, NAME = 'keyEvent')
USE, INTRINSIC :: ISO_C_BINDING
IMPLICIT NONE
INTEGER(C_SIGNED_CHAR), VALUE :: key
INTEGER(C_INT) , VALUE :: ix, iy
SELECT CASE (key)
CASE (27)
PRINT *, "*** ", icount / arUtilTimer(), "(frame/sec)"
CALL cleanup()
STOP
CASE (32)
qaniki = .TRUE.
CASE DEFAULT
CONTINUE
END SELECT
RETURN
END SUBROUTINE keyEvent
SUBROUTINE draw() BIND(C)
USE, INTRINSIC :: ISO_C_BINDING
IMPLICIT NONE
REAL(gldouble) :: gl_para(4, 4)
REAL(glfloat ) :: mat_ambient(4) = (/0.0_glfloat, 0.0_glfloat, 1.0_glfloat, 1.0_glfloat/)
REAL(glfloat ) :: mat_flash(4) = (/0.0_glfloat, 0.0_glfloat, 1.0_glfloat, 1.0_glfloat/)
REAL(glfloat ) :: mat_emission(4) = (/0.1_glfloat, 0.0_glfloat, 1.0_glfloat, 1.0_glfloat/)
REAL(glfloat ) :: mat_flash_shiny(1) = (/50.0_glfloat/)
REAL(glfloat ) :: light_position(4) = (/0.0_glfloat, 0.0_glfloat, 200.0_glfloat, 0.0_glfloat/)
REAL(glfloat ) :: ambi(4) = (/0.1_glfloat, 0.1_glfloat, 0.1_glfloat, 0.1_glfloat/)
REAL(glfloat ) :: lightZeroColor(4) = (/0.9_glfloat, 0.9_glfloat, 0.9_glfloat, 0.1_glfloat/)
CALL argDrawMode3D()
CALL argDraw3dCamera( 0, 0 )
CALL glClearDepth( 1.0_gldouble )
CALL glClear(GL_DEPTH_BUFFER_BIT)
CALL glEnable(GL_DEPTH_TEST)
CALL glDepthFunc(GL_LEQUAL)
CALL argConvGlpara(patt_trans, gl_para)
CALL glMatrixMode(GL_MODELVIEW)
CALL glLoadMatrixd( gl_para )
CALL glEnable(GL_LIGHTING)
CALL glEnable(GL_LIGHT0)
CALL glLightfv(GL_LIGHT0, GL_POSITION, light_position)
CALL glLightfv(GL_LIGHT0, GL_AMBIENT, ambi)
CALL glLightfv(GL_LIGHT0, GL_DIFFUSE, lightZeroColor)
CALL glMaterialfv(GL_FRONT, GL_SPECULAR, mat_flash)
CALL glMaterialfv(GL_FRONT, GL_SHININESS, mat_flash_shiny)
CALL glMaterialfv(GL_FRONT, GL_AMBIENT, mat_ambient)
CALL glMatrixMode(GL_MODELVIEW)
CALL glPushMatrix()
IF (qaniki) THEN
CALL glTranslatef( 0.0_glfloat, 0.0_glfloat, 130.0_glfloat )
CALL glPushMatrix()
CALL glScalef( 2.0_glfloat, 2.0_glfloat, 2.0_glfloat )
lightZeroColor = (/1.0_glfloat, 0.0_glfloat, 0.1_glfloat, 0.1_glfloat/)
CALL glLightfv(GL_LIGHT0, GL_DIFFUSE, lightZeroColor)
CALL glTranslatef(-10.0_glfloat, 0.0_glfloat, -19.0_glfloat )
CALL glutSolidSphere( 3.0_gldouble, 10, 10 )
CALL glTranslatef( 38.0_glfloat, 0.0_glfloat, -5.0_glfloat )
CALL glutSolidSphere( 3.0_gldouble, 10, 10 )
CALL glPopMatrix()
CALL glScalef( 80.0_glfloat, 80.0_glfloat, 80.0_glfloat )
CALL glEnable(GL_TEXTURE_2D)
CALL glBindTexture( GL_TEXTURE_2D, 3 )
CALL glScalef( 4.0_glfloat, 4.0_glfloat, 4.0_glfloat )
CALL glBegin( GL_QUADS )
CALL glTexCoord2f( 0.0_glfloat, 0.0_glfloat )
CALL glVertex3f (-0.5_glfloat, 0.0_glfloat,-0.5_glfloat )
CALL glTexCoord2f( 0.0_glfloat, 1.0_glfloat )
CALL glVertex3f (-0.5_glfloat, 0.0_glfloat, 0.5_glfloat )
CALL glTexCoord2f( 1.0_glfloat, 1.0_glfloat )
CALL glVertex3f ( 0.5_glfloat, 0.0_glfloat, 0.5_glfloat )
CALL glTexCoord2f( 1.0_glfloat, 0.0_glfloat )
CALL glVertex3f ( 0.5_glfloat, 0.0_glfloat,-0.5_glfloat )
CALL glEnd()
CALL glDisable(GL_TEXTURE_2D)
ELSE
CALL glTranslatef( 0.0_glfloat, 0.0_glfloat, 160.0_glfloat )
CALL glScalef( 80.0_glfloat, 80.0_glfloat, 80.0_glfloat )
CALL glutSolidOctahedron()
CALL glPushAttrib(GL_LIGHTING_BIT)
CALL glLightfv(GL_LIGHT0, GL_EMISSION, ambi)
CALL glMaterialfv(GL_FRONT, GL_EMISSION, mat_emission)
CALL glutWireOctahedron()
CALL glPopAttrib()
END IF
CALL glPopMatrix()
CALL glDisable( GL_LIGHTING )
CALL glDisable( GL_DEPTH_TEST )
RETURN
END SUBROUTINE draw
SUBROUTINE makeImage()
USE :: m_bitmap
IMPLICIT NONE
INTEGER :: iheight, iwidth
INTEGER(1), ALLOCATABLE :: image(:)
INTEGER :: iret
CALL ReadBitMapData("aniki2b.bmp", iwidth, iheight, image)
CALL glPixelStorei( GL_UNPACK_ALIGNMENT, 1 )
CALL glBindTexture( GL_TEXTURE_2D, 3 )
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
END MODULE m_ART
PROGRAM main1
USE m_art
IMPLICIT NONE
CALL glutInit()
CALL init()
CALL makeImage()
CALL arVideoCapStart()
CALL argMainLoop( 0, C_FUNLOC(keyEvent), C_FUNLOC(mainLoop) )
STOP
END PROGRAM main1
