Gleam 0.1.0.0 → 0.1.0.1
raw patch · 10 files changed
+754/−2 lines, 10 filesdep ~basePVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: base
API changes (from Hackage documentation)
- Color: Aquamarine :: Color
- Color: Azure :: Color
- Color: Black :: Color
- Color: Blue :: Color
- Color: Chartreuse :: Color
- Color: Cyan :: Color
- Color: Green :: Color
- Color: Magenta :: Color
- Color: Orange :: Color
- Color: RGBA :: String -> Color
- Color: Red :: Color
- Color: Rose :: Color
- Color: Transparent :: Color
- Color: Violet :: Color
- Color: White :: Color
- Color: Yellow :: Color
- Color: convertColor :: Color -> String
- Color: data Color
- Color: instance GHC.Classes.Eq Color.Color
- Color: instance GHC.Show.Show Color.Color
- InputEvent: Char :: Char -> Key
- InputEvent: Down :: KeyState
- InputEvent: EventKey :: Key -> KeyState -> Point -> InputEvent
- InputEvent: EventMotion :: Point -> Point -> InputEvent
- InputEvent: KeyAlt :: SpecialKey
- InputEvent: KeyBackspace :: SpecialKey
- InputEvent: KeyCaps :: SpecialKey
- InputEvent: KeyCtrl :: SpecialKey
- InputEvent: KeyDown :: SpecialKey
- InputEvent: KeyEnter :: SpecialKey
- InputEvent: KeyEsc :: SpecialKey
- InputEvent: KeyLeft :: SpecialKey
- InputEvent: KeyRight :: SpecialKey
- InputEvent: KeyShift :: SpecialKey
- InputEvent: KeySpace :: SpecialKey
- InputEvent: KeyTab :: SpecialKey
- InputEvent: KeyUnknown :: SpecialKey
- InputEvent: KeyUp :: SpecialKey
- InputEvent: Mouse :: Key
- InputEvent: SpecialKey :: SpecialKey -> Key
- InputEvent: Up :: KeyState
- InputEvent: data InputEvent
- InputEvent: data Key
- InputEvent: data KeyState
- InputEvent: data SpecialKey
- InputEvent: instance GHC.Classes.Eq InputEvent.InputEvent
- InputEvent: instance GHC.Classes.Eq InputEvent.Key
- InputEvent: instance GHC.Classes.Eq InputEvent.KeyState
- InputEvent: instance GHC.Classes.Eq InputEvent.SpecialKey
- InputEvent: instance GHC.Classes.Ord InputEvent.Key
- InputEvent: instance GHC.Classes.Ord InputEvent.KeyState
- InputEvent: instance GHC.Classes.Ord InputEvent.SpecialKey
- InputEvent: instance GHC.Show.Show InputEvent.InputEvent
- InputEvent: instance GHC.Show.Show InputEvent.Key
- InputEvent: instance GHC.Show.Show InputEvent.KeyState
- InputEvent: instance GHC.Show.Show InputEvent.SpecialKey
- Picture: Arc :: Double -> Double -> Double -> Picture
- Picture: Blank :: Picture
- Picture: Circle :: Double -> Picture
- Picture: File :: String -> Location
- Picture: FillColor :: Color -> Picture -> Picture
- Picture: Image :: Location -> Double -> Double -> Picture
- Picture: Line :: Path -> Picture
- Picture: Pictures :: [Picture] -> Picture
- Picture: Polygon :: Path -> Picture
- Picture: Rectangle :: Double -> Double -> Picture
- Picture: Rotate :: Double -> Picture -> Picture
- Picture: Scale :: Double -> Double -> Picture -> Picture
- Picture: Stroke :: Color -> Double -> Picture -> Picture
- Picture: Text :: String -> Font -> FontSize -> Picture
- Picture: Translate :: Double -> Double -> Picture -> Picture
- Picture: Url :: String -> Location
- Picture: data Location
- Picture: data Picture
- Picture: instance Data.Semigroup.Semigroup Picture.Picture
- Picture: instance GHC.Base.Monoid Picture.Picture
- Picture: instance GHC.Classes.Eq Picture.Location
- Picture: instance GHC.Classes.Eq Picture.Picture
- Picture: instance GHC.Show.Show Picture.Location
- Picture: instance GHC.Show.Show Picture.Picture
- Picture: lineLoop :: Path -> Picture
- Picture: rectanglePath :: Double -> Double -> Path
- Picture: rectangleSolid :: Double -> Double -> Picture
- Picture: rectangleWire :: Double -> Double -> Picture
- Picture: sectorWire :: Double -> Double -> Double -> Picture
- Picture: type Path = [Point]
- Picture: type Point = (Double, Double)
- Picture: type Vector = Point
- Settings: GleamConfig :: Int -> Int -> GleamConfig
- Settings: Simulation :: GleamConfig -> model -> (model -> Picture) -> (model -> model) -> (InputEvent -> model -> model) -> String -> Simulation
- Settings: [height] :: GleamConfig -> Int
- Settings: [simConfig] :: Simulation -> GleamConfig
- Settings: [simDraw] :: Simulation -> (model -> Picture)
- Settings: [simHandler] :: Simulation -> (InputEvent -> model -> model)
- Settings: [simInitialModel] :: Simulation -> model
- Settings: [simTitle] :: Simulation -> String
- Settings: [simUpdate] :: Simulation -> (model -> model)
- Settings: [width] :: GleamConfig -> Int
- Settings: data GleamConfig
- Settings: data Simulation
- Settings: defaultGleamConfig :: GleamConfig
- Text: Arial :: Font
- Text: CourierNew :: Font
- Text: Font :: String -> Font
- Text: SansSerif :: Font
- Text: Serif :: Font
- Text: Size :: Int -> FontSize
- Text: TimesNewRoman :: Font
- Text: Verdana :: Font
- Text: data Font
- Text: data FontSize
- Text: getCombinedFont :: Font -> FontSize -> String
- Text: instance GHC.Classes.Eq Text.Font
- Text: instance GHC.Classes.Eq Text.FontSize
- Text: instance GHC.Show.Show Text.Font
- Text: instance GHC.Show.Show Text.FontSize
+ Gleam: Arc :: Double -> Double -> Double -> Picture
+ Gleam: Blank :: Picture
+ Gleam: Char :: Char -> Key
+ Gleam: Circle :: Double -> Picture
+ Gleam: Color :: Color -> Picture -> Picture
+ Gleam: Down :: KeyState
+ Gleam: EventKey :: Key -> KeyState -> InputEvent
+ Gleam: EventMotion :: Point -> Point -> InputEvent
+ Gleam: File :: String -> Source
+ Gleam: Image :: Source -> Double -> Double -> Picture
+ Gleam: KeyAlt :: SpecialKey
+ Gleam: KeyBackspace :: SpecialKey
+ Gleam: KeyCaps :: SpecialKey
+ Gleam: KeyCtrl :: SpecialKey
+ Gleam: KeyDown :: SpecialKey
+ Gleam: KeyEnter :: SpecialKey
+ Gleam: KeyEsc :: SpecialKey
+ Gleam: KeyLeft :: SpecialKey
+ Gleam: KeyRight :: SpecialKey
+ Gleam: KeyShift :: SpecialKey
+ Gleam: KeySpace :: SpecialKey
+ Gleam: KeyTab :: SpecialKey
+ Gleam: KeyUnknown :: SpecialKey
+ Gleam: KeyUp :: SpecialKey
+ Gleam: Line :: Path -> Picture
+ Gleam: Mouse :: Point -> Key
+ Gleam: Pictures :: [Picture] -> Picture
+ Gleam: Polygon :: Path -> Picture
+ Gleam: Rectangle :: Double -> Double -> Picture
+ Gleam: Scale :: Double -> Double -> Picture -> Picture
+ Gleam: SpecialKey :: SpecialKey -> Key
+ Gleam: Stroke :: Color -> Double -> Picture -> Picture
+ Gleam: Text :: String -> Font -> FontSize -> Picture
+ Gleam: Translate :: Double -> Double -> Picture -> Picture
+ Gleam: Up :: KeyState
+ Gleam: Url :: String -> Source
+ Gleam: convertColor :: Color -> String
+ Gleam: data InputEvent
+ Gleam: data Key
+ Gleam: data KeyState
+ Gleam: data Picture
+ Gleam: data Source
+ Gleam: data SpecialKey
+ Gleam: defaultGleamConfig :: GleamConfig
+ Gleam: lineLoop :: Path -> Picture
+ Gleam: rectanglePath :: Double -> Double -> Path
+ Gleam: rectangleSolid :: Double -> Double -> Picture
+ Gleam: rectangleWire :: Double -> Double -> Picture
+ Gleam: sectorWire :: Double -> Double -> Double -> Picture
+ Gleam: type Path = [Point]
+ Gleam: type Point = (Double, Double)
+ Gleam: type Vector = Point
Files
- Gleam.cabal +12/−2
- src/Animate.hs +53/−0
- src/Color.hs +45/−0
- src/Handler.hs +177/−0
- src/InputEvent.hs +42/−0
- src/Picture.hs +146/−0
- src/Render.hs +183/−0
- src/Settings.hs +37/−0
- src/Text.hs +46/−0
- src/Utility.hs +13/−0
Gleam.cabal view
@@ -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
+ src/Animate.hs view
@@ -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
+ src/Color.hs view
@@ -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
+ src/Handler.hs view
@@ -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
+ src/InputEvent.hs view
@@ -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)
+ src/Picture.hs view
@@ -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)
+ src/Render.hs view
@@ -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"
+ src/Settings.hs view
@@ -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
+ src/Text.hs view
@@ -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)]++++
+ src/Utility.hs view
@@ -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