boxDemo.hs

import qualified Graphics.UI.WX as WX

import Codec.Picture.Types
import Codec.Picture
import qualified Graphics.Rasterific as RAST
import Graphics.Rasterific.Transformations as TRANS
import Graphics.Rasterific.Texture

import System.Posix.Unistd
import System.Random

import Control.Concurrent.MVar
import Control.Monad (when)


{-
This is a simplified verion of the gezira snow demo from:
https://github.com/damelang/gezira/blob/master/c/demos/snow-demo.c

Instead of animated snowflakes, this file shows only blue rectangles instead
for simlicity (i.e., the rectangles represent snowflakes).

The main date type is the box which has a delta y, rotation angle and scaling parameter. Every frame the list of boxes (stored in a mvar) is updated via the updateBox function. Subsequently the list of boxes is rasterized using the Rasterific library to generate a image (bmp image file) that is stored as a file in "/tmp". The generated image is then displayed/drawn in a graphic panel and the wxhaskell frame is updated/redrawn.

The question is if the temorary file stored in "/tmp" can be avoided and the image directly passed on wxhaskell and whether or not this improves the performance
-}

--
-- Constants
--
sleepTimeWrite    = 1500      -- milli seconds/10^-6
sleepTimeForTimer = 50        -- micro seconds/10^-3
numberOfBoxes = 30

{-
Performance problems start to arise when either the frame
height or width is increased. Or then the timer sleep time is small
and the number of boxes is increased.

-}

{-
This is runs fast/smooth:
sleepTimeWrite    = 1500
sleepTimeForTimer = 50
numberOfBoxes = 15
-}

{-
This is quite slow on my labtop:
sleepTimeWrite    = 1000
sleepTimeForTimer = 40
numberOfBoxes = 20
-}

{-
This short timer sleep time works only for 2 boxes:
sleepTimeWrite    = 1000
sleepTimeForTimer = 20
numberOfBoxes = 2
-}



frameWidth :: Int
frameWidth = 800

frameHeight :: Int
frameHeight = 600

--
--  Box (i.e. Rectangle)
--  Building block in Alan Kay STEPs project
--
data Point = Point
    { positionX :: Float
    , positionY :: Float
    } deriving (Show)

data Box = Box
    { position :: Point
    , dy :: Float
    , scale :: Float
    , angle :: Float
    , dangle :: Float
    } deriving (Show)

widthBox :: Float
widthBox = 60

heightBox :: Float
heightBox = 60

centerBox :: Box -> RAST.V2 Float
centerBox (Box (Point x1 y1) a b c d) =
  RAST.V2 newX newY
  where
    newX = x1 + (widthBox / 2)
    newY = y1 + (heightBox / 2)

updateBox :: Box -> Box
updateBox (Box (Point x1 y1) dy scale angle dangle) =
 (Box (Point x1 (y1 + deltaY)) dy scale (angle + dangle) dangle)
  where
    deltaY = if y1 < (fromIntegral frameHeight) then dy else (- ((fromIntegral frameHeight) -10))

--
--  remember(!) top left is (0,0); y-axsis increases down!
--

randomBox :: IO Box
randomBox = do
  x <- randomRIO (0.0 , fromIntegral frameWidth)
  y <- randomRIO (0.0 , fromIntegral frameHeight)
  dy <- randomRIO (0.5 , 2.2)
  scale <- randomRIO (0.2 , 1.7)
  angle <- randomRIO (0.0 , 4.0)
  dangle <- randomRIO (- 0.1 , 0.1)

  return (Box (Point x y) dy scale angle dangle)


boxesAtStart :: IO [Box]
boxesAtStart = mapM (\x -> randomBox) [1..numberOfBoxes]



main :: IO ()
main = WX.start main'


main' :: IO ()
main' = do
  f <- WX.frame [WX.text WX.:= "Test Program"]

  p <- WX.panel f []
  imagep <- WX.panel p []

  boxes <- boxesAtStart
  mvar <- newMVar boxes

  t <- WX.timer f [WX.interval WX.:= sleepTimeForTimer,
                   WX.on WX.command WX.:= updateImg mvar imagep
                  ]

  WX.set f [ WX.layout WX.:= WX.fill $ WX.container p $ WX.fill $ WX.widget imagep
           , WX.outerSize WX.:= WX.sz frameWidth frameHeight
           ]

  return ()



updateImg :: WX.Paint w => MVar [Box] -> w -> IO ()
updateImg mvar imagep = do
  var <- tryTakeMVar mvar
  case var of
    Nothing -> do
      putStrLn "!! MVar taken -- LOST frame"
      return ()

    Just boxesOldState -> do
      let boxes = map updateBox boxesOldState -- update state of boxes

      -- write rasterized image to a file in "/tmp" dir
      --
      writePng "/tmp/img.bmp" (createImg boxes)
      usleep sleepTimeWrite
      --
      loadImageFromFile imagep
      WX.repaint imagep  -- must send repaint event to make change visible!

      putMVar mvar boxes
      return ()


-- display/paint image from file to a panel that is displayed in wxHaskell
--
loadImageFromFile :: WX.Paint w => w -> IO ()
loadImageFromFile imagePanel = do
  image <- WX.bitmapCreateFromFile "/tmp/img.bmp"
  WX.set imagePanel [WX.on WX.paintRaw WX.:= \dc rect dirtyRecs -> WX.drawBitmap dc image WX.pointZero True [] ]



--
-- Create Rasterized image
--
white = PixelRGBA8 255 255 255 255
pink = PixelRGBA8 0xFF 0x53 0x73 255
blue = PixelRGBA8 22 60 163 179

-- Render single box with scaling/roation transformation applied
--
renderBox :: Box -> RAST.Drawing PixelRGBA8 ()
renderBox (Box (Point x y) dy boxScale angle dangle)  =
   RAST.withTexture (uniformTexture blue) . RAST.fill . transformation $
                     RAST.rectangle (RAST.V2 x y) widthBox heightBox
    where
      box = Box (Point x y) dy boxScale angle dangle
      --
      transformScale = RAST.transform (applyTransformation $ TRANS.scale boxScale boxScale)
      transformRotation = RAST.transform (applyTransformation $ rotateCenter angle (centerBox box))
      transformation = transformScale . transformRotation

renderBoxes :: [Box] -> RAST.Drawing PixelRGBA8 ()
renderBoxes (box : []) = renderBox box
renderBoxes (box : bs) = renderBox box >> renderBoxes bs

-- render the drawing
--
createImg :: [Box] -> Codec.Picture.Types.Image PixelRGBA8
createImg boxes = RAST.renderDrawing frameWidth frameHeight white $ renderBoxes boxes