Merge pull request #44 from Anut-py/performance

Bunnymark example

CONTRIBUTING.md

@@ -2,7 +2,9 @@
 
 Anybody willing to contribute to the project is welcome to do so. Please use the GitHub issue tracker to report any bugs you find.
 
-You can run the examples by using `cabal run {example name}` in the project directory.
+You can run the examples by using `cabal run [example-name]` in the project directory.
+
+You can run an example with profiling by using `cabal run [example-name] --ghc-options="-fprof-auto -rtsopts -threaded" --enable-library-profiling --enable-profiling -- +RTS -N -P`. This will generate a file `example-name.prof` with the profiling info.
 
 You can use `run-all-examples.sh` to run all of the examples in one go.
 

cabal.project

@@ -1,3 +1,6 @@
 packages: *.cabal
+
+optimization: 2
+
 package h-raylib
   flags: +examples

examples/basic-audio/src/Main.hs

@@ -10,7 +10,7 @@ import Raylib.Util (drawing, inGHCi, whileWindowOpen0, withWindow)
 import Raylib.Util.Colors (lightGray, rayWhite)
 
 musicPath :: String
-musicPath = (if not inGHCi then "../../../../../../../../../" else "./") ++ "examples/basic-audio/assets/mini1111.xm"
+musicPath = (if not inGHCi then "../../../../../../../../../../" else "./") ++ "examples/basic-audio/assets/mini1111.xm"
 
 main :: IO ()
 main = do

examples/basic-automation-events/src/Main.hs

@@ -40,8 +40,6 @@ main =
     "raylib [core] example - basic automation events"
     60
     ( \window -> do
-        el <- newAutomationEventList
-        listRef <- setAutomationEventList el window
         rWidth <- measureText "REC" 30
         pWidth <- measureText "PLAY" 30
 
@@ -56,16 +54,18 @@ main =
                         then
                           ( do
                               l <- newAutomationEventList
-                              setAutomationEventList l window
+                              Just <$> setAutomationEventList l window
                           )
                         else return lRef
                     when toggleRec $ if recording' then setAutomationEventBaseFrame 60 >> startAutomationEventRecording else stopAutomationEventRecording
                     when recording' $ drawText "REC" (790 - rWidth) 10 30 red
 
-                    list <- peekAutomationEventList lRef'
+                    lEvents <- case lRef' of
+                      Nothing -> return []
+                      Just l -> automationEventList'events <$> peekAutomationEventList l
                     let playback' =
                           if toggleRec && not recording'
-                            then Just (automationEventList'events list, 0)
+                            then Just (lEvents, 0)
                             else playback
                     startPlay <- isKeyPressed KeyP
                     let playing' = isJust playback' && not recording' && (startPlay || playing)
@@ -85,7 +85,7 @@ main =
                         else return playback'
                     let (playback''', playing'') =
                           case playback'' of
-                            Nothing -> let e = automationEventList'events list in if null e then (Nothing, False) else (Just (e, 0), False)
+                            Nothing -> if null lEvents then (Nothing, False) else (Just (lEvents, 0), False)
                             v -> (v, playing')
 
                     clearBackground white
@@ -100,7 +100,7 @@ main =
                       Nothing -> drawText "Click somewhere or press the arrow keys" 10 10 20 black >> drawText "Press 'R' to start or stop recording, and 'P' to play the recording" 10 40 20 black
                       Just (p@(Vector2 x y), t) ->
                         ( do
-                            when (t < 1.0) $ drawCircleV p (sin ((realToFrac t) * pi / 1.0) * 10) red
+                            when (t < 1.0) $ drawCircleV p (sin (realToFrac t * pi / 1.0) * 10) red
                             drawText ("Mouse clicked at (" ++ show x ++ ", " ++ show y ++ ")") 10 (if y < 50 && t < 1.0 then 570 else 10) 20 black
                         )
 
@@ -112,7 +112,7 @@ main =
                     let shiftLeft =
                           case mState'' of
                             Nothing -> 0
-                            Just ((Vector2 x y), t) -> if x > 580 && y > 490 && t < 1.0 then -580 else 0
+                            Just (Vector2 x y, t) -> if x > 580 && y > 490 && t < 1.0 then -580 else 0
 
                     (if uDown then drawRectangle else drawRectangleLines) (660 + shiftLeft) 500 60 40 lb
                     (if dDown then drawRectangle else drawRectangleLines) (660 + shiftLeft) 550 60 40 lb
@@ -122,5 +122,5 @@ main =
                     return (mState'', playback''', playing'', recording', lRef')
                 )
           )
-          (Nothing, Nothing, False, False, listRef)
+          (Nothing, Nothing, False, False, Nothing)
     )

examples/basic-images/src/Main.hs

@@ -21,7 +21,7 @@ import Raylib.Util (drawing, inGHCi, textureMode, whileWindowOpen0, withWindow)
 import Raylib.Util.Colors (black, lightGray, orange, white)
 
 logoPath :: String
-logoPath = (if not inGHCi then "../../../../../../../../../" else "./") ++ "examples/basic-images/assets/raylib-logo.png"
+logoPath = (if not inGHCi then "../../../../../../../../../../" else "./") ++ "examples/basic-images/assets/raylib-logo.png"
 
 main :: IO ()
 main = do

examples/basic-models/src/Main.hs

@@ -11,7 +11,7 @@ import Raylib.Util (drawing, inGHCi, mode3D, whileWindowOpen_, withWindow)
 import Raylib.Util.Colors (orange, white)
 
 modelPath :: String
-modelPath = (if not inGHCi then "../../../../../../../../../" else "./") ++ "examples/basic-models/assets/Model.obj"
+modelPath = (if not inGHCi then "../../../../../../../../../../" else "./") ++ "examples/basic-models/assets/Model.obj"
 
 main :: IO ()
 main = do

examples/basic-rlgl/src/Main.hs

@@ -12,7 +12,7 @@ import Raylib.Util.RLGL (rlBegin, rlColor4ub, rlEnd, rlNormal3f, rlPopMatrix, rl
 import Prelude hiding (length)
 
 texturePath :: String
-texturePath = (if not inGHCi then "../../../../../../../../../" else "./") ++ "examples/basic-rlgl/assets/cubicmap_atlas.png"
+texturePath = (if not inGHCi then "../../../../../../../../../../" else "./") ++ "examples/basic-rlgl/assets/cubicmap_atlas.png"
 
 main :: IO ()
 main = do

examples/basic-shaders/src/Main.hs

@@ -42,7 +42,7 @@ import Raylib.Util (inGHCi, setMaterialShader, whileWindowOpen_)
 import Raylib.Util.Colors (black, blue, lightGray, orange, white)
 
 assetsPath :: String
-assetsPath = (if not inGHCi then "../../../../../../../../../" else "./") ++ "examples/basic-shaders/assets/"
+assetsPath = (if not inGHCi then "../../../../../../../../../../" else "./") ++ "examples/basic-shaders/assets/"
 
 main :: IO ()
 main = do

examples/bunnymark/src/Main.hs

@@ -0,0 +1,229 @@
+{-# OPTIONS -Wall #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE BangPatterns #-}
+
+-- Writing performant h-raylib code requires the use of pointers and other
+-- un-Haskelly functionality. Unfortunately, this cannot be avoided.
+
+module Main where
+
+import Control.Monad (forM_, unless, void, when)
+import Foreign
+  ( Ptr,
+    Storable (alignment, peek, peekByteOff, poke, pokeByteOff, sizeOf),
+    advancePtr,
+    callocArray,
+    free,
+    malloc,
+    nullPtr,
+    peek,
+    plusPtr,
+    poke,
+  )
+import Foreign.C (CFloat, withCString)
+import Raylib.Core
+  ( beginDrawing,
+    c'getMouseX,
+    c'getMouseY,
+    c'getRandomValue,
+    changeDirectory,
+    clearBackground,
+    endDrawing,
+    getApplicationDirectory,
+    getFrameTime,
+    getScreenHeight,
+    getScreenWidth,
+    initWindow,
+    isMouseButtonDown,
+    setTargetFPS,
+    windowShouldClose,
+  )
+import Raylib.Core.Shapes (drawRectangle)
+import Raylib.Core.Text (drawFPS, drawText)
+import Raylib.Core.Textures (c'drawTexture, c'loadTexture, c'unloadTexture)
+import Raylib.Types (Color (Color), MouseButton (MouseButtonLeft), Texture (texture'height, texture'width))
+import Raylib.Util (inGHCi, raylibApplication)
+import Raylib.Util.Colors (black, green, maroon, rayWhite)
+
+texPath :: String
+texPath = (if not inGHCi then "../../../../../../../../../../" else "./") ++ "examples/bunnymark/assets/wabbit_alpha.png"
+
+maxBunnies :: Int
+maxBunnies = 500000 -- 500K bunnies limit
+
+-- Strict fields
+data Bunny = Bunny
+  { px :: !Float,
+    py :: !Float,
+    sx :: !Float,
+    sy :: !Float,
+    color :: !(Ptr Color) -- Store colors as pointers to avoid reallocating memory each time
+  }
+  deriving (Show, Eq)
+
+cfs :: Int
+cfs = sizeOf (0 :: CFloat)
+
+nps :: Int
+nps = sizeOf nullPtr
+
+instance Storable Bunny where
+  alignment _ = min cfs nps
+  sizeOf _ = 4 * cfs + nps
+
+  -- We do not peek/poke entire bunnies in this example, so the code below is never called
+  -- (we advance the pointers using the `p'*` functions to directly access the fields)
+  peek _p = do
+    _px <- realToFrac <$> (peekByteOff _p (0 * cfs) :: IO CFloat)
+    _py <- realToFrac <$> (peekByteOff _p (1 * cfs) :: IO CFloat)
+    _sx <- realToFrac <$> (peekByteOff _p (2 * cfs) :: IO CFloat)
+    _sy <- realToFrac <$> (peekByteOff _p (3 * cfs) :: IO CFloat)
+    _color <- peekByteOff _p (4 * cfs) :: IO (Ptr Color)
+    return $ Bunny {px = _px, py = _py, sx = _sx, sy = _sy, color = _color}
+  poke _p (Bunny _px _py _sx _sy _color) = do
+    pokeByteOff _p (0 * cfs) (realToFrac _px :: CFloat)
+    pokeByteOff _p (1 * cfs) (realToFrac _py :: CFloat)
+    pokeByteOff _p (2 * cfs) (realToFrac _sx :: CFloat)
+    pokeByteOff _p (3 * cfs) (realToFrac _sy :: CFloat)
+    pokeByteOff _p (4 * cfs) _color
+    return ()
+
+p'px :: Ptr Bunny -> Ptr CFloat
+p'px = (`plusPtr` (0 * cfs))
+
+p'py :: Ptr Bunny -> Ptr CFloat
+p'py = (`plusPtr` (1 * cfs))
+
+p'sx :: Ptr Bunny -> Ptr CFloat
+p'sx = (`plusPtr` (2 * cfs))
+
+p'sy :: Ptr Bunny -> Ptr CFloat
+p'sy = (`plusPtr` (3 * cfs))
+
+p'color :: Ptr Bunny -> Ptr (Ptr Color)
+p'color = (`plusPtr` (4 * cfs))
+
+data AppState = AppState
+  { texBunny :: !(Ptr Texture),
+    halfTexWidth :: !CFloat,
+    halfTexHeight :: !CFloat,
+    bunnies :: !(Ptr Bunny), -- Store the bunnies as a pointer because Haskell linked lists are extremely slow
+    bunniesCount :: !Int
+  }
+  deriving (Show, Eq)
+
+startup :: IO AppState
+startup = do
+  _ <- initWindow 800 450 "raylib [textures] example - bunnymark"
+  setTargetFPS 60
+  unless inGHCi (void $ changeDirectory =<< getApplicationDirectory)
+  texPtr <- withCString texPath c'loadTexture
+  -- Use `peek` when you need to access the underlying fields
+
+  -- If you have to do this often (e.g. every frame), use `plusPtr`
+  -- to get a pointer to the exact field that you need
+
+  -- For example, this could be rewritten as
+  --   tWidth <- fromIntegral (peekByteOff texPtr 4 :: IO CInt)
+  -- but since we are only doing this on startup, there is no need to optimize it
+  tex <- peek texPtr
+  bunniesPtr <- callocArray maxBunnies
+  return
+    ( AppState
+        { texBunny = texPtr,
+          bunnies = bunniesPtr,
+          halfTexWidth = fromIntegral (texture'width tex) / 2,
+          halfTexHeight = fromIntegral (texture'height tex) / 2,
+          bunniesCount = 0
+        }
+    )
+
+mainLoop :: AppState -> IO AppState
+mainLoop state = do
+  screenWidth <- getScreenWidth
+  screenHeight <- getScreenHeight
+
+  beginDrawing
+  clearBackground rayWhite
+  forM_
+    [0 .. (bunniesCount state - 1)]
+    ( \(!i) ->
+        do
+          -- Advancing the array pointer to get a pointer to a bunny
+          let bunny = advancePtr (bunnies state) i
+          -- Advancing the bunny pointer to access the fields
+          _px <- peek $ p'px bunny
+          _py <- peek $ p'py bunny
+          _color <- peek $ p'color bunny
+          c'drawTexture (texBunny state) (floor _px) (floor _py) _color
+    )
+  drawRectangle 0 0 screenWidth 40 black
+  drawText ("bunnies: " ++ show (bunniesCount state)) 120 10 20 green
+  drawText ("batched draw calls: " ++ show (1 + (bunniesCount state `div` 8192))) 320 10 20 maroon
+  drawFPS 10 10
+  endDrawing
+
+  forM_
+    [0 .. (bunniesCount state - 1)]
+    ( \(!i) ->
+        do
+          -- Same thing as before, but reading (`peek`) _and_ writing (`poke`)
+          let bunny = advancePtr (bunnies state) i
+          _px <- peek $ p'px bunny
+          _py <- peek $ p'py bunny
+          _sx <- peek $ p'sx bunny
+          _sy <- peek $ p'sy bunny
+          _color <- peek $ p'color bunny
+          let px' = _px + _sx
+              py' = _py + _sy
+              adjX = px' + halfTexWidth state
+              adjY = py' + halfTexHeight state
+          poke (p'px bunny) px'
+          poke (p'py bunny) py'
+          when (adjX > fromIntegral screenWidth || adjX < 0) $ poke (p'sx bunny) (-_sx)
+          when (adjY > fromIntegral screenHeight || adjY < 40) $ poke (p'sy bunny) (-_sy)
+    )
+
+  do
+    lDown <- isMouseButtonDown MouseButtonLeft
+    if lDown
+      then do
+        frameTime <- getFrameTime
+        let newBunnies = min (round (10000 * frameTime)) (maxBunnies - bunniesCount state)
+        mx <- realToFrac <$> c'getMouseX
+        my <- realToFrac <$> c'getMouseY
+        forM_
+          [bunniesCount state .. (bunniesCount state + newBunnies - 1)]
+          ( \(!i) ->
+              do
+                -- Creating elements uses `poke`, just like writing
+                let bunny = advancePtr (bunnies state) i
+                xSpeed <- (/ 60) . fromIntegral <$> c'getRandomValue (-250) 250
+                ySpeed <- (/ 60) . fromIntegral <$> c'getRandomValue (-250) 250
+                r <- fromIntegral <$> c'getRandomValue 50 240
+                g <- fromIntegral <$> c'getRandomValue 80 240
+                b <- fromIntegral <$> c'getRandomValue 100 240
+                ptr <- malloc
+                poke ptr (Color r g b 255)
+
+                poke (p'px bunny) mx
+                poke (p'py bunny) my
+                poke (p'sx bunny) xSpeed
+                poke (p'sy bunny) ySpeed
+                poke (p'color bunny) ptr
+          )
+        return $ state {bunniesCount = bunniesCount state + newBunnies}
+      else return state
+
+shouldClose :: AppState -> IO Bool
+shouldClose _ = windowShouldClose
+
+teardown :: AppState -> IO ()
+teardown state = do
+  -- Unload and free functions have to be manually called
+  c'unloadTexture (texBunny state)
+  free (texBunny state)
+  forM_ [0 .. (bunniesCount state - 1)] (\(!i) -> let bunny = advancePtr (bunnies state) i in free =<< peek (p'color bunny))
+  free (bunnies state)
+
+$(raylibApplication 'startup 'mainLoop 'shouldClose 'teardown)

examples/custom-font-text/src/Main.hs

@@ -15,7 +15,7 @@ import Raylib.Util (inGHCi, whileWindowOpen_, withWindow, drawing)
 import Raylib.Util.Colors (black, rayWhite)
 
 mainFontPath :: String
-mainFontPath = (if not inGHCi then "../../../../../../../../../" else "./") ++ "examples/custom-font-text/assets/Lato-Regular.ttf"
+mainFontPath = (if not inGHCi then "../../../../../../../../../../" else "./") ++ "examples/custom-font-text/assets/Lato-Regular.ttf"
 
 main :: IO ()
 main = do

examples/postprocessing-effects/src/Main.hs

@@ -13,7 +13,7 @@ import Raylib.Util (inGHCi, mode3D, textureMode, whileWindowOpen_, withWindow, d
 import Raylib.Util.Colors (black, blue, darkBlue, darkGreen, green, maroon, orange, red, white)
 
 assetsPath :: String
-assetsPath = (if not inGHCi then "../../../../../../../../../" else "./") ++ "examples/postprocessing-effects/assets/"
+assetsPath = (if not inGHCi then "../../../../../../../../../../" else "./") ++ "examples/postprocessing-effects/assets/"
 
 main :: IO ()
 main = do

h-raylib.cabal

@@ -104,7 +104,7 @@ common example-options
       , base
       , h-raylib
 
-    other-extensions: TemplateHaskell
+    other-extensions: TemplateHaskell, BangPatterns
 
     if flag(platform-web)
       ghc-options:
@@ -139,6 +139,11 @@ executable basic-images
   hs-source-dirs: examples/basic-images/src
   main-is:        Main.hs
 
+executable bunnymark
+  import:         example-options
+  hs-source-dirs: examples/bunnymark/src
+  main-is:        Main.hs
+
 -- text
 executable custom-font-text
   import:         example-options