-
-
Save anonymous/ce7614ee2abf8110b78325063084da6e to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment