diff --git a/Gleam.cabal b/Gleam.cabal --- a/Gleam.cabal +++ b/Gleam.cabal @@ -1,5 +1,5 @@ name: Gleam -version: 0.1.0.0 +version: 0.1.0.1 cabal-version: >=1.10 license: BSD3 license-file: LICENSE @@ -21,8 +21,18 @@ library exposed-modules: Gleam + other-modules: Animate, + Color, + Handler, + InputEvent, + Picture, + Render, + Settings, + Text, + Utility + -- Other library packages from which modules are imported. - build-depends: base >=4.9 && <4.10 + build-depends: base >=4.9 && <= 5 ,mtl >= 2.2.2 && < 2.3 ,split >= 0.2.3 && < 0.3 ,threepenny-gui >= 0.8.3 && < 0.9 diff --git a/src/Animate.hs b/src/Animate.hs new file mode 100644 --- /dev/null +++ b/src/Animate.hs @@ -0,0 +1,53 @@ +{-# OPTIONS_HADDOCK hide #-} + +module Animate + ( animateMultiple + , animate + ) +where + +import Picture +import qualified Graphics.UI.Threepenny as UI +import Graphics.UI.Threepenny.Core +import Graphics.UI.Threepenny.Timer +import Data.IORef +import Render + +-- | Animates the simulation for multiple canvases. +animateMultiple + :: IORef model -- ^ Current state of the simulation. + -> IORef Bool -- ^ Whether the current simulation is paused. + -> (model -> model) -- ^ Function to update the state of the simulation. + -> (model -> Picture) -- ^ Function to generate a picture from a model. + -> UI.Element -- ^ The canvas element. + -> UI Timer +animateMultiple currentState currentPause update draw canvas = do + t <- timer + on (\canvas -> (tick t)) canvas $ \_ -> do + pause <- liftIO $ readIORef currentPause + case (pause) of + False -> do + current <- liftIO $ readIORef currentState + let updatedState = update current + liftIO $ writeIORef currentState updatedState + renderPicture (draw updatedState) canvas + True -> do + current <- liftIO $ readIORef currentState + renderPicture (draw current) canvas + return t # set interval 16 # set running True + +-- | Animates the simulation for a single canvas. +animate + :: IORef model -- ^ Current state of the simulation. + -> (model -> model) -- ^ Function to update the state of the simulation. + -> (model -> Picture) -- ^ Function to generate a picture from a model. + -> UI.Element -- ^ The canvas element. + -> UI Timer +animate currentState update draw canvas = do + t <- timer + on (\canvas -> (tick t)) canvas $ \_ -> do + current <- liftIO $ readIORef currentState + let updatedState = update current + liftIO $ writeIORef currentState updatedState + renderPicture (draw updatedState) canvas + return t # set interval 16 # set running True diff --git a/src/Color.hs b/src/Color.hs new file mode 100644 --- /dev/null +++ b/src/Color.hs @@ -0,0 +1,45 @@ +module Color + ( Color(..) + , convertColor + ) +where + +data Color + = White + | Black + | Transparent + | Red + | Green + | Blue + | Yellow + | Cyan + | Magenta + | Rose + | Violet + | Azure + | Aquamarine + | Chartreuse + | Orange + -- | A hex color string. + | RGBA String + deriving (Show, Eq) + + +-- | Converts a color to a html color string. +convertColor :: Color -> String +convertColor color = case (color) of + White -> "white" + Black -> "black" + Transparent -> "#00000000" + Red -> "red" + Green -> "green" + Blue -> "blue" + Yellow -> "yellow" + Cyan -> "cyan" + Magenta -> "magenta" + Rose -> "rose" + Violet -> "violet" + Azure -> "azure" + Chartreuse -> "chartreuse" + Orange -> "orange" + (RGBA string) -> string diff --git a/src/Handler.hs b/src/Handler.hs new file mode 100644 --- /dev/null +++ b/src/Handler.hs @@ -0,0 +1,177 @@ +{-# OPTIONS_HADDOCK hide #-} + +module Handler + ( handleEventsMultiple + , handleEvents + ) +where + +import qualified Graphics.UI.Threepenny as UI +import Graphics.UI.Threepenny.Core +import Data.Char +import Data.IORef +import InputEvent +import Picture +import Settings + +-- | Handles events for multiple canvases. +handleEventsMultiple + :: GleamConfig -- ^ Canvas size. + -> IORef model -- ^ Current state of the simulation. + -> IORef (Double, Double) -- ^ Current mouse position. + -> IORef Bool -- ^ Whether the current simulation is paused. + -> (InputEvent -> model -> model) -- ^ Function to handle input events. + -> UI.Element -- ^ The canvas element. + -> UI () +handleEventsMultiple gleamconfig currentState currentMousePos currentPause handler canvas + = do + on UI.keydown canvas $ \c -> do + pause <- liftIO $ readIORef currentPause + case (pause) of + False -> do + current <- liftIO $ readIORef currentState + let updatedState = handler (convertKeyCode c Down) current + liftIO $ writeIORef currentState updatedState + True -> return () + + on UI.keyup canvas $ \c -> do + pause <- liftIO $ readIORef currentPause + case (pause) of + False -> do + current <- liftIO $ readIORef currentState + let updatedState = handler (convertKeyCode c Up) current + liftIO $ writeIORef currentState updatedState + True -> return () + + on UI.mouseup canvas $ \pos -> do + pause <- liftIO $ readIORef currentPause + case (pause) of + False -> do + current <- liftIO $ readIORef currentState + let updatedState = handler + (convertMouse (convertMousePos gleamconfig pos) Up) + current + liftIO $ writeIORef currentState updatedState + True -> return () + + on UI.mousedown canvas $ \pos -> do + pause <- liftIO $ readIORef currentPause + case (pause) of + False -> do + current <- liftIO $ readIORef currentState + let updatedState = handler + (convertMouse (convertMousePos gleamconfig pos) Down) + current + liftIO $ writeIORef currentState updatedState + True -> return () + + on UI.mousemove canvas $ \pos -> do + pause <- liftIO $ readIORef currentPause + case (pause) of + False -> do + current <- liftIO $ readIORef currentState + mousePos <- liftIO $ readIORef currentMousePos + let updatedState = handler + (convertMouseMove mousePos (convertMousePos gleamconfig pos)) + current + liftIO $ writeIORef currentState updatedState + liftIO $ writeIORef currentMousePos $ convertMousePos gleamconfig pos + True -> return () + + return () + +-- | Handles events for a single canvas. +handleEvents + :: GleamConfig -- ^ Canvas size. + -> IORef model -- ^ Current state of the simulation. + -> IORef (Double, Double) -- ^ Current mouse position. + -> (InputEvent -> model -> model) -- ^ Function to handle input events. + -> UI.Element -- ^ The canvas element. + -> UI () +handleEvents gleamconfig currentState currentMousePos handler canvas = do + + on UI.keydown canvas $ \c -> do + current <- liftIO $ readIORef currentState + let updatedState = handler (convertKeyCode c Down) current + liftIO $ writeIORef currentState updatedState + + on UI.keyup canvas $ \c -> do + current <- liftIO $ readIORef currentState + let updatedState = handler (convertKeyCode c Up) current + liftIO $ writeIORef currentState updatedState + + on UI.mouseup canvas $ \pos -> do + current <- liftIO $ readIORef currentState + let updatedState = + handler (convertMouse (convertMousePos gleamconfig pos) Up) current + liftIO $ writeIORef currentState updatedState + + on UI.mousedown canvas $ \pos -> do + current <- liftIO $ readIORef currentState + let updatedState = + handler (convertMouse (convertMousePos gleamconfig pos) Down) current + liftIO $ writeIORef currentState updatedState + + on UI.mousemove canvas $ \pos -> do + current <- liftIO $ readIORef currentState + mousePos <- liftIO $ readIORef currentMousePos + let updatedState = handler + (convertMouseMove mousePos (convertMousePos gleamconfig pos)) + current + liftIO $ writeIORef currentState updatedState + liftIO $ writeIORef currentMousePos $ convertMousePos gleamconfig pos + + return () + +convertMousePos :: GleamConfig -> (Int, Int) -> Point +convertMousePos gleamconfig (x, y) = + ( ((fromIntegral x) - (fromIntegral (width gleamconfig) / 2)) + , ((fromIntegral y) - (fromIntegral (height gleamconfig) / 2)) + ) + +convertMouse :: Point -> KeyState -> InputEvent +convertMouse pos state = (EventKey (Mouse pos) state) + +convertMouseMove :: Point -> Point -> InputEvent +convertMouseMove (x, y) (nx, ny) = (EventMotion ((x - nx), (y - ny)) (nx, ny)) + +convertKeyCode :: UI.KeyCode -> KeyState -> InputEvent +convertKeyCode code state + | charCodes code = (EventKey (Char (keyCodeToChar code)) state) + | code == 8 = (EventKey (SpecialKey KeyBackspace) state) + | code == 9 = (EventKey (SpecialKey KeyTab) state) + | code == 13 = (EventKey (SpecialKey KeyEnter) state) + | code == 16 = (EventKey (SpecialKey KeyShift) state) + | code == 17 = (EventKey (SpecialKey KeyCtrl) state) + | code == 18 = (EventKey (SpecialKey KeyAlt) state) + | code == 20 = (EventKey (SpecialKey KeyCaps) state) + | code == 27 = (EventKey (SpecialKey KeyEsc) state) + | code == 37 = (EventKey (SpecialKey KeyLeft) state) + | code == 38 = (EventKey (SpecialKey KeyUp) state) + | code == 39 = (EventKey (SpecialKey KeyRight) state) + | code == 40 = (EventKey (SpecialKey KeyDown) state) + | otherwise = (EventKey (SpecialKey KeyUnknown) state) + +keyCodeToChar :: UI.KeyCode -> Char +keyCodeToChar code | (code >= 65 && code <= 90) = chr $ (ord 'z') - (90 - code) + | (code >= 48 && code <= 57) = chr $ (ord '9') - (57 - code) + | (code == 186) = ';' + | (code == 187) = '=' + | (code == 188) = ',' + | (code == 189) = '-' + | (code == 190) = '.' + | (code == 191) = '/' + | (code == 192) = '`' + | (code == 219) = '[' + | (code == 220) = '\\' + | (code == 221) = ']' + | (code == 222) = '\'' + | otherwise = '?' + +charCodes :: UI.KeyCode -> Bool +charCodes code | (code >= 65 && code <= 90) = True + | (code >= 48 && code <= 61) = True + | (code >= 48 && code <= 57) = True + | (code >= 186 && code <= 192) = True + | (code >= 219 && code <= 222) = True + | otherwise = False diff --git a/src/InputEvent.hs b/src/InputEvent.hs new file mode 100644 --- /dev/null +++ b/src/InputEvent.hs @@ -0,0 +1,42 @@ +module InputEvent + ( InputEvent(..) + , Key(..) + , KeyState(..) + , SpecialKey(..) + ) +where + +import Picture + +data InputEvent + = EventKey Key KeyState + | EventMotion Point Point + deriving (Eq, Show) + +data Key + = Char Char + | SpecialKey SpecialKey + | Mouse Point + deriving (Show, Eq, Ord) + +data KeyState + = Down + | Up + deriving (Show, Eq, Ord) + +data SpecialKey + = KeyUnknown + | KeySpace + | KeyEsc + | KeyUp + | KeyDown + | KeyLeft + | KeyRight + | KeyTab + | KeyEnter + | KeyBackspace + | KeyShift + | KeyCtrl + | KeyAlt + | KeyCaps + deriving (Show, Eq, Ord) diff --git a/src/Picture.hs b/src/Picture.hs new file mode 100644 --- /dev/null +++ b/src/Picture.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Picture + ( Picture(..) + , Point + , Vector + , Path + , Source(..) + -- * Compound shapes + , lineLoop + , sectorWire + , rectanglePath + , rectangleWire + , rectangleSolid + ) +where + +import Data.Monoid +import Data.Semigroup +import Data.Foldable +import Color +import Text + +-- | A point on the x-y plane. +type Point = (Double, Double) + +-- | A vector can be treated as a point, and vis-versa. +type Vector = Point + +-- | A path through the x-y plane. +type Path = [Point] + +-- | An image location +data Source = + -- | Path to an image inside ./images. + File String + -- | An image url. + | Url String + deriving (Show, Eq) + +-- | A 2D picture +data Picture + -- | A blank picture, with nothing in it. + = Blank + -- | A line along an arbitrary path. + | Line Path + -- | A polygon filled with a solid color. + | Polygon Path + -- | A circle with the given radius. + | Circle Double + -- | A circular arc drawn counter-clockwise between two angles + -- (in degrees) at the given radius. + | Arc Double Double Double + -- | A rectangle drawn with given width and height. + | Rectangle Double Double + -- | Image to draw from a certain with given width and height. + | Image Source Double Double + -- | Some text to draw with a vector font. + | Text String Font FontSize + -- | A picture drawn with this color. + | Color Color Picture + -- | A picture drawn with this stroke, given a color and size. + | Stroke Color Double Picture + -- | A picture translated by the given x and y coordinates. + | Translate Double Double Picture + -- | A picture scaled by the given x and y factors. + | Scale Double Double Picture + -- | A picture consisting of several others. + | Pictures [Picture] + deriving (Show, Eq) + + +-- Instances ------------------------------------------------------------------ +instance Monoid Picture where + mempty = Blank + mappend a b = Pictures [a, b] + mconcat = Pictures + +instance Semigroup Picture where + a <> b = Pictures [a, b] + sconcat = Pictures . toList + stimes = stimesIdempotent + +-- Other Shapes --------------------------------------------------------------- +-- | A closed loop along a path. +lineLoop :: Path -> Picture +lineLoop [] = Line [] +lineLoop (x : xs) = Line ((x : xs) ++ [x]) + + +-- | A wireframe sector of a circle. +-- An arc is draw counter-clockwise from the first to the second angle at +-- the given radius. +sectorWire :: Double -> Double -> Double -> Picture +sectorWire a1 a2 r_ = + let r = abs r_ + in Pictures + [ Arc a1 a2 r + , Line [(0, 0), (r * cos (degToRad a1), r * sin (degToRad a1))] + , Line [(0, 0), (r * cos (degToRad a2), r * sin (degToRad a2))] + ] + + +-- Rectangles ----------------------------------------------------------------- + +-- | A path representing a rectangle centered about the origin +rectanglePath + :: Double -- ^ width of rectangle + -> Double -- ^ height of rectangle + -> Path +rectanglePath sizeX sizeY = + let sx = sizeX / 2 + sy = sizeY / 2 + in [(-sx, -sy), (-sx, sy), (sx, sy), (sx, -sy)] + + +-- | A wireframe rectangle centered about the origin. +rectangleWire :: Double -> Double -> Picture +rectangleWire sizeX sizeY = lineLoop $ rectanglePath sizeX sizeY + + +-- | A solid rectangle centered about the origin. +rectangleSolid + :: Double -- ^ width of rectangle + -> Double -- ^ height of rectangle + -> Picture +rectangleSolid sizeX sizeY = Polygon $ rectanglePath sizeX sizeY + +-- | Convert degrees to radians +degToRad :: Double -> Double +degToRad d = d * pi / 180 +{-# INLINE degToRad #-} + + +-- | Convert radians to degrees +radToDeg :: Double -> Double +radToDeg r = r * 180 / pi +{-# INLINE radToDeg #-} + + +-- | Normalize an angle to be between 0 and 2*pi radians +normalizeAngle :: Double -> Double +normalizeAngle f = f - 2 * pi * floor' (f / (2 * pi)) + where + floor' :: Double -> Double + floor' x = fromIntegral (floor x :: Int) diff --git a/src/Render.hs b/src/Render.hs new file mode 100644 --- /dev/null +++ b/src/Render.hs @@ -0,0 +1,183 @@ +{-# OPTIONS_HADDOCK hide #-} + +module Render + ( renderPicture + ) +where + +import qualified Graphics.UI.Threepenny as UI +import Graphics.UI.Threepenny.Core +import Foreign.JavaScript +import Control.Monad +import Data.List +import Data.List.Split +import Picture +import Color +import Text + +renderPicture :: Picture -> Element -> UI () +renderPicture picture canvas = do + canvas # saveDrawState + canvas # translateMiddle + canvas # drawPicture picture + canvas # restoreDrawState + return () + +drawPicture :: Picture -> Element -> UI () + +drawPicture (Blank) canvas = do + return () + +drawPicture (Circle radius) canvas = do + canvas # UI.beginPath + canvas # UI.arc (0, 0) (radius) (-pi) pi + canvas # UI.closePath + canvas # UI.fill + return () + +drawPicture (Arc startAngle endAngle radius) canvas = do + canvas # UI.beginPath + canvas # UI.moveTo (0, 0) + canvas + # UI.arc (0, 0) (radius) (startAngle * (pi / 180)) (endAngle * (pi / 180)) + canvas # UI.closePath + canvas # UI.fill + return () + +drawPicture (Rectangle width height) canvas = do + canvas # UI.fillRect (0 - (width / 2), 0 - (height / 2)) width height + return () + +drawPicture (Stroke color size picture) canvas = do + canvas # saveDrawState + canvas # set' UI.strokeStyle (convertColor color) + canvas # set' UI.lineWidth size + canvas # drawPicture picture + canvas # restoreDrawState + return () + +drawPicture (Text string font fontSize) canvas = do + canvas # set' UI.textAlign (UI.Center) + canvas # set' UI.textFont (getCombinedFont font fontSize) + canvas # UI.fillText string (0, 0) + return () + +drawPicture (Image (Url url) width height) canvas = do + img <- UI.img # set UI.src url + canvas # drawImage img (0 - (width / 2), 0 - (height / 2)) width height + return () + +drawPicture (Image (File file) width height) canvas = do + img <- UI.img # set + UI.src + ("http://127.0.0.1:8023/static/" ++ file) + canvas # drawImage img (0 - (width / 2), 0 - (height / 2)) width height + return () + +drawPicture (Scale x y picture) canvas = do + canvas # saveDrawState + canvas # scalePicture (x, y) + canvas # drawPicture picture + canvas # restoreDrawState + return () + +drawPicture (Translate x y picture) canvas = do + canvas # saveDrawState + canvas # translatePicture (x, y) + canvas # drawPicture picture + canvas # restoreDrawState + return () + +drawPicture (Pictures (picture : pictures)) canvas = do + canvas # drawPicture picture + canvas # drawPicture (Pictures pictures) + return () + +drawPicture (Line (_ : [])) _ = do + return () + +drawPicture (Line ([])) _ = do + return () + +drawPicture (Line ((x, y) : rest)) canvas = do + canvas # UI.beginPath + canvas # UI.moveTo (x, y) + forM_ rest (\(x', y') -> canvas # UI.lineTo (x', y')) + canvas # UI.stroke + return () + +drawPicture (Polygon (_ : [])) _ = do + return () + +drawPicture (Polygon ([])) _ = do + return () + +drawPicture (Polygon ((x, y) : rest)) canvas = do + canvas # UI.beginPath + canvas # UI.moveTo (x, y) + forM_ rest (\(x', y') -> canvas # UI.lineTo (x', y')) + canvas # UI.closePath + canvas # UI.fill + return () + +drawPicture (Color color picture) canvas = do + canvas # saveDrawState + canvas # set' UI.fillStyle (UI.htmlColor $ convertColor color) + canvas # drawPicture picture + canvas # restoreDrawState + return () + +drawPicture _ _ = do + return () + +scalePicture :: Point -> UI.Canvas -> UI () +scalePicture (sx, sy) canvas = + UI.runFunction $ ffi "%1.getContext('2d').scale(%2, %3)" canvas sx sy + +saveDrawState :: UI.Canvas -> UI () +saveDrawState canvas = UI.runFunction $ ffi "%1.getContext('2d').save()" canvas + +restoreDrawState :: UI.Canvas -> UI () +restoreDrawState canvas = + UI.runFunction $ ffi "%1.getContext('2d').restore()" canvas + +resetTransform :: UI.Canvas -> UI () +resetTransform canvas = UI.runFunction + $ ffi "%1.getContext('2d').setTransform(1, 0, 0, 1, 0, 0)" canvas + +translatePicture :: Point -> UI.Canvas -> UI () +translatePicture (tx, ty) canvas = + UI.runFunction $ ffi "%1.getContext('2d').translate(%2, %3)" canvas tx ty + +translateMiddle :: UI.Canvas -> UI () +translateMiddle canvas = UI.runFunction + $ ffi "%1.getContext('2d').translate(%1.width/2, %1.height/2)" canvas + +drawImage :: UI.Element -> Vector -> Double -> Double -> UI.Canvas -> UI () +drawImage image (x, y) width height canvas = UI.runFunction $ ffi + "%1.getContext('2d').drawImage(%2,%3,%4,%5,%6)" + canvas + image + x + y + width + height + +getMimeType :: String -> String +getMimeType fileName = case (last (splitOn "." fileName)) of + "apng" -> "image/apng" + "bmp" -> "image/bmp" + "gif" -> "image/gif" + "ico" -> "image/x-icon" + "cur" -> "image/x-icon" + "jpg" -> "image/jpeg" + "jpeg" -> "image/jpeg" + "jfif" -> "image/jpeg" + "pjpeg" -> "image/jpeg" + "pjp" -> "image/jpeg" + "png" -> "image/png" + "svg" -> "image/svg+xml" + "tif" -> "image/tiff" + "tiff" -> "image/tiff" + "webp" -> "image/webp" + _ -> "image" diff --git a/src/Settings.hs b/src/Settings.hs new file mode 100644 --- /dev/null +++ b/src/Settings.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE ExistentialQuantification #-} + +module Settings + ( Simulation(..) + , GleamConfig(..) + , defaultGleamConfig + ) +where + +import Picture +import InputEvent + +data Simulation = forall model . Simulation { + -- | Config for the canvas. + simConfig :: GleamConfig, + -- | Initial model for a simulation. + simInitialModel :: model, + -- | Function to generate a picture from a model. + simDraw :: (model -> Picture), + -- | Function to update the state of the simulation. + simUpdate :: (model -> model), + -- | Function to handle input events. + simHandler :: (InputEvent -> model -> model), + -- | Title of the simulation. + simTitle :: String +} + +data GleamConfig = GleamConfig { + -- | Width of the canvas. + width :: Int, + -- | Height of the canvas. + height :: Int +} + +-- | The default config for Gleam +defaultGleamConfig :: GleamConfig +defaultGleamConfig = GleamConfig 400 400 diff --git a/src/Text.hs b/src/Text.hs new file mode 100644 --- /dev/null +++ b/src/Text.hs @@ -0,0 +1,46 @@ +module Text + ( Font(..) + , FontSize(..) + , getCombinedFont + ) +where + +import Data.List + +-- | A font. +data Font + = Arial + | Verdana + | TimesNewRoman + | CourierNew + | Serif + | SansSerif + -- | A html font family + | Font String deriving (Show, Eq) + +-- | A font size, given in points. +data FontSize = Size Int deriving (Show, Eq) + +-- | Converts a `Font` to a html font family. +convertFont :: Font -> String +convertFont font = case (font) of + Arial -> "Arial" + Verdana -> "Verdana" + TimesNewRoman -> "Times New Roman" + CourierNew -> "Courier New" + Serif -> "serif" + SansSerif -> "sans-serif" + Font family -> family + +-- | Converts a `FontSize` to a html font size. +convertFontSize :: FontSize -> String +convertFontSize (Size size) = (show size) ++ "pt" + +-- | Combines a `Font` and `FontSize` to return a html string representing them. +getCombinedFont :: Font -> FontSize -> String +getCombinedFont font fontSize = + intercalate " " [(convertFontSize fontSize), (convertFont font)] + + + + diff --git a/src/Utility.hs b/src/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Utility.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_HADDOCK hide #-} + +module Utility + ( setAttribute + ) +where + +import qualified Graphics.UI.Threepenny as UI +import Graphics.UI.Threepenny.Core + +setAttribute :: String -> String -> UI.Canvas -> UI () +setAttribute key value canvas = + UI.runFunction $ ffi "%1.setAttribute(%2, %3)" canvas key value