Main.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TemplateHaskell #-}

-- Writing performant h-raylib code requires the use of pointers and other
-- un-Haskelly functionality. Unfortunately, this cannot be avoided.

module Main where

import Paths_h_raylib (getDataFileName)
import Control.Monad (forM_, when)
import Foreign
  ( ForeignPtr,
    Ptr,
    Storable (alignment, peek, poke, sizeOf),
    advancePtr,
    free,
    mallocForeignPtrArray,
    peek,
    plusPtr,
    poke,
    withForeignPtr,
  )
import Foreign.C (CFloat, withCString)
import Raylib.Core
  ( beginDrawing,
    c'getMouseX,
    c'getMouseY,
    c'getRandomValue,
    clearBackground,
    endDrawing,
    getFrameTime,
    getScreenHeight,
    getScreenWidth,
    initWindow,
    isMouseButtonDown,
    setTargetFPS,
    windowShouldClose, closeWindow,
  )
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, p'texture'height, p'texture'width)
import Raylib.Util (raylibApplication)
import Raylib.Util.Colors (black, green, maroon, rayWhite)

texPath :: String
texPath = "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 :: !Color
  }
  deriving (Show, Eq)

cfs :: Int
cfs = sizeOf (0 :: CFloat)

cls :: Int
cls = sizeOf (undefined :: Color)

instance Storable Bunny where
  alignment _ = min cfs cls
  sizeOf _ = 4 * cfs + cls

  -- 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 <$> peek (p'px _p)
    _py <- realToFrac <$> peek (p'py _p)
    _sx <- realToFrac <$> peek (p'sx _p)
    _sy <- realToFrac <$> peek (p'sy _p)
    _color <- peek (p'color _p)
    return $ Bunny {px = _px, py = _py, sx = _sx, sy = _sy, color = _color}
  poke _p (Bunny _px _py _sx _sy _color) = do
    poke (p'px _p) (realToFrac _px)
    poke (p'py _p) (realToFrac _py)
    poke (p'sx _p) (realToFrac _sx)
    poke (p'sy _p) (realToFrac _sy)
    poke (p'color _p) _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 Color
p'color = (`plusPtr` (4 * cfs))

data AppState = AppState
  { texBunny :: !(Ptr Texture),
    halfTexWidth :: !CFloat,
    halfTexHeight :: !CFloat,
    bunnies :: !(ForeignPtr Bunny), -- Store the bunnies as a pointer (C-style array) 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
  texPath' <- getDataFileName texPath
  texPtr <- withCString texPath' c'loadTexture
  -- Use `peek` when you need to access the underlying fields

  -- This could be rewritten as
  --   tex <- peek texPtr
  --   let tWidth = texture'width tex
  --   ...
  -- but the code below is faster as it doesn't have to load the entire structure into Haskell
  tWidth <- peek (p'texture'width texPtr)
  tHeight <- peek (p'texture'height texPtr)
  bunniesPtr <- mallocForeignPtrArray maxBunnies
  return
    ( AppState
        { texBunny = texPtr,
          bunnies = bunniesPtr,
          halfTexWidth = fromIntegral tWidth / 2,
          halfTexHeight = fromIntegral tHeight / 2,
          bunniesCount = 0
        }
    )

mainLoop :: AppState -> IO AppState
mainLoop state = do
  withForeignPtr (bunnies state) $ \bptr -> 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 bptr i
            -- Advancing the bunny pointer to access the fields
            _px <- peek $ p'px bunny
            _py <- peek $ p'py bunny
            c'drawTexture (texBunny state) (floor _px) (floor _py) (p'color bunny)
      )
    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 bptr i
            _px <- peek $ p'px bunny
            _py <- peek $ p'py bunny
            _sx <- peek $ p'sx bunny
            _sy <- peek $ p'sy 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 bptr 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

                  poke (p'px bunny) mx
                  poke (p'py bunny) my
                  poke (p'sx bunny) xSpeed
                  poke (p'sy bunny) ySpeed
                  poke (p'color bunny) (Color r g b 255)
            )
          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)
  closeWindow Nothing

$(raylibApplication 'startup 'mainLoop 'shouldClose 'teardown)