Touch rotating cube in Frege on Android. See froid instructions on how to run.

CubeActivity.fr

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