diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,8 @@ +2023-04-08 Ivan Perez + * Version bump (0.2.1) (#16). + * Conformance with style guide (#14). + * Bumps contraints on base, Yampa (#15). + 2019-02-24 Ivan Perez * Bumps version number (0.2). diff --git a/examples/Example.hs b/examples/Example.hs --- a/examples/Example.hs +++ b/examples/Example.hs @@ -1,18 +1,104 @@ -{-# LANGUAGE Arrows #-} -import Control.Arrow ( (^<<), returnA ) -import FRP.Yampa ( SF, time ) +{-# LANGUAGE Arrows #-} +{-# LANGUAGE ParallelListComp #-} +import Control.Arrow ( returnA, (&&&), (>>^), (^<<) ) +import FRP.Yampa ( SF, Event, after, constant, switch, time ) import GHC.Float ( double2Float ) -import Graphics.Gloss ( Picture (Color, Translate) - , Display(InWindow), circleSolid - , red, rotate, white, withAlpha ) -import Graphics.Gloss.Interface.FRP.Yampa ( playYampa ) +import Graphics.Gloss ( Color, Display (InWindow) + , Picture (Color, Pictures, Translate) + , aquamarine, azure, blue + , chartreuse, circleSolid + , cyan, green, magenta + , orange, polygon, red, red + , rose, rotate, thickArc + , violet, white, withAlpha + , yellow + ) +import Graphics.Gloss.Interface.FRP.Yampa ( InputEvent, playYampa ) main :: IO () -main = playYampa (InWindow "YampaDemo" (1280, 1050) (200, 200)) white 30 rotatingColor +main = defaultPlay rotatingColor +defaultPlay :: SF (Event InputEvent) Picture -> IO () +defaultPlay = playYampa (InWindow "YampaDemo" (1280, 1050) (200, 200)) white 30 + rotatingColor :: SF a Picture rotatingColor = proc _ -> do - t <- double2Float ^<< time -< () -- Yampa's time is Double, Gloss units are Float. + t <- ftime -< () -- Yampa's time is Double, Gloss units are Float. returnA -< rotate (180 * t / pi) $ Translate 200 200 $ Color (withAlpha 0.8 red) $ circleSolid 80 + +-- +plainWave :: SF a Picture +plainWave = proc _ -> do + t <- (*1.25) ^<< ftime -< () + + let t2 n = (sin (t + 2 * pi * fromIntegral n / 45)) ** 2 + circleX n = fromIntegral n * 20 - 400 + circleY n = t2 n * 200 + + returnA -< Pictures + [ Translate (circleX n) (circleY n) + $ Color (withAlpha 0.8 magenta) + $ circleSolid 10 + | n <- [0 .. length colors] + | c <- colors + ] + + + +wave :: SF a Picture +wave = proc _ -> do + t <- (*20) ^<< ftime -< () + let t2 = (t - 20) `modF` 60 + let t3 = (t - 40) `modF` 60 + let t4 = t `modF` 60 + let a1 = if t4 < 5 then Pictures [] else thickArc 0 90 t4 10 + a2 = if t2 < 5 then Pictures [] else thickArc 0 90 t2 10 + a3 = if t3 < 5 then Pictures [] else thickArc 0 90 t3 10 + returnA -< rotate 45 $ Pictures [a1, a2, a3] + +linearTween :: Double -> SF a Double +linearTween maxTime = + switch (progress &&& after maxTime ()) (\_ -> constant 1) + where + progress = proc _ -> do + t <- time -< () + let prop = t / maxTime + returnA -< prop + +-- * Auxiliary definitions + +-- ** Auxiliary Gloss definitions + +thickRectangle thickness w h = + Pictures [ polygon [(0,0), (w, 0), (w, thickness), (0, thickness), (0, 0)] + , polygon [(w-thickness,0), (w, 0), (w, h), (w-thickness, h), (w-thickness, 0)] + , polygon [(0,0), (thickness, 0), (thickness, h), (0, h), (0, 0)] + , polygon [(0,h-thickness), (w, h-thickness), (w, h), (0, h), (0, h-thickness)] + ] + +colors :: [Color] +colors = [ red, orange, yellow, chartreuse, green, aquamarine + , cyan, azure, blue, violet, magenta, rose + ] + +arrowHead :: Picture +arrowHead = polygon [(100,0), (0, 40), (0, -40)] + +nothing :: Picture +nothing = Pictures [] + +-- ** Auxiliary Num definitions + +modF :: Float -> Float -> Float +modF f1 m = if f1 > m then modF (f1 - m) m else f1 + +-- ** Auxiliary Yampa definitions + +untilSF sf1 sf2 = sf1 &&& sf2 +forSF sf1 t = sf1 `untilSF` after t () +andThen_ sf1 sf2 = switch sf1 (\_ -> sf2) + +ftime :: SF a Float +ftime = time >>^ double2Float diff --git a/src/Graphics/Gloss/Interface/FRP/Yampa.hs b/src/Graphics/Gloss/Interface/FRP/Yampa.hs --- a/src/Graphics/Gloss/Interface/FRP/Yampa.hs +++ b/src/Graphics/Gloss/Interface/FRP/Yampa.hs @@ -1,48 +1,76 @@ +-- | +-- Copyright : (c) 2018-2023 Ivan Perez +-- (c) 2015-2018 Konstantin Saveljev +-- License : MIT License (MIT) +-- Maintainer : ivan.perez@keera.co.uk +-- +-- Gloss backend for Yampa. +-- +-- Gloss is a purely functional library to create pictures and animations. +-- Yampa is a Functional Reactive Programming DSL structured around signal +-- functions. +-- +-- This module provides a function to create an interactive Gloss animation +-- driven by a signal function that transforms a Gloss input signal into a +-- Gloss 'Picture'. module Graphics.Gloss.Interface.FRP.Yampa - (playYampa, InputEvent) + (InputEvent, playYampa) where +-- External imports import Control.Monad (when) import Data.IORef (newIORef, readIORef, writeIORef) -import FRP.Yampa (Event (..), SF, react, +import FRP.Yampa (DTime, Event (..), SF, react, reactInit) import Graphics.Gloss (Color, Display, Picture, blank) -import qualified Graphics.Gloss import Graphics.Gloss.Interface.IO.Game (playIO) import qualified Graphics.Gloss.Interface.IO.Game as G +-- | Type representing input events to the signal function. +-- +-- Note that this type represents the kind of information placed inside the +-- Yampa 'Event'. It will still be wrapped in an 'Event' to represent the fact +-- that an 'InputEvent' may or may not be present at one particular point in +-- time, and that it changes discretely. type InputEvent = G.Event --- | Play the game in a window, updating when the value of the provided -playYampa :: Display -- ^ The display method - -> Color -- ^ The background color - -> Int -- ^ The refresh rate, in Hertz - -> SF (Event InputEvent) Picture +-- | Play the game in a window, updating when the value of the provided +playYampa :: Display -- ^ The display method + -> Color -- ^ The background color + -> Int -- ^ The refresh rate, in Hertz + -> SF (Event InputEvent) Picture -- ^ Signal function -> IO () playYampa display color frequency mainSF = do picRef <- newIORef blank handle <- reactInit - (return NoEvent) - (\_ updated pic -> when updated (picRef `writeIORef` pic) >> return False) - mainSF - - let delta = 0.01 / fromIntegral frequency + (return NoEvent) + (\_ updated pic -> do when updated (picRef `writeIORef` pic) + return False + ) + mainSF - -- An action to convert the world to a picture - toPic = (const $ readIORef picRef) + let -- An action to convert the world to a picture + toPic :: DTime -> IO Picture + toPic = const $ readIORef picRef -- A function to handle input events - handleInput = (\e t -> react handle (delta, Just (Event e)) >> return (t + delta)) + handleInput :: G.Event -> DTime -> IO DTime + handleInput event timeAcc = do + _quit <- react handle (delta, Just (Event event)) + return (timeAcc + delta) + where + delta = 0.01 / fromIntegral frequency - -- A function to step the world one iteration. It is passed the period - -- of time (in seconds) needing to be advanced - stepWorld = - (\d t -> let delta' = realToFrac d - t - in if delta' > 0 - then react handle (delta', Just NoEvent) >> return 0.0 - else return (-delta')) + -- A function to step the world one iteration. It is passed the period of + -- time (in seconds) needing to be advanced + stepWorld :: Float -> DTime -> IO DTime + stepWorld delta timeAcc + | delta' > 0 = react handle (delta', Just NoEvent) >> return 0.0 + | otherwise = return (-delta') + where + delta' = realToFrac delta - timeAcc playIO display color frequency 0 toPic handleInput stepWorld diff --git a/yampa-gloss.cabal b/yampa-gloss.cabal --- a/yampa-gloss.cabal +++ b/yampa-gloss.cabal @@ -1,5 +1,5 @@ name: yampa-gloss -version: 0.2 +version: 0.2.1 synopsis: A GLOSS backend for Yampa description: A Gloss backend for Yampa. @@ -30,9 +30,9 @@ library exposed-modules: Graphics.Gloss.Interface.FRP.Yampa - build-depends: base >= 4.7 && <4.13 + build-depends: base >= 4.7 && <4.19 , gloss >= 1.10 && <1.14 - , Yampa >= 0.9.6 && <0.14 + , Yampa >= 0.9.6 && <0.15 hs-source-dirs: src default-language: Haskell2010 @@ -43,9 +43,9 @@ default-language: Haskell2010 if flag(examples) buildable: True - build-depends: base >= 4.7 && <4.13 + build-depends: base >= 4.7 && <4.19 , gloss >= 1.10 && <1.14 - , Yampa >= 0.9.6 && <0.14 + , Yampa >= 0.9.6 && <0.15 , yampa-gloss else buildable: False