Create a gist now

Instantly share code, notes, and snippets.

Touch rotating cube in Frege on Android. See froid instructions on how to run.
module io.github.mchav.touchcube.CubeActivity where
import froid.javax.microedition.khronos.egl.EGLConfig
import froid.javax.microedition.khronos.opengles.GL10
import froid.java.nio.ByteBuffer
import froid.java.nio.IntBuffer
import froid.app.Activity
import froid.content.Context
import froid.opengl.GLSurfaceView
import froid.opengl.glSurfaceView.java.NativeRenderer
import froid.opengl.glSurfaceView.Renderer
import froid.os.Bundle
import froid.view.InputDevice
import froid.view.MotionEvent
import froid.view.View
import Data.Bits
native module type Activity where {}
onCreate :: MutableIO Activity -> Maybe (MutableIO Bundle) -> IO ()
onCreate this bundle = do
context <- this.getApplicationContext
glSurfaceView <- newTouchSurfaceView context
view <- glSurfaceView.asView
this.setContentView (view :: MutableIO View)
glSurfaceView.requestFocus
glSurfaceView.setFocusableInTouchMode True
this.setOnResume glSurfaceView.onResume
this.setOnPause glSurfaceView.onPause
-- GLSurfaceView
newTouchSurfaceView :: MutableIO Context -> IOMutable GLSurfaceView
newTouchSurfaceView context = do
angleX <- newIORef (0 :: Float)
angleY <- newIORef (0 :: Float)
previousX <- newIORef (0 :: Float)
previousY <- newIORef (0 :: Float)
renderer <- newCubeRenderer angleX angleY
surfaceView <- mkGLSurfaceView context (surfaceViewDelegator angleX angleY previousX previousY)
surfaceView.setRenderer renderer
surfaceView.setRenderMode GLSurfaceView.renderModeWhenDirty
return surfaceView
surfaceViewDelegator :: IORef Float -> IORef Float -> IORef Float -> IORef Float -> GLSurfaceViewDelegator
surfaceViewDelegator ax ay px py = defaultGLSurfaceView.{ onTouchEvent = Just (onTouchEvent px py ax ay)
, onTrackballEvent = Just (onTrackballEvent ax ay )
}
onTrackballEvent :: IORef Float -> IORef Float ->
MutableIO GLSurfaceView -> MutableIO MotionEvent -> IO Bool
onTrackballEvent angleX angleY this e = do
x <- e.getX
y <- e.getY
modifyIORef angleX (+ (x * trackballScaleFactor))
modifyIORef angleY (+ (y * trackballScaleFactor))
this.requestRender
return True
onTouchEvent :: IORef Float -> IORef Float -> IORef Float -> IORef Float ->
MutableIO GLSurfaceView -> MutableIO MotionEvent -> IO Bool
onTouchEvent previousX previousY angleX angleY this e = do
touchAction <- e.getActionMasked
x <- e.getX
y <- e.getY
prevX <- readIORef previousX
prevY <- readIORef previousY
-- update angles
let (dx, dy) = updateAngles (x - prevX) (y - prevY)
zipWithM_ writeIORef [angleX, angleY, previousX, previousY] [x, y, dx, dy]
this.requestRender
return True
updateAngles :: Float -> Float -> (Float, Float)
updateAngles dx dy = ((dx * touchScaleFactor), (dy * touchScaleFactor))
touchScaleFactor :: Float
touchScaleFactor = 180.0 / 320
trackballScaleFactor :: Float
trackballScaleFactor = 36.0
-- cube renderer
newCubeRenderer :: IORef Float -> IORef Float -> STMutable RealWorld GLSurfaceViewRenderer
newCubeRenderer angleX angleY = do
cube <- newCube
mkGLSurfaceViewRenderer (rendererDelegator cube angleX angleY)
rendererDelegator :: Cube -> IORef Float -> IORef Float -> GlsvRendererDelegator
rendererDelegator cube x y = GlsvRendererDelegator { onDrawFrame = Just (onDrawFrame cube x y)
, onSurfaceCreated = Just onSurfaceCreated
, onSurfaceChanged = Just onSurfaceChanged
}
onDrawFrame :: Cube -> IORef Float -> IORef Float -> MutableIO GL10 -> IO ()
onDrawFrame cube angleX angleY gl = do
x <- readIORef angleX
y <- readIORef angleY
gl.glClear (GL10.glColorBufferBit .|. GL10.glDepthBufferBit)
gl.glMatrixMode GL10.glModelView
gl.glLoadIdentity
gl.glTranslatef 0 0 (-3)
gl.glRotatef x 0 1 0
gl.glRotatef y 1 0 0
gl.glEnableClientState GL10.glVertexArray
gl.glEnableClientState GL10.glColorArray
drawCube gl cube
onSurfaceCreated :: MutableIO GL10 -> MutableIO EGLConfig -> IO ()
onSurfaceCreated gl config = do
gl.glDisable GL10.glDither
gl.glHint GL10.glPerspectiveCorrectHint GL10.glFastest
gl.glClearColor 1 1 1 1
gl.glEnable GL10.glCullFace
gl.glShadeModel GL10.glSmooth
gl.glEnable GL10.glDepthTest
onSurfaceChanged :: MutableIO GL10 -> Int -> Int -> IO ()
onSurfaceChanged gl width height = do
gl.glViewport 0 0 width height
let ratio = width.float / height.float
gl.glMatrixMode GL10.glProjection
gl.glLoadIdentity
gl.glFrustumf (-ratio) ratio (-1) 1 1 10
--- cube
-- a cube is just a collection of buffers
data Cube = CubeBuffers { vertexBuffer :: MutableIO IntBuffer
, colorBuffer :: MutableIO IntBuffer
, indexBuffer :: MutableIO ByteBuffer
}
newCube :: IO Cube
newCube = do
vertexBuffer <- initIntBuffer vertices
colorBuffer <- initIntBuffer colors
indexBuffer <- initByteBuffer indices
return CubeBuffers { vertexBuffer = vertexBuffer, colorBuffer = colorBuffer, indexBuffer = indexBuffer }
initIntBuffer :: [Int] -> IOMutable IntBuffer
initIntBuffer xs = do
nativeByteOrder <- ByteOrder.nativeOrder ()
bb <- ByteBuffer.allocateDirect ((length xs) * 4)
bb.order nativeByteOrder
buffer <- bb.asIntBuffer
bs <- arrayFromListST xs
buffer.put bs
buffer.position 0
return buffer
initByteBuffer :: [Byte] -> IOMutable ByteBuffer
initByteBuffer xs = do
bb <- ByteBuffer.allocateDirect (length xs)
bytes <- arrayFromListST xs
bb.put bytes
bb.position 0
return bb
drawCube :: MutableIO GL10 -> Cube -> IO ()
drawCube gl cube = do
gl.glFrontFace GL10.glCW
gl.glVertexPointer 3 GL10.glFixed 0 cube.vertexBuffer
gl.glColorPointer 4 GL10.glFixed 0 cube.colorBuffer
gl.glDrawElements GL10.glTriangle 36 GL10.glUnsignedByte cube.indexBuffer
vertices :: [Int]
vertices = [ (-one), (-one), (-one)
, one , (-one), (-one)
, one , one , (-one)
, (-one), one , (-one)
, (-one), (-one), one
, one , (-one), one
, one , one , one
, (-one), one , one
]
colors :: [Int]
colors = [ 0 , 0, 0, one
, one, 0, 0, one
, one, one, 0, one
, 0 , one, 0, one
, 0 , 0, one, one
, one, 0, one, one
, one, one, one, one
, 0 , one, one, one
]
indices :: [Byte]
indices = [ 0, 4, 5, 0, 5, 1
, 1, 5, 6, 1, 6, 2
, 2, 6, 7, 2, 7, 3
, 3, 7, 4, 3, 4, 0
, 4, 7, 6, 4, 6, 5
, 3, 0, 1, 3, 1, 2
]
one :: Int
one = 0x10000
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment