Skeletal animation for games in Haskell

I recently revisited my project to bring concepts from Jason Gregory's Game Engine Architecture into Haskell and found that they are translating quite well. The relational ideas I've been playing around with mesh nicely though there are still some rough edges. This is not a highly efficient implementation but I think that the code allows for some nice possible optimizations.

I decided that I wanted to implement skeletal animation since I figured that even a great set of free game sprites would only go so far. Fortunately GEA has a great description of this with a precise set of terminology, and helped me get this implementation going. I apologize ahead of time for any butchering of terminology that will likely happen.

As most of you know, skeletal animation binds meshes to a system of joints, so that manipulating the joints will deform the meshes. This allows you to get your characters into different poses without drawing them from scratch, and later, poses can also be blended to get combinations of movements, like running and shooting. I will skip most of the math specifics since there are a lot of resources that go into the details.

So far my code just gets from this:

To this:

But eventually this should let me get a lot of movement out of the characters from a small set of base art.

I'm still using a similar setup to Experimenting with Game Concepts in Haskell. So an entity like a player is split up into several components, and they are only associated with each other by a shared id. After using this for a while I feel that the single shared id is too limiting and a more standard relational design would work better, but the single id is a good starting point.

As before the entire game state is stored in a single value that is updated in a purely functional way. The game state value is stored in a transactional variable (TVar) that is updated on each game step.

data GameState = GameState { player :: HaskQuery.Relation (Component Player) (HaskQuery.IntIndex.IntIndex),
                             position :: HaskQuery.Relation (Component Position) (HaskQuery.IntIndex.IntIndex),
                             texture :: HaskQuery.Relation (Component Texture) (HaskQuery.IntIndex.IntIndex),
                             renderer :: HaskQuery.Relation (Component Renderer) (HaskQuery.IntIndex.IntIndex),
                             axisAlignedBoundingBox :: HaskQuery.Relation (Component AxisAlignedBoundingBox) (HaskQuery.IntIndex.IntIndex),
                             skeleton :: HaskQuery.Relation (Component Skeleton) (HaskQuery.IntIndex.IntIndex),
                             flatSkeleton :: HaskQuery.Relation (Component (FlatSkeleton Bone)) (HaskQuery.IntIndex.IntIndex),
                             flatSkeletonJoint :: HaskQuery.Relation (Component (FlatSkeleton Joint)) (HaskQuery.IntIndex.IntIndex),
                             _globalPose :: HaskQuery.Relation (Component GlobalSkeletonPose) (HaskQuery.IntIndex.IntIndex),
                             _mesh :: HaskQuery.Relation (Component Mesh) (HaskQuery.IntIndex.IntIndex),
                             _meshSkeletonBinding :: HaskQuery.Relation (Component MeshSkeletonBinding) (HaskQuery.IntIndex.IntIndex),
                             _animationClip :: HaskQuery.Relation (Component AnimationClip) (HaskQuery.IntIndex.IntIndex),
                             _animationState :: HaskQuery.Relation (Component AnimationState) (HaskQuery.IntIndex.IntIndex),
                             currentId :: GameEntityIdentifier
                           }

The key fields that are used for posing are:

 
position :: HaskQuery.Relation (Component Position) (HaskQuery.IntIndex.IntIndex),
flatSkeletonJoint :: HaskQuery.Relation (Component (FlatSkeleton Joint)) (HaskQuery.IntIndex.IntIndex),
_globalPose :: HaskQuery.Relation (Component GlobalSkeletonPose) (HaskQuery.IntIndex.IntIndex),
_mesh :: HaskQuery.Relation (Component Mesh) (HaskQuery.IntIndex.IntIndex),
_meshSkeletonBinding :: HaskQuery.Relation (Component MeshSkeletonBinding) (HaskQuery.IntIndex.IntIndex),

In this setup a skeleton is a tree of joints. Joints are affine transformations so linear transformation + translation or a 4x3 matrix. A lot of game engines don't store the full 4x3 matrix and store the joint as a Scale, Rotation (Quaternion) and Translation. I used the excellent Linear library for a lot of data structures and math functions.

So we take the base joints, add a notion of a primary key and parent id, then collect them in a relation using the relation library I've been experimenting with in Building Gtk2HS guis with queries.

data Joint = Joint { 
    _transform :: Linear.V3 (OpenGL.GLdouble), --This will need to be renamed later
    _scale :: (OpenGL.GLdouble), 
    _quaternion :: Linear.Quaternion (OpenGL.GLdouble)}
             deriving (Show)

data ComponentWithParent a = BoneWithParent { _parentId :: Int, _boneId :: Int, _bone :: a}
                             deriving (Show)


data FlatSkeleton a = FlatSkeleton { _rootId :: Int, _bones :: HaskQuery.Relation (ComponentWithParent a) (HaskQuery.IntIndex.IntIndex) }
                      deriving (Show)

Here's the skeleton that we're using, which is shown by the yellow lines in the images at the start.

let originalSkeleton = TestGame.Skeleton.flatSkeleton (-1) [
    TestGame.Types.BoneWithParent {TestGame.Types._parentId = -1, TestGame.Types._boneId =0, TestGame.Types._bone = TestGame.Skeleton.defaultJoint {TestGame.Types._quaternion = Linear.axisAngle (Linear.V3 0 0 1) (0.00)} },
    TestGame.Types.BoneWithParent {TestGame.Types._parentId = 0, TestGame.Types._boneId =1, TestGame.Types._bone = (TestGame.Skeleton.defaultJoint) {TestGame.Types._transform = Linear.V3 100 0 0, TestGame.Types._quaternion = Linear.axisAngle (Linear.V3 0 0 1) 0 }},
    TestGame.Types.BoneWithParent {TestGame.Types._parentId = 1, TestGame.Types._boneId =2, TestGame.Types._bone = (TestGame.Skeleton.defaultJoint) {TestGame.Types._transform = Linear.V3 100 0 0,  TestGame.Types._quaternion = Linear.axisAngle (Linear.V3 0 0 1) (0) }},
    TestGame.Types.BoneWithParent {TestGame.Types._parentId = -1, TestGame.Types._boneId =3, TestGame.Types._bone = (TestGame.Skeleton.defaultJoint) {TestGame.Types._quaternion = Linear.axisAngle (Linear.V3 0 0 1) (-pi)} },
    TestGame.Types.BoneWithParent {TestGame.Types._parentId = 3, TestGame.Types._boneId =4, TestGame.Types._bone = (TestGame.Skeleton.defaultJoint) {TestGame.Types._transform = Linear.V3 100 0 0, TestGame.Types._quaternion = Linear.axisAngle (Linear.V3 0 0 1) (0.0) }},
    TestGame.Types.BoneWithParent {TestGame.Types._parentId = 4, TestGame.Types._boneId =5, TestGame.Types._bone = (TestGame.Skeleton.defaultJoint) {TestGame.Types._transform = Linear.V3 100 0 0,  TestGame.Types._quaternion = Linear.axisAngle (Linear.V3 0 0 1) (0.0) }},
    TestGame.Types.BoneWithParent {TestGame.Types._parentId = -1, TestGame.Types._boneId =6, TestGame.Types._bone = (TestGame.Skeleton.defaultJoint) {TestGame.Types._quaternion = Linear.axisAngle (Linear.V3 0 0 1) (-0.5*pi)} },
    TestGame.Types.BoneWithParent {TestGame.Types._parentId = 6, TestGame.Types._boneId = 7, TestGame.Types._bone = (TestGame.Skeleton.defaultJoint) {TestGame.Types._transform = Linear.V3 100 0 0, TestGame.Types._quaternion = Linear.axisAngle (Linear.V3 0 0 1) (-0.25*pi)} },
    TestGame.Types.BoneWithParent {TestGame.Types._parentId = 6, TestGame.Types._boneId =8, TestGame.Types._bone = (TestGame.Skeleton.defaultJoint) {TestGame.Types._transform = Linear.V3 100 0 0, TestGame.Types._quaternion = Linear.axisAngle (Linear.V3 0 0 1) (0.25*pi)} },
    TestGame.Types.BoneWithParent {TestGame.Types._parentId = -1, TestGame.Types._boneId =9, TestGame.Types._bone = (TestGame.Skeleton.defaultJoint) {TestGame.Types._quaternion = Linear.axisAngle (Linear.V3 0 0 1) (0.50*pi)} }
]

The skeleton then has to be attached to meshes, in this image is a mesh for each arm, then one for the neck/head. The skeleton has an initial pose called the bind pose that is fixed when the meshes are attached. The mesh vertices will be transformed from where they are relative to the bind pose to where they are relative to the current pose.

Here is one of the purple arm meshes, which is a triangle strip in entityId order. I will omit the other meshes for the remaining discussion.

TestGame.Types.MeshComponent $ TestGame.Mesh.mesh $ \ meshRelation ->
    HaskQuery.insertRows meshRelation [  TestGame.Types.Component { TestGame.Types._entityId = 1, TestGame.Types._component = TestGame.Mesh.vertex3 0 25 0 },
        TestGame.Types.Component { TestGame.Types._entityId = 2, TestGame.Types._component = TestGame.Mesh.vertex3 0 (-25) 0},
        TestGame.Types.Component { TestGame.Types._entityId = 3, TestGame.Types._component = TestGame.Mesh.vertex3 100 (25) 0},
        TestGame.Types.Component { TestGame.Types._entityId = 4, TestGame.Types._component = TestGame.Mesh.vertex3 100 (-25) 0},
        TestGame.Types.Component { TestGame.Types._entityId = 5, TestGame.Types._component = TestGame.Mesh.vertex3 200 (25) 0},
        TestGame.Types.Component { TestGame.Types._entityId = 6, TestGame.Types._component = TestGame.Mesh.vertex3 200 (-25) 0},
        TestGame.Types.Component { TestGame.Types._entityId = 7, TestGame.Types._component = TestGame.Mesh.vertex3 300 (0) 0}
    ]

Now we need to attach this mesh to the original bind pose. The bind pose will always be used to determine the initial relationship between a joint and a vertex. This relation is a mapping from vertices to joints with a weight attached. So the vertices around the elbow will be jointly determined by the two parts of the arm joint. This is a natural fit for a relational model, though I am using a lot of manual id manipulation which I hope to reduce.

TestGame.Types.MeshSkeletonComponent $ TestGame.Mesh.meshSkeleton $ \ meshSkeletonBinding ->
    HaskQuery.insertRows meshSkeletonBinding [
        TestGame.Types.VertexJointBinding { TestGame.Types._vertexId = 1, TestGame.Types._jointId=0, TestGame.Types._bindWeight=1},
        TestGame.Types.VertexJointBinding { TestGame.Types._vertexId = 2, TestGame.Types._jointId=0, TestGame.Types._bindWeight=1},
        TestGame.Types.VertexJointBinding { TestGame.Types._vertexId = 3, TestGame.Types._jointId=0, TestGame.Types._bindWeight=0.5},
        TestGame.Types.VertexJointBinding { TestGame.Types._vertexId = 3, TestGame.Types._jointId=1, TestGame.Types._bindWeight=0.5},
        TestGame.Types.VertexJointBinding { TestGame.Types._vertexId = 4, TestGame.Types._jointId=0, TestGame.Types._bindWeight=0.5},
        TestGame.Types.VertexJointBinding { TestGame.Types._vertexId = 4, TestGame.Types._jointId=1, TestGame.Types._bindWeight=0.5},
        TestGame.Types.VertexJointBinding { TestGame.Types._vertexId = 5, TestGame.Types._jointId=1, TestGame.Types._bindWeight=1},
        TestGame.Types.VertexJointBinding { TestGame.Types._vertexId = 6, TestGame.Types._jointId=1, TestGame.Types._bindWeight=1},
        TestGame.Types.VertexJointBinding { TestGame.Types._vertexId = 7, TestGame.Types._jointId=2, TestGame.Types._bindWeight=1}]
                                                                 

Now we have our skeleton in bind pose bound to the meshes. Now we want to change the skeleton pose and transform the mesh appropriately.

Let's create the new pose with some help from the lens library:

let pose = originalSkeleton 
    & (TestGame.Types.bones %~ (\ uBones -> HaskQuery.update uBones (( == 0) . TestGame.Types._boneId  ) 
        (TestGame.Types.bone %~ (\bone -> bone { TestGame.Types._quaternion = Linear.axisAngle (Linear.V3 0 0 1) (-0.25) } ))))
    & (TestGame.Types.bones %~ (\ uBones -> HaskQuery.update uBones (( == 1) . TestGame.Types._boneId  ) 
        (TestGame.Types.bone %~ (\bone -> bone { TestGame.Types._quaternion = Linear.axisAngle (Linear.V3 0 0 1) (1) }  ))))
    & (TestGame.Types.bones %~ (\ uBones -> HaskQuery.update uBones (( == 2) . TestGame.Types._boneId  ) 
        (TestGame.Types.bone %~ (\bone -> bone { TestGame.Types._quaternion = Linear.axisAngle (Linear.V3 0 0 1) (0.75) }  ))))   

So now for the math, which I'll only cover at a high level. The skeleton in bind pose is a tree of transformations, each one relative to its parent. We need to turn this into a set of transformations, each one relative to the root coordinate system, instead of its parent.

To do this we traverse the tree, multiplying the transformations as we go down and collecting all the results. This is a recursive query on the bind pose relation.

flatJointSkeletonToGlobalPose :: FlatSkeleton Joint -> GlobalSkeletonPose
flatJointSkeletonToGlobalPose flatSkeletonJointPose =
    let emptyGlobalSkeletonPose = HaskQuery.reindex HaskQuery.empty (HaskQuery.IntIndex.intIndex _boneId)
    in  HaskQuery.insertInto emptyGlobalSkeletonPose $ do
            rootJoint <- HaskQuery.selectWithIndex (HaskQuery.IntIndex.intIndexSelector) (_bones flatSkeletonJointPose) (_rootId flatSkeletonJointPose)
            selectGlobalPoses (rootJoint { _bone = jointToMatrix $ (_bone rootJoint)}) flatSkeletonJointPose

Here we multiply the current local joint by the accumulated global joint.

selectGlobalPoses :: GlobalJointPose -> FlatSkeleton Joint -> HaskQuery.Cont (b -> b) GlobalJointPose
selectGlobalPoses joint flatSkeleton = do
    let parentGlobalJointPoseMatrix = (_bone joint)
    produceAndRecurse joint $ do
        b <- HaskQuery.selectWithIndex (HaskQuery.IntIndex.intIndexSelector) (_bones flatSkeleton) (_boneId joint)
        let globalJoint = b { _bone = parentGlobalJointPoseMatrix Linear.!*! (jointToMatrix $ (_bone b))}
        selectGlobalPoses globalJoint flatSkeleton

When skinning, we are going to take the global pose of the bind pose, invert it, apply the inverse to the meshes, then apply the current pose to the meshes. If we think of a hand mesh vertex at (1,1,1) from a joint, assuming no scaling, then after inverting, the vertex will be (1,1,1). Then we need to move that hand mesh vertex to where the joint currently is, so we apply the current pose global transformation which should be (1,1,1) from the current joint. Please check GEA or other resources for a better explanation.

The GameState value allows multiple renderers to be associated with an entity. There is a mesh renderer to render the skinned mesh in purple, and another one will render the skeleton in yellow. The mesh renderer will find the bind pose flatSkeletonJointComponent, mesh meshComponent and current pose globalPose with queries.

For each mesh it will start a triangle strip, and for each vertex in the mesh it will find all joint bindings and apply the inverse global bind pose and current global pose to the vertex with appropriate weights. This code was originally written with the single mesh case, now that there are multiple meshes, reordering the queries and only calculating the inverse once would probably be a good idea.

flatSkeletonMeshGlobalPoseRenderer :: (OpenGL.ColorComponent a) => OpenGL.Color4 a -> Renderer
flatSkeletonMeshGlobalPoseRenderer color entityId gameState  = do
    OpenGL.color $ color
    _ <- HaskQuery.runQueryM $ do
        Component { _component = positionComponent } <- TestGame.GameState.selectEntityByIdM gameState position entityId
        Component { _entityId = _meshEntityId, _component = meshComponent} <- TestGame.GameState.selectEntityByIdM gameState _mesh entityId
        Component { _entityId = _meshEntityId, _component = flatSkeletonJointComponent} <- TestGame.GameState.selectEntityByIdM gameState flatSkeletonJoint entityId
        Component { _entityId = _meshEntityId, _component = globalPose} <- TestGame.GameState.selectEntityByIdM gameState _globalPose entityId
        HaskQuery.executeM $ do
            let skinningMatrices = TestGame.Skeleton.flatJoinSkeletonToInverseGlobalPose flatSkeletonJointComponent
            OpenGL.preservingMatrix $ do
                OpenGL.translate (OpenGL.Vector3 (fromIntegral (xPosition positionComponent))
                                                 (fromIntegral (yPosition positionComponent))
                                                 (0 :: OpenGL.GLdouble))
                OpenGL.renderPrimitive OpenGL.TriangleStrip $ do
                    _ <- HaskQuery.runQueryM $ do
                        Component { _entityId = vertexId, _component = vertexComponent} <- HaskQuery.selectM (_meshVertices meshComponent)
                        Component { _component = skeletonBinding } <- TestGame.GameState.selectEntityByIdM gameState _meshSkeletonBinding entityId
                        HaskQuery.executeM $ do
                            let collector :: (Linear.V4 OpenGL.GLdouble, (Linear.V4 OpenGL.GLdouble -> Linear.V4 OpenGL.GLdouble -> Linear.V4 OpenGL.GLdouble))
                                collector = ((Linear.V4 0 0 0 1), (\ vector result -> vector Linear.^+^ result))
                            let vertex = HaskQuery.runQueryWithCollector collector $ do
                                    VertexJointBinding {_jointId = jointId, _bindWeight = bindWeight} <- HaskQuery.selectWithIndex HaskQuery.IntIndex.intIndexSelector (_meshVertexBinding skeletonBinding) vertexId
                                    BoneWithParent { _bone = skinningMatrix} <- HaskQuery.selectWithIndex HaskQuery.IntIndex.intIndexSelector  skinningMatrices jointId
                                    BoneWithParent { _bone = globalPoseMatrix } <- HaskQuery.selectWithIndex HaskQuery.IntIndex.intIndexSelector  globalPose jointId
                                    let OpenGL.Vertex3 x y z = vertexComponent
                                    return $  bindWeight Linear.*^ ((globalPoseMatrix Linear.!*! skinningMatrix) Linear.!* (Linear.V4 x y z 1))
                            let Linear.V4 px py pz _ = vertex
                            OpenGL.vertex $ OpenGL.Vertex3 px py pz
                        return ()
                    return ()
    return ()

While working on this I found a lot of advantages to representing data relationally. A recursive query gave a nice way of calculating global poses. VertexJointBinding which attaches meshes to bind pose skeletons was stored separately and did not change the definition of skeletons or meshes.

This code probably has a decent bit of overhead from using IntMaps under the hood everywhere, but the above queries could be used to build efficient Vectors to store static data. Data can be stored in a flexible format, then cooked down to more efficient representations for specific needs.

This is still experimental but I'm convinced that Haskell has a lot to offer for games development, and its tools for abstraction can make a lot of the complicated pieces of game development much easier to work with and reason about.

A quick way to run Postgres in Docker with local directory data storage

There are a lot of times where I want to quickly spin up a postgres server for some testing.

Unfortunately this usually involves installing it in the package manager and working with the global postgres config. Running postgres in Docker is better but volumes are tricky to deal with, and using data containers means you have to keep track of an extra container, as well as remembering to clean up volumes that are no longer used.

So I wrote this quick script that does all the steps needed to run a postgres docker container using a local directory for data storage, instead of volumes. So instead of having to leave your TestWebAppPostgresDb container and TestDataProcessingPostgresDb container hanging around in docker you can just leave them in local directories.

Quick usage

#Build the docker image
sudo docker build -t stevechy/postgres:v9.3 [DirectoryWithDockerFile]

#Make a database directory
mkdir -p projects/testDatabases/mytestdb

#Copy runDockerPostgres.py to the directory, or symlink it
cp runDockerPostgres.py projects/testDatabases/mytestdb

#Grab the default /etc/postgresql config from the docker image
cd projects/testDatabases/mytestdb
./runDockerPostgres.py --action extractEtcPostgresql

#Configure etc_postgresql/9.3/main/postgresql.conf if needed, for example, setting the port

#Initialize the postgres data cluster
./runDockerPostgres.py --action initDb

#You'll need a running postgres to create databases and users, start postgres in another terminal
./runDockerPostgres.py --action run

#Create a user
./runDockerPostgres.py --action createuser
#Enter name of role to add: testuser
#Enter password for new role: 
#Enter it again: 
#Shall the new role be a superuser? (y/n) n
#Shall the new role be allowed to create databases? (y/n) n
#Shall the new role be allowed to create more new roles? (y/n) n

#Create a database
./runDockerPostgres.py --action createdb --dbowner testuser --dbname testdb

You should now have a local running postgres that you can connect to.

Dockerfile:

from debian:wheezy

RUN echo "deb http://apt.postgresql.org/pub/repos/apt/ wheezy-pgdg main" > /etc/apt/sources.list.d/pgdg.list
RUN apt-get update

RUN apt-get -y install wget ca-certificates

RUN wget --quiet https://www.postgresql.org/media/keys/ACCC4CF8.asc ; apt-key add ACCC4CF8.asc

RUN apt-get update

RUN apt-get -y install postgresql-9.3

EXPOSE 5432

USER postgres

CMD ["/bin/bash"]

runDockerPostgres.py

Haskell OpenGL textures with JuicyPixels and Cairo

Quick note post, I saw some stackoverflow questions of how to load OpenGL textures from JuicyPixels and I found one way to do it. Seems like an easy way to shuttle binary data between libraries is to use bytestrings, though you might end up with more copies in the process. Looking at some other libraries, you can probably use vector directly but that's a bit too advanced for me.

I just noticed in pasting this code that useAsCString will add a null terminator, which shouldn't be a problem, but it's a little odd for this application.

module TestGame.TextureLoading
where

import Codec.Picture
import qualified Data.ByteString
import qualified Data.ByteString.Lazy
import qualified Data.ByteString.Lazy.Builder as ByteString.Builder
import qualified Data.Vector.Storable
import Data.Monoid
import qualified Graphics.Rendering.OpenGL as OpenGL
import Data.Int

data Loaded2dTexture = Loaded2dTexture { width :: Int, 
                                         height::Int, 
                                         textureData :: Data.ByteString.ByteString}

loadTexture :: FilePath -> IO (Maybe Loaded2dTexture)
loadTexture filePath = do
    imageEither  <- readImage filePath
    case imageEither of
        Left error -> do
            putStrLn error
            return Nothing
        Right image -> return $ rawImage image

rawImage :: DynamicImage -> (Maybe Loaded2dTexture)
rawImage (ImageRGBA8 image) = Just $ rawImageRGBA8 $ flipImageVertically image
rawImage _ = Nothing

--OpenGL has y going up so this makes it convenient for 2d game images
flipImageVertically :: Image PixelRGBA8 -> Image PixelRGBA8
flipImageVertically image = generateImage (flippedPixel) 
                                          (imageWidth image) 
                                          (imageHeight image)
    where flippedPixel x y = pixelAt image x ((imageHeight image) - 1 - y)

rawImageRGBA8 :: Image PixelRGBA8 -> Loaded2dTexture
rawImageRGBA8 image =
    Loaded2dTexture{
        width = imageWidth image,
        height = imageHeight image,
        --JuicyPixels image data is packed from first component to last component, 
        --should not need endian conversion
        textureData = copyPixelDataToByteString (imageData image)}
                      
copyPixelDataToByteString imageData =  Data.ByteString.Lazy.toStrict $ 
                      ByteString.Builder.toLazyByteString $ 
                      Data.Vector.Storable.foldl' appendPixel 
                                                  (mempty :: ByteString.Builder.Builder) 
                                                  imageData

appendPixel :: ByteString.Builder.Builder -> (PixelBaseComponent PixelRGBA8) -> ByteString.Builder.Builder
appendPixel pixelBytes pixelComponent = pixelBytes `mappend` (ByteString.Builder.word8 pixelComponent)

uploadTexture :: Loaded2dTexture -> IO ()
uploadTexture texture = do
    uploadTextureT texture OpenGL.Texture2D


uploadTextureRectangle :: Loaded2dTexture -> IO ()
uploadTextureRectangle texture = do
    uploadTextureT texture OpenGL.TextureRectangle


uploadTextureT :: (OpenGL.TwoDimensionalTextureTarget t, OpenGL.ParameterizedTextureTarget t ) =>  
                  Loaded2dTexture -> t -> IO ()
uploadTextureT texture textureTarget = do
    Data.ByteString.useAsCString (textureData texture) $ \ texturePtr ->  do
            let (texWidth, texHeight) = ((fromIntegral $ width texture), (fromIntegral $ height texture))
            OpenGL.texImage2D textureTarget 
                              OpenGL.NoProxy 0 OpenGL.RGBA' 
                              (OpenGL.TextureSize2D texWidth texHeight) 0 
                              (OpenGL.PixelData OpenGL.RGBA OpenGL.UnsignedByte (texturePtr))
    OpenGL.textureFilter textureTarget OpenGL.$= ((OpenGL.Linear', Nothing), OpenGL.Linear')

Bytestrings also work for shuttling data from cairo (hoping to get diagram generated textures!) but cairo uses the host endian format. Little endian ARGB = BGRA. This one is ripped from some existing code so it's not a full example.

import qualified Graphics.UI.GLFW as GLFW
import qualified Graphics.Rendering.OpenGL as OpenGL
import qualified Graphics.Rendering.OpenGL.GLU as OpenGL.GLU
import qualified Graphics.Rendering.FTGL as FTGL
import Control.Monad
import qualified Control.Concurrent
import Foreign.C.Types
import qualified Graphics.Rendering.Cairo as Cairo
import qualified Data.ByteString
import qualified Foreign.Ptr
import qualified Data.Word
import qualified Data.ByteString.Lazy.Builder
import qualified Data.ByteString.Lazy
import qualified Data.Binary.Get
import Data.Monoid

loadTexture = do
        cairoTexture <- renderCairo
        OpenGL.textureBinding OpenGL.Texture2D OpenGL.$= Just textureName
        Data.ByteString.writeFile "texture.raw" cairoTexture
        Data.ByteString.useAsCString (hostEndianToLittleEndian cairoTexture) $ \ texturePtr ->  do
            OpenGL.texImage2D OpenGL.Texture2D OpenGL.NoProxy 0 
                              OpenGL.RGBA' (OpenGL.TextureSize2D 512 512) 0 
                              (OpenGL.PixelData OpenGL.BGRA OpenGL.UnsignedByte (texturePtr))
        OpenGL.textureFilter OpenGL.Texture2D OpenGL.$= ((OpenGL.Linear', Nothing), OpenGL.Linear')

hostEndianToLittleEndian :: Data.ByteString.ByteString -> Data.ByteString.ByteString
hostEndianToLittleEndian sourceByteString =
    let initialBuilder = mempty :: Data.ByteString.Lazy.Builder.Builder
        convert builder = do
            empty <- Data.Binary.Get.isEmpty
            if empty
                then return builder
                else do
                    word32 <- Data.Binary.Get.getWord32host
                    convert (builder `mappend` (Data.ByteString.Lazy.Builder.word32LE word32)  )
    in Data.ByteString.Lazy.toStrict $ 
       Data.ByteString.Lazy.Builder.toLazyByteString $ 
       Data.Binary.Get.runGet (convert initialBuilder) (Data.ByteString.Lazy.fromStrict sourceByteString)

renderCairo :: IO Data.ByteString.ByteString
renderCairo = do
    Cairo.withImageSurface Cairo.FormatARGB32 512 512 $ \surface -> do
        drawSurface surface
        Cairo.imageSurfaceGetData surface

drawSurface :: Cairo.Surface -> IO ()
drawSurface surface = do
    Cairo.renderWith surface $ do
        --Doing the y axis flip for OpenGL directly in cairo
        Cairo.scale 1.0 (-1.0)
        Cairo.translate 0 (-512)
        Cairo.rectangle 0 0 512 512
        Cairo.setSourceRGBA 0.0 0.0 0.0 0.0
        Cairo.fill
        Cairo.setSourceRGB 0.5 0.5 0.5
        Cairo.rectangle 0 0 10 10
        Cairo.fill
        Cairo.setLineWidth 10.0
        Cairo.setSourceRGB 1.0 0.0 0.0
        Cairo.rectangle  50 50 200 200
        Cairo.stroke

        roundRectPath 100 100 200 50 10
        Cairo.setSourceRGB 0.25 0.25 0.25
        Cairo.fill
        Cairo.setSourceRGB 0.0 1.0 1.0
        Cairo.moveTo 120 120
        Cairo.setFontSize 20
        Cairo.showText $ "Hello Cairo!"




        Cairo.surfaceFlush surface
    return ()

roundRectPath x y width height radius = do
    Cairo.newPath
    Cairo.arc (x+width-radius) (y+radius) radius  (3*pi/2) (2*pi)
    Cairo.arc (x+width-radius) (y+height-radius) radius 0  (pi/2.0)
    Cairo.arc (x+radius) (y+height-radius) radius (pi/2.0) (pi)
    Cairo.arc (x+radius) (y+radius) radius pi (3*pi/2)
    Cairo.closePath

Building Gtk2Hs GUIs with queries

Please comment on reddit

In my previous post Haskell::Reddit helped me find out that the continuation monad can be used to make an interesting query like interface. I've been using this interface to refactor my toy editor program and it's been working fairly well. I still haven't fixed the issue that started this tangent (opening a file twice results in two tabs) but that's side project coding for you.


My toy editor is not very complicated but it still took a while to build directly. Gtk2Hs is a great library but not as easy to use as HTML + JS. The web has made some amazing progress in making UIs easier to build and I'm hoping that some of those insights can be transferred to the native GUI world.

When you use the gtk api directly, you tend to build things in a hierarchical way based on how you want things laid out. But a lot of the times you want connections between components (I'm hoping to have components that aren't Gtk widgets eventually) that cross hierarchies:

This isn't too bad but once right click menus are added it could get messy. And even when the connections match the hierarchy, you don't want to tie layout to event handling logic.

Glade is supposed to be a solution to this but for my side project coding I'd rather work with direct code.

In the original version of the editor I had to have a second initialization phase after I did my layout to setup the callbacks correctly.

main :: IO ()
main :: IO ()
main = do
    initGUI
    window <- windowNew
    set window [windowDefaultWidth := 800, windowDefaultHeight := 600]
    
    mainBox <- vBoxNew False 0
    _ <- containerAdd window mainBox

    buttonBar <- hBoxNew False 0
    
    button <- buttonNewWithLabel "Open Project"
    saveButton <- buttonNewWithMnemonic "_Save Files"
    refreshButton <- buttonNewWithMnemonic "S_ynchronize Folders"
    boxPackStart buttonBar button PackNatural 0
    boxPackStart buttonBar saveButton PackNatural 0
    boxPackStart buttonBar refreshButton PackNatural 0
    widgetShowAll buttonBar
    
    boxPackStart mainBox buttonBar PackNatural 0
          
    editor <- makeEditor
    
    
    onClicked button $ newFileChooser $ loadFile editor
    onClicked saveButton $ saveFiles editor
    onClicked refreshButton $ refreshFolders editor
    
    onRowActivated (_fileTreeView editor) $ openFileChooserFile editor
    
    boxPackStart mainBox (mainPane editor) PackGrow 0
             

    onDestroy window mainQuit
    widgetShowAll button    
    widgetShowAll mainBox
    widgetShowAll window
    mainGUI

makeEditor  = do
        {- widget creation setup..etc -}
    let editorWindow =  EditorWindow { mainPane = mainVPane, 
                          _fileTreeView = fileTreeView, 
                          _fileTreeStore = treeStore, 
                          notebook = noteBook, 
                          _rootPath = filePath, 
                          nextGuiId = guiId,
                          sourceBuffers = buffers
                        } 
    consoleBookInitializer editorWindow
    return editorWindow

So these lines came after

editor <- makeEditor

:

    onClicked button $ newFileChooser $ loadFile editor
    onClicked saveButton $ saveFiles editor
    onClicked refreshButton $ refreshFolders editor

Because opening a project and refreshing the folders meant updating the file tree (it should also clear the tabs when opening a project... another bug), the callback needed to get the file tree somehow. But the buttons were created before the file tree since they are on top. Also EditorWindow needs to have the file tree created before it can be created.

I decided to tag components with a String identifier, like HTML ids, then I could query for the component based on the identifier. Like jQuery if the query does not find anything then nothing happens. So then I could setup callbacks without worrying about the order of creating components.

I could store each of the components in a separate container but after trying it out I gave up and went with Data.Dynamic. String identifiers and Data.Dynamic steps aren't the Haskell way but it was the best idea I had at the time. For some extra type-safety I added constants that put the identifiers together with their types.

data Named a = Named { _identifier :: String, _content :: a}
data Widgets = Widgets {  _widgets :: HaskQuery.Relation (Named Dynamic) (OrdIndex.OrdIndex String)}

type WidgetRef a = Named (Proxy a)

widgetReference :: String -> WidgetRef a
widgetReference identifier = Named { _identifier = identifier, _content = Proxy}

HaskQuery (as of this post) is just where I put all my query stuff. HaskQuery.Relation is a wrapper around Data.IntMap that makes the interface more SQL-like.

data Relation a b = Relation { _relation :: Data.IntMap.Lazy.IntMap a , 
    _lastRowId :: Int, _indices :: UpdatableIndex a b} 
    deriving (Show)

selectDynamicWithTypeM :: (Data.Typeable.Typeable a, Monad m) 
=> Data.Proxy.Proxy a 
-> Data.Dynamic.Dynamic 
-> Control.Monad.Trans.Cont.Cont (b->m b) a
selectDynamicWithTypeM proxy value = 
    Control.Monad.Trans.Cont.cont (\continuation -> 
                                        (\seed -> (case Data.Dynamic.fromDynamic value of 
                                                                    Just typed -> continuation typed seed 
                                                                    Nothing -> return seed)))

selectM :: Monad m => Relation a c -> Control.Monad.Trans.Cont.Cont (b -> m b) a
selectM relation = Control.Monad.Trans.Cont.cont (\continuation -> 
    (\seed -> Data.IntMap.Lazy.foldl 
        (\foldSeed value ->  foldSeed >>= continuation value) 
        (return seed) 
        (_relation relation)))

selectWidget :: Typeable a => Widgets -> String -> Proxy a -> (HaskQuery.Cont (b -> IO b) a)
selectWidget widgets identifier typeProxy = do        
        widget <- HaskQuery.selectM $ _widgets widgets
        HaskQuery.filterM $ (_identifier widget) == identifier
        selectedWidget <- HaskQuery.selectDynamicWithTypeM typeProxy (_content widget)
        return selectedWidget

selectWidgetRef :: Typeable a => Widgets -> WidgetRef a -> (HaskQuery.Cont (b -> IO b) a)
selectWidgetRef widgets widgetRef = selectWidget widgets (_identifier widgetRef) (_content widgetRef)

Ok, with that I could now change the direct file tree lookup for refreshing the file list to one that did a lookup for the file tree:

Before

makeEditor  = do
        {- widget creation setup..etc -}
    let editorWindow =  EditorWindow { mainPane = mainVPane, 
                          _fileTreeView = fileTreeView, 
                          _fileTreeStore = treeStore, 
                          notebook = noteBook, 
                          _rootPath = filePath, 
                          nextGuiId = guiId,
                          sourceBuffers = buffers
                        } 
    consoleBookInitializer editorWindow
    return editorWindow

refreshFolders editor = do
  canonicalRootPathMaybe <- atomically $ readTVar (_rootPath editor) 
  case canonicalRootPathMaybe of 
        Just canonicalRootPath -> do
                                    forest <- getDirContentsAsTree canonicalRootPath
                                    let fileTreeStore = _fileTreeStore editor 
                                    treeStoreClear fileTreeStore  
                                    treeStoreInsertForest fileTreeStore [] 0 forest
                                    return ()
        Nothing -> return ()

After

fileTreeStoreRef :: WidgetRef (TreeStore DirectoryEntry)
fileTreeStoreRef = widgetReference "fileTreeStore"

makeEditorWindow ::  IO EditorWindow
makeEditorWindow = do
    filePath <- atomically $ newTVar Nothing
    buffers <- atomically $ newTVar IntMap.empty
    propertyRelation <- atomically $ newTVar HaskQuery.empty
    widgetTVar <- atomically $ newTVar emptyWidgets
   
    guiId <- newIORef 0
    
    let editorWindow =  EditorWindow {   
                          _editorWidgets = widgetTVar,   
                          _rootPath = filePath, 
                          nextGuiId = guiId,
                          sourceBuffers = buffers,
                          _properties = propertyRelation
                        } 
    return editorWindow

refreshFolders :: EditorWindow -> IO ()
refreshFolders editor = do
  canonicalRootPathMaybe <- atomically $ readTVar (_rootPath editor) 
  case canonicalRootPathMaybe of 
        Just canonicalRootPath -> do
            forest <- getDirContentsAsTree canonicalRootPath
            _ <- HaskQuery.runQueryM $ do
                 widgets <- getWidgets (_editorWidgets editor)
                 fileTreeStore <- selectWidgetRef widgets fileTreeStoreRef 
                 HaskQuery.executeM $ do
                     treeStoreClear fileTreeStore  
                     treeStoreInsertForest fileTreeStore [] 0 forest
            return ()
        Nothing -> return ()

The new code is uglier but it's a lot easier to move pieces of code around and separate layout code from event connection code. EditorWindow can now be created without any Gtk widgets which might be useful for writing test code. Another nice thing is that I can now remove the file tree and replace it at run time. This might be useful if I want to rebuild parts of the layout.

I'm still experimenting with the best way to use queries and what the tradeoffs are but it has definitely helped me decouple my GUI code and it's making this project a lot more fun. The code version as of this post is at github/stevechy/HaskellEditor.

Finding an interesting interface for simple io in Haskell

(This is going to be a long post, but there were a lot of wrong turns and bumps that I encountered that might be helpful to others, kind of a postmortem.
Comments on reddit
Turns out I ended up getting the Cont monad, have a lot to learn, thanks reddit user rampion!)

I had an annoying bug in my editor side project (link).  If you opened the same file twice then you would get two tabs with the same file.   The save button also saves all tabs so if I accidentally opened the same file twice, one of them could overwrite the other.

Should be an easy fix, unfortunately my data structure wasn't going to help:

data EditorWindow = EditorWindow { mainPane:: VPaned,
                                   _fileTreeStore :: TreeStore DirectoryEntry,
                                   _fileTreeView:: TreeView,
                                   notebook :: Notebook,
                                   _rootPath :: TVar (Maybe FilePath),                                  
                                   nextGuiId :: IORef (Int),
                                   sourceBuffers :: TVar ( IntMap.IntMap (String, SourceBuffer))
                                   }

I'd have to write something to go over the sourceBuffers and match the strings.  Ugh.  Then I thought that it would be really nice to write queries over the gui state like jQuery.  Would be nice for the file system too.

Seemed like it should be possible, I'd been reading a lot of good things about core.logic, watched Adam Foltzer's Molog presentation, Phil Wadler's LINQ presentation.  Looked at some core.logic presentations, went over the "Essence of LINQ" paper, started looking at pieces of William Byrd's miniKanren dissertation, LogicT paper, and List monad stuff.

After all that I figured that I just needed something that did nested loop type stuff like the List monad or an SQL query.  And it would be really great if I could get it into do notation.  For directory reading I had to get the directory entries then after that figure out if they were files or directories.  It would be nice if it looked like this:

dirContents dirPath = do
    filePath <- selectM (directoryContentsRelation dirPath)
    fileNode <- selectM (directoryType filePath)
    return fileNode

The TLDR is that after much goose chasing the above actually works. Still haven't organized it, it's in here for now RelationalTest.hs

The Goose Chase

Didn't look like I could get it into a monad, but at least this Beyond Monads post showed me that you could chain a custom bind >>>= in a pretty readable way so that wasn't too bad.

Seemed like it would be easier to start with files. So something that "selected" from a file would loop over the lines, then collect the results. Since most of the operations would be appends, I stuck in a DList. So the file would provide a source of data, and it would call a consumer to add results to the DList.

type SeedConsumer b = Data.DList.DList b -> IO (Data.DList.DList b)
type IOAccumulator a b = a -> SeedConsumer b
type IOSource a b = Data.DList.DList b -> IOAccumulator a b-> IO (Data.DList.DList b)

readFileRelation :: IOSource String b
readFileRelation seed consumer = withFile "LICENSE" ReadMode (readFileStep seed consumer)

readFileStep :: Data.DList.DList b -> IOAccumulator String b -> Handle -> IO ( Data.DList.DList b )
readFileStep seed consumer handle = do
   isEof <- hIsEOF handle
   if isEof 
       then return $ seed
       else do 
                 line <- hGetLine handle
                 result <- consumer line seed
                 readFileStep result consumer handle

This looked pretty good, it could do query like things like filter out lines:

sat :: Data.DList.DList a -> Bool -> a -> Data.DList.DList a
sat seed True elem = Data.DList.snoc seed elem
sat seed False elem = seed

tests :: Test
tests = TestList [
        TestLabel "Should Query File" $ TestCase $ do
            fileRelations <- readFileRelation emptySeed (\ line seed  -> return (Data.DList.snoc seed line) ) 
            putStrLn $ showDlist $ fileRelations
            assertEqual "Queried file"  "a" "a"
        ,TestLabel "Should Query File" $ TestCase $ do
            fileRelations <- readFileRelation emptySeed (\ line seed  -> return $ (sat seed (length line <= 10) line) )  
            putStrLn $ showDlist $ fileRelations
            assertEqual "Queried file" "a" "a"
]

Then I added some convenience functions:

selectPipe :: IOSource a b -> IOAccumulator a b -> SeedConsumer b
selectPipe source accumulator = \seed  -> source seed accumulator

It was kind of annoying to pass through the seed all the time, and I was thinking that most of the time the consumer would not modify the seed, so I added some functions to manage the seed separately. This actually ended up side tracking my thinking a bit but made writing the code a bit easier.

type IOConsumer a b = a -> IO (Data.DList.DList b)

accum ::  IOConsumer a b -> IOAccumulator a b
accum consumer = \ input seed -> do
    result <- consumer input
    return $ Data.DList.append seed result

select :: IOSource a b -> IOConsumer a b -> SeedConsumer b
select source consumer = selectPipe source (accum consumer)


flatDirectoryContents :: DirectoryPath -> IOSource FileNode b
flatDirectoryContents dirPath seed consumer = 
    applySeed seed $ selectPipe (directoryContentsRelation dirPath) $ \ filePath ->
        selectPipe (directoryType filePath) $ consumer

fileTree :: DirectoryPath -> IO( Data.DList.DList FileTree )
fileTree dirPath = 
    applySeed emptySeed $ select (flatDirectoryContents dirPath) $ \fileNode -&gt
        if traversable fileNode
            then do 
                subTrees <- fileTree (fileNodePath fileNode)
                    return $ having True $ (Tree fileNode (Data.DList.toList subTrees)) 
            else return $ having True $ (Leaf fileNode) 

I played around with select and selectPipe a bit more and was starting to think that this was really close to a monad. And I really wanted the nice do syntax. So what were the elements of the monad? It looked like the source was a good thing:

type IOSource a b = Data.DList.DList b -> IOAccumulator a b-> IO (Data.DList.DList b)

But then I didn't know how to write >>=. Maybe I could use free monads. I pulled out operational, added the GADT extension, tried to make IOSource a command of the free monad.

The b parameter ended up being a problem. I tried hiding the b in the GADT but I couldn't get it to typecheck. It ended up with an error where some outside b1 looked like it was exactly b but it wasn't able to match them. I tried tweaking it a bunch more times but it wouldn't work.

Well I'm not the greatest person with types, I've actually taken a category theory course before (not really type systems but kind of similar). I even audited it again to try and get more out of it, but I have no intuition for it and can pretty much only crunch through the definitions manually.

So I went back to square one. I thought it over and over. Then I wondered why I was doing this on a Sunday. Then I wondered why I was spending all this brain time on a side project. Then I went for a walk to the store. Then an idea popped up.

The b type parameter never changed through all of the bind applications. Actually all the types with b never changed. So Data.DList.DList b and IO (Data.DList.DList b) were kind of constants when binding. So I really wanted IOSource to look more like:

type IOSource a b =  IOAccumulator a b-> Data.DList.DList b -> IO (Data.DList.DList b)

Which was actually:

type IOSource a b =  (a -> Data.DList.DList b -> IO (Data.DList.DList b)) -> Data.DList.DList b -> IO (Data.DList.DList b)

And then I really wanted the b to be applied first:

type IOSource b a =  (a -> Data.DList.DList b -> IO (Data.DList.DList b)) -> Data.DList.DList b -> IO (Data.DList.DList b)

Now, (IOSource b) looked like a monad, the b parameters didn't matter since they would be fixed from the monad point of view. Maybe I could write >>= now. I didn't really want to rewrite my IOSource code yet though, so since they were just synonyms I tried to make a type for this new thing that might be a monad.

data RelationMonad b a = RelationMonad { source ::  (a -> Data.DList.DList b -> IO (Data.DList.DList b)) -> Data.DList.DList b -> IO (Data.DList.DList b)  }

Now I had to fill in the instance functions:

instance Monad (RelationMonad b) where
    return x = ?
    relationMonad >>= f = ?

So what was return? Thinking of the file IOSource, return x would be kind of like a one line file. So it would just call the consumer with x.

return x = RelationMonad { source = \ accum -> accum x}

What about >>= ? Well what would f be in this case? It would take in an input from the source then produce another source...

But the >>= would have to produce a new source. It looked like the source was kind of a function with a hole in it, kind of like the "one hole context" idea.

And the hole is an accumulator, something that takes an input and adds it to the seed.

 So >>= would have to take a source1 with a hole, a function from the "output" (lines of the file) of source1 to a source2 then produce a new source3 with a hole with source2's "output" type.

Still pretty fuzzy, what are the types of these things? The b is now fixed so make it z to get it out of the way.

--Not exactly code

relationMonad :: (RelationMonad z) a

f :: a -> (RelationMonad z) b

source3 :: (RelationMonad z) b
source3 = relationMonad >>= f

source3 :: RelationMonad { source ::  (b -> Data.DList.DList z -> IO (Data.DList.DList z)) -> Data.DList.DList z -> IO (Data.DList.DList z)  }

Oh, so now I have to make a new source that takes in a hole thing of type (b -> Data.DList.DList z -> IO (Data.DList.DList z)) using relationMonad and f.

Well if I apply f to the output of relationMonad then I get a source like that, but I still have to run relationMonad.

I guess I have to make a new accumulator of type (a -> Data.DList.DList z -> IO (Data.DList.DList z)) then pass that to relationMonad.

But to make an accumulator from a source I have to fill the hole with another accumulator.

Oh, that's going to be the accumulator that is passed in to the new source3.

--Not exactly code

newSource :: a -> (RelationMonad z) b
newSource = \input -> (source (f input))

newAccumulator :: (a -> Data.DList.DList z -> IO (Data.DList.DList z))
newAccumulator :: (\input -> (source (f input)) accum)

relationMonadWithNewAccumulator ::  Data.DList.DList z -> IO (Data.DList.DList z)
relationMonadWithNewAccumulator = (source relationMonad) (\input -> (source (f input)) accum) 

source3 :: RelationMonad { source ::  \accum -> (source relationMonad) (\input -> (source (f input) accum)   }

Ok, does that work?

instance Monad (RelationMonad b) where
    return x = RelationMonad { source = \ accum -> accum x}
    relationMonad >>= f = RelationMonad { source =  \accum -> (source relationMonad) (\input -> (source (f input)) accum) }

It typechecks and it runs.

runMonad :: RelationMonad (Data.DList.DList b -> IO (Data.DList.DList b)) b -> IO (Data.DList.DList b)
runMonad relationMonad = ((source relationMonad) (\ input seed -> return $ Data.DList.snoc seed input)) Data.DList.empty

selectM :: IOSource a b -> RelationMonad (Data.DList.DList b -> IO (Data.DList.DList b)) a
selectM src = RelationMonad { source = (\accum seed -> src seed accum )}

dirContents dirPath = do
    filePath <- selectM (directoryContentsRelation dirPath)
    fileNode <- selectM (directoryType filePath)
    return fileNode

tests :: Test
tests = TestList [
     TestLabel "Monad"  $ TestCase $ do
            dirRelations <- runMonad $ dirContents (DirectoryPath "." "sandbox")
            putStrLn $ ""
            putStrLn $ showDlist $ dirRelations
            assertEqual "Queried DirMonad" "a" "a"
    ]

So this is pretty neat interface for reading files and looping over things. Any function that fits the signature will work, so it could loop over filenames then use those filenames to loop over GUI elements. Also can loop over file names, read the files, then collect the results in a list. Cool, wow almost didn't think it was going to work.

But there's still something kind of weird, we didn't really touch the (Data.DList.DList b -> IO (Data.DList.DList b)) part:

data RelationMonad b a = RelationMonad { source ::  (a -> Data.DList.DList b -> IO (Data.DList.DList b)) -> Data.DList.DList b -> IO (Data.DList.DList b)  }

does this work?

data RelationMonad b a = RelationMonad { source ::  (a -> b) -> b  }

Strangely it does. I don't know what this thing is now. Maybe Binder? It kind of does part of what >>= does in other monads.

EDIT: Turns out this is the Cont monad, guess I need to study more :)

Is it actually a monad? Well I always thought Gabriel Gonzalez's equational reasoning tutorial was pretty neat, so might as well try it out:


data Binder b a = Binder { source ::  (a -> b) -> b  }
 instance Monad (Binder b) where
    return x = Binder { source = \ accum -> accum x}
     relationMonad >>= f = Binder { source =  \accum -> (source relationMonad) (\input -> (source (f input)) accum) }

Monad laws
 Left identity:
 return a >>= f
 ≡
 f a

 Proof:
 return a >>= f
 ≡ (apply definition of return)
 Binder { source = \ accum -> accum a} >>= f
 ≡ (apply definition of >>=)
 Binder { source =  \accum -> (source Binder { source = \ accum1 -> accum1 a}) (\input -> (source (f input)) accum) }
 ≡ (cancel source)
 Binder { source =  \accum -> ( \ accum1 -> accum1 a) (\input -> (source (f input)) accum) }
 ≡ (apply (\input -> (source (f input)) to \accum1... )
 Binder { source =  \accum -> ((\input -> (source (f input)) a)  accum) }
 ≡ (apply a to \input ...)
 Binder { source =  \accum -> (source (f a)) )  accum) }
 ≡
 Binder { source =  source (f a) }
 ≡
 f a


 Right identity:
 m >>= return
 ≡
 m

 Proof:

 m >>= return
 ≡ (apply definition of >>=)
 Binder { source =  \accum -> (source m) (\input -> (source (return input)) accum) }
 ≡ (apply definition of return)
 Binder { source =  \accum -> (source m) (\input -> (source (Binder { source = \ accum1 -> accum1 input})) accum) }
 ≡ (cancel source)
 Binder { source =  \accum -> (source m) (\input -> (\ accum1 -> accum1 input) accum) }
 ≡ (apply accum to \accum...)
 Binder { source =  \accum -> (source m) (\input ->  accum input ) }
 ≡
 Binder { source =  \accum -> (source m) accum }
 ≡
 Binder { source = source m } ≡ m


 Associativity:
 (m >>= f) >>= g
 ≡
 m >>= (\x -> f x >>= g)

 Proof:

 (m >>= f) >>= g
 ≡ (apply definition of >>=)
 Binder { source =  \accum -> (source m) (\input -> (source (f input)) accum) } >>= g
 ≡ (rename) 
Binder { source =  \accum1 -> (source m) (\input1 -> (source (f input1)) accum1) } >>= g
 ≡ (apply definition of >>=)
 Binder { source =  \accum -> (source RelationMonad { source =  \accum1 -> (source m) (\input1 -> (source (f input1)) accum1) }) (\input -> (source (g input)) accum) }
 ≡ (cancel source)
 Binder { source =  \accum -> (\accum1 -> (source m) (\input1 -> (source (f input1)) accum1)) (\input -> (source (g input)) accum) }
 ≡ (apply (\input -> (source (g input)) accum) to \accum1 ...)
 Binder { source =  \accum -> (source m) (\input1 -> (source (f input1)) (\input -> (source (g input)) accum))  }
 ≡ (rename)
 Binder { source =  \accum -> (source m) (\input ->   (source (f input)) (\input1 -> (source (g input1)) accum))  }



 Other side:
 m >>= (\x -> f x >>= g)
 ≡ (apply definition of >>=)
 m >>= ( \x ->  Binder { source =  \accum -> (source (f x)) (\input -> (source (g input)) accum) })
 ≡ (rename)
 m >>= ( \x ->  Binder { source =  \accum1 -> (source (f x)) (\input1 -> (source (g input1)) accum1) }) 
≡ (apply definition of >>=)
 Binder { source =  \accum -> (source m) (\input -> (source (( \x ->  Binder { source =  \accum1 -> (source (f x)) (\input1 -> (source (g input1)) accum1) }) input)) accum) }
 ≡ (apply input to \x ...)
 Binder { source =  \accum -> (source m) (\input -> (source ( Binder { source =  \accum1 -> (source (f input)) (\input1 -> (source (g input1)) accum1) } )) accum) }
 ≡ (cancel source)
 Binder { source =  \accum -> (source m) (\input ->  (\accum1 -> (source (f input)) (\input1 -> (source (g input1)) accum1)) accum) }
 ≡ (apply accum to \accum1)
 Binder { source =  \accum -> (source m) (\input ->   (source (f input)) (\input1 -> (source (g input1)) accum))  }
≡
 (m >>= f) >>= g



Ok, so it's quite possible I made a mistake but it looks like it is a monad. I don't know what this monad really is though since I'm still just thinking of it in terms of sources and accumulators. Anyone have an idea?

Experimenting with game engine concepts in Haskell

I've had Jason Gregory's excellent Game Engine Architecture (GEA) on my bookshelf for a while and every time I skim through I want to try out the ideas in it. Watching John Carmack talk about Haskell at QuakeCon got me thinking about trying them out in Haskell.

Armed with some notion that this was a good idea and some idea of how real games are set up I worked out a few details in haskellGame.  It's not even a demo at this point, but so far I've learned some things that I'd like to share.

(Thanks to Kenny.nl for awesome free game graphics!)

Game Loop

Most games are driven by a game loop.  The loop grabs events, applies them to the game state then renders it.  In an imperative language, this might look like:

 

while(!gameEngine.done()) {
    currentTicks = getTicks();
    frameDelay = currentTicks - lastTicks;
    gameEngine.updateGameObjects();
    gameEngine.applyPhysics(frameDelay);
    gameEngine.detectAndResolveCollisions();
    gameEngine.render();
    lastTicks = currentTicks;
}

GEA describes reasons why most engines update objects in batched phases.  This works out nicely in Haskell as it naturally operates on batches of objects of the same type.

In Haskell, each of these phases can be implemented as a function from GameState -> GameState. Then the loop just needs to apply all the phases to the game state on every run through. I later had to add some communication between the phases, which I represented as GameEventQueues. So a game phase is now (GameState, GameEventQueues) -> (GameState, GameEventQueues).

Could the GameState contain the event queues?  Maybe, I don't have a good idea of which is better at this point.

 

gameLoop :: (GameState -> IO t) -> IO Event -> GameState -> GHC.Word.Word32 -> IO ()
gameLoop drawAction eventAction gameState lastFrameTicks = do
 
  events <- HaskellGame.HumanInterface.Manager.pollEvents eventAction []
  let gameEvents = GameEventQueues { gameActions = concat $ Data.List.map (HaskellGame.HumanInterface.Manager.playerGameAction playerId) events,
                                  physicsActions = [] }
  
  let state = Data.Maybe.isNothing $ find (\x -> x == Graphics.UI.SDL.Events.Quit) events 
  
  currentTicks <- Graphics.UI.SDL.Time.getTicks
  
  let frameDelay = fromIntegral $ currentTicks - lastFrameTicks
   
  let (finalState, finalQueues) = 
        Data.List.foldl' ( \ currentGameState gameStep -> gameStep currentGameState) (gameState, gameEvents) 
                   [ HaskellGame.Gameplay.Simulator.processGameStateOutputEvents, 
                     HaskellGame.Physics.Simulator.applyPhysicsChanges, 
                     HaskellGame.Physics.Simulator.applyPhysics frameDelay, 
                     HaskellGame.Physics.CollisionDetector.detectAndResolveCollisions frameDelay
                   ]        
  
  
  _ <- drawAction finalState

  case state of
    True -> do 
      Graphics.UI.SDL.Time.delay 30
      gameLoop drawAction eventAction finalState currentTicks
    False -> return ()

Game State

The game loop applies phases that operate on different slices of data.  Well that was the theory at least, most of these update position information.  The original theory seemed to work well with what GEA calls a "pure component model" for game objects.  Entities in the game are just distinct components that are bound together by a unique identifier.

With that in mind, the GameState became mostly a collection of IntMaps from identifiers to game components:

type BoundingBoxState = Data.IntMap.Lazy.IntMap BoundingBox

type PhysicsState = Data.IntMap.Lazy.IntMap VelocityAcceleration

type WorldState = Data.IntMap.Lazy.IntMap Position

type AnimationStates = Data.IntMap.Lazy.IntMap AnimationClip

type RenderingHandlers = Data.IntMap.Lazy.IntMap RenderingHandler

type ActorStates = Data.IntMap.Lazy.IntMap ActorState

data GameState = GameState { worldState :: WorldState, 
                             _resources :: GraphicResources, 
                             actorStates :: ActorStates, 
                             physicsState::PhysicsState, 
                             boundingBoxState :: BoundingBoxState,
                             _animationStates :: AnimationStates,
                             renderingHandlers :: RenderingHandlers, 
                             _font :: Font }

I was trying to push the design a bit to see where it breaks by separating Position and VelocityAcceleration.  A funny thing came out of it, I can omit the VelocityAcceleration component of platforms and the physics phase won't be able to move them.

Originally I initialized each of the maps separately, but calling code that adds entities will usually want to define all of the components together.  First I added a union type to work with the cases, but later, I added a convenience typeclass.  I've been trying to avoid using a lot of typeclasses but this one seemed to work out well.

{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
module HaskellGame.Game where

-- .... snipped code

data GameComponent = PositionComponent Position 
                       | CollisionComponent BoundingBox 
                       | PhysicsComponent VelocityAcceleration 
                       | RenderingComponent RenderingHandler 
                       | ActorComponent ActorState
                       | AnimationComponent AnimationClip

class GameComponentStore a where
    toComponent :: a -> GameComponent

instance GameComponentStore Position where
    toComponent = PositionComponent 

instance GameComponentStore BoundingBox where
    toComponent = CollisionComponent 

instance GameComponentStore VelocityAcceleration where
    toComponent = PhysicsComponent 

instance GameComponentStore RenderingHandler where
    toComponent = RenderingComponent 

instance GameComponentStore ActorState where
    toComponent = ActorComponent 

instance GameComponentStore AnimationClip where
    toComponent = AnimationComponent 

This makes entity definition a lot easier since the caller does not need to know the union constructor names.

initializeGameState :: GameState -> GameState
initializeGameState gameState = 
    insertEntities gameState [GameEntity randomSquareId [toComponent (BoundingBox 0 0 10 10), 
                                              toComponent (Position 300 5),
                                              toComponent HaskellGame.Rendering.Renderer.rectRenderer ],
                              GameEntity playerId [toComponent $ Position 5 5,
                                                    toComponent $ VelocityAcceleration {vx = 0, vy = 0.00, ax = 0, ay = 0.0002},
                                                    toComponent $ BoundingBox 0 0 66 92,
                                                    toComponent $ Idle,
                                                    toComponent $ HaskellGame.Rendering.Renderer.animatedRender,
                                                    toComponent $ AnimationClip {_resourceId = playerId, _startTime = 0, _rate = 125}
                                                    ],
                              GameEntity floorId  [toComponent $ Position 0 400,
                                                     toComponent $ HaskellGame.Rendering.Renderer.rectRenderer,
                                                     toComponent $ BoundingBox 0 0 640 10
                                                    ],
                              GameEntity platformId  [toComponent $ Position 500 300,
                                                     toComponent $ HaskellGame.Rendering.Renderer.rectRenderer,
                                                     toComponent $ BoundingBox (-25) (-25) 50 50
                                                    ]
                             ] 

Testing

This structure should lead to easier tests, one nice thing is that only the components that are being tested need to be added to the test case.

I've only made two HUnit tests so far, specifically for this blog post, but I hope to add more as it goes:

 
ts :: Test
tests = TestList [   
    TestLabel "AccelTest"
        (TestCase 
            (do  let intialGameState = HaskellGame.Types.emptyGameState
                 let playerEntityId = 201404
                 let playerEntity = GameEntity playerEntityId [toComponent $ Position 5 5,
                                                         toComponent $ VelocityAcceleration {vx = 0, vy = 0.00, ax = 0, ay = 0.0002},
                                                         toComponent $ BoundingBox 0 0 66 92]
                 let gameState = insertEntity intialGameState playerEntity
                 let physicsTimeInterval = 1000
                 let (gameStateAfterPhysics, _) = HaskellGame.Physics.Simulator.applyPhysics physicsTimeInterval (gameState, HaskellGame.Types.emptyGameEventQueues)
                 let positionAfterPhysics = Data.IntMap.Lazy.lookup playerEntityId $ worldState gameStateAfterPhysics
                 assertEqual "Force was applied" (Just $ Position 5 205) positionAfterPhysics)
        ),
    TestLabel "Collision Test"
        (TestCase 
            (do  let intialGameState = HaskellGame.Types.emptyGameState
                 let playerEntityId = 20140401
                 let playerEntity = GameEntity playerEntityId [toComponent $ Position 5 5,                                                         
                                                         toComponent $ BoundingBox 0 0 10 10]
                 let enemyEntityId = 20140402
                 let enemyEntity = GameEntity enemyEntityId [toComponent $ Position 5 5,                                                         
                                                         toComponent $ BoundingBox 0 0 5 5]
                 let gameState = insertEntities intialGameState [playerEntity, enemyEntity]
                 
                 let [((collisionEntityA,_,_), (collisionEntityB,_,_)) ] = HaskellGame.Physics.CollisionDetector.collisions gameState
                 assertEqual "Collisions detected" (playerEntityId, enemyEntityId) (collisionEntityA, collisionEntityB))
        )
    ]

HUnit produces pretty decent errors, wondering if something like Hamcrest would help though.

 

### Failure in: 0:AccelTest               
Force was applied
expected: Just (Position {_x = 1, _y = 205})
 but got: Just (Position {_x = 5, _y = 205})
### Failure in: 1:Collision Test          
Collisions detected
expected: (20140401,20140403)
 but got: (20140401,20140402)
Cases: 2  Tried: 2  Errors: 0  Failures: 2

Next steps and general impressions

I've implemented the basics of an animation system, an animation clip points to an array of images, but now the current game time needs to be threaded through the GameState, which will be also be needed to pause and save the game.  Eventually the clips will have to change based on changes to entity states, but because the animation frame is just a function of the current time and the start time of the clip, AnimationClip itself does not need to change.  This could help for background elements that just repeat a single animation cycle.

Having Int typed time is also inconvenient in a lot of places so I'll have to think about how to change it.

I cheated to play around with animation by adding a separate SDL getTicks call in the animation handler.  It's definitely wrong, but I've found it's kind of nice to have IO pockets here and there to cheat a bit, as long as it's clear that it's happening.

 

data AnimationClip = AnimationClip { _resourceId :: GameEntityIdentifier , _startTime :: Int, _rate :: Int }

So far I've been pretty happy with the project, and I haven't gotten really stuck at this early stage.  Refactoring to move the individual phases into different modules cleared a lot of things up and I've learned a lot.  I've been trying to prefer constructs that reduce the impact of changes over those that produce shorter code, though it's more of a feeling that I can't put into writing at the moment.

Changes are starting to get easier, and are starting to feel more localized.  Pattern matching is awesome but sometimes it feels like it introduces too much coupling.  Naming record fields with underscores got rid of a lot of compiler warnings, though there are still a lot left to clean up.

Eventually I need to work through a full usage of the event passing mechanism for some more involved game mechanics, work on saving the game, better resource loading, menu screen, then loading/storing levels and more.

I guess I'm saying if you're looking for a Haskell side project, a game engine will definitely burn some cycles :)

Writing elementary Haskell for fun and learning

(EDIT: decided to change the name of this to elementary)

I've been playing around with Haskell on and off for a while now.  I guess I wrote my first Haskell program around 2005.  It's been pretty slow going but I've started to get used to it more and more, and it has replaced Python as my main language for side projects alongside Java.

One of the great things about the Haskell community is that it is continually trying to find more elegant, more efficient and more powerful ways of solving problems.  Over the years this has resulted in a large body of knowledge that seems to be growing by leaps and bounds every month.

For a beginner though, even a long time beginner like myself, it can be intimidating and it can discourage you from learning more about this wonderful language.  You might feel that if your program that doesn't use the hottest techniques, idioms, and libraries then it will be obsolete before it's even completed.

The fact is though, that even if you write fairly bad Haskell, you will still learn a lot and you will learn even more refactoring that code as you go on.  Despite all of the sophisticated new concepts that people are developing in Haskell, the basic language is still incredibly powerful and expressive, and this is easy to miss if you are following the cutting edge developments.

As a response I purposely try to write elementary Haskell, and this helps me write more Haskell programs.  When programming elementary Haskell:

• Use simple data structures.  Plain records, union types, and containers.  
• Make specific data types first, parameterization can be done later
• You probably don't need your own typeclasses yet
• When in doubt, implement it in IO first and pull out pieces of pure code
• Use wrapper types so you can change data structures later, e.g. data BookCollection = BookCollection [Books]
• Use wrapper types to decouple code, especially to decouple application logic from complicated libraries
• Stick to the plain IO monad, avoid monads like State,Reader, and Writer for pure code
• Use IO to decouple code if needed.  

The thing about IO is that in your regular programs it's all over the place anyway.  It doesn't need to be removed instantly now that it's explicit.

Some extra things I've been trying to work on for general readability but haven't been doing enough of yet are:

• Limit the number of direct dependencies a module has, use the number of imports as a guide
• Isolate special language features in sub modules, see if the part that is needed can be wrapped in a simpler interface
• Prefer qualified imports

Two side projects that I've been trying to use this on are:

A game project 

And a haskell editor.

I ended up wanting to create the editor after noticing that I really just wanted a tabbed editor for haskell files and found that emacs buffer switching was just encouraging me to make larger and larger modules.  If I can integrate it with command line applications through shelly then I should be ready to start using it regularly.

Eventually I might outgrow this practice but I think it results in code that strikes a good balance between taking advantage of Haskell's expressiveness while being fairly easy to understand and hopefully even easy to train other people to work with.  I probably need to work in lens for easier data manipulation and pipes or conduit to manage resources but so far it seems like I can still build some fun and enjoyable programs in this limited space.