Sunday, October 26, 2014

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

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, 
                                         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 =
        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) 

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.setSourceRGB 0.5 0.5 0.5
        Cairo.rectangle 0 0 10 10
        Cairo.setLineWidth 10.0
        Cairo.setSourceRGB 1.0 0.0 0.0
        Cairo.rectangle  50 50 200 200

        roundRectPath 100 100 200 50 10
        Cairo.setSourceRGB 0.25 0.25 0.25
        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.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)

Saturday, September 20, 2014

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
    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

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:


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 ()


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.

Friday, April 18, 2014

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

 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 >>= 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

 (m >>= f) >>= g
 m >>= (\x -> f x >>= g)


 (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?

Thursday, March 6, 2014

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 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;
    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 $ (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.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, 
                             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


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"
            (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"
            (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 :)