packages feed

dyna-gloss (empty) → 0.1.0.0

raw patch · 14 files changed

+1904/−0 lines, 14 filesdep +Booleandep +MonadRandomdep +basesetup-changed

Dependencies added: Boolean, MonadRandom, base, dyna, dyna-gloss, gloss, lifted-base, monad-control, mtl, random, stm, temporal-media, time, transformers-base, unagi-chan, vector-space

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for dyna-gloss++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2022++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,12 @@+# dyna-gloss++FRP bindings for library `gloss` which is great+to create 2D animation and graphics. It features declarative+and functional approach to drawing the pictures and here we+make it even more declarative with FRP style.++## Tutorial++* [Introduction](https://github.com/anton-k/dyna-frp/blob/main/dyna-gloss/tutorial/00-intro.md)+* [Example](https://github.com/anton-k/dyna-frp/blob/main/dyna-gloss/tutorial/01-example.md)+* [Quick reference](https://github.com/anton-k/dyna-frp/blob/main/dyna-gloss/tutorial/101-reference.md)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ dyna-gloss.cabal view
@@ -0,0 +1,83 @@+cabal-version: 1.12++name:           dyna-gloss+version:        0.1.0.0+synopsis:       FRP for gloss graphics and animation library+description:    Defines FRP for gloss graphics and animation library+homepage:       https://github.com/anton-k/dyna-gloss#readme+bug-reports:    https://github.com/anton-k/dyna-gloss/issues+author:         Anton Kholomiov+maintainer:     anton.kholomiov@gmail.com+category:       Graphics, FRP+copyright:      2022 Anton Kholomiov+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/anton-k/dyna-frp/dyna-gloss++library+  exposed-modules:+      Dyna.Gloss+      Dyna.Gloss.Data.Picture+      Dyna.Gloss.Data.Point+      Dyna.Gloss.Data.Vec+      Dyna.Gloss.Geometry.Line+      Dyna.Gloss.Frp+      Dyna.Gloss.Run+  other-modules:+      Dyna.Gloss.Types+      Paths_dyna_gloss+  hs-source-dirs:+      src+  build-depends:+      base >=4.7 && <5+    , Boolean+    , dyna+    , gloss+    , lifted-base+    , monad-control+    , mtl+    , stm+    , temporal-media+    , time+    , transformers-base+    , vector-space+    , unagi-chan+    , random+    , MonadRandom+  default-language: Haskell2010+  default-extensions:+    GADTs+    RankNTypes+    LambdaCase+    FlexibleContexts+    FlexibleInstances+    ExistentialQuantification+    MultiParamTypeClasses+    TypeApplications+    TypeFamilies+    TupleSections+    GeneralizedNewtypeDeriving+    UndecidableInstances+    ImportQualifiedPost+    RecordWildCards+++test-suite dyna-gloss-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_dyna_gloss+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , dyna-gloss+  default-language: Haskell2010
+ src/Dyna/Gloss.hs view
@@ -0,0 +1,25 @@+module Dyna.Gloss(+  module X+) where++import Data.AdditiveGroup as X+import Data.AffineSpace as X+import Data.Basis as X+import Data.Cross as X+import Data.VectorSpace as X+import Temporal.Class as X++import Graphics.Gloss.Data.Bitmap as X+import Graphics.Gloss.Data.Color as X+import Graphics.Gloss.Data.Display as X+import Graphics.Gloss.Data.ViewPort as X+import Graphics.Gloss.Data.ViewState as X+import Graphics.Gloss.Geometry.Angle as X+import Graphics.Gloss.Interface.Environment as X++import Dyna.Gloss.Frp as X+import Dyna.Gloss.Run as X+import Dyna.Gloss.Data.Vec as X+import Dyna.Gloss.Data.Point as X+import Dyna.Gloss.Data.Picture as X+import Dyna.Gloss.Geometry.Line as X
+ src/Dyna/Gloss/Data/Picture.hs view
@@ -0,0 +1,198 @@+module Dyna.Gloss.Data.Picture+        ( Picture       (..)+        , Point, Vec, Path++        -- * Aliases for Picture constructors+        , blank+        , polygon+        , line+        , circle, thickCircle+        , arc,    thickArc+        , text+        , bitmap+        , bitmapSection+        -- , bitmap+        , color+        , translate, rotate, scale+        , pictures++        -- * Compound shapes+        , lineLoop+        , circleSolid+        , arcSolid+        , sectorWire+        , rectanglePath+        , rectangleWire+        , rectangleSolid+        , rectangleUpperPath+        , rectangleUpperWire+        , rectangleUpperSolid+        )+where++import Data.VectorSpace+import Graphics.Gloss.Data.Bitmap+import Graphics.Gloss.Data.Color+import Graphics.Gloss.Data.Picture (Picture(..))+import Graphics.Gloss.Geometry.Angle+import Dyna.Gloss.Data.Point+import Dyna.Gloss.Data.Vec++-- Constructors ----------------------------------------------------------------+-- NOTE: The docs here should be identical to the ones on the constructors.++-- | A blank picture, with nothing in it.+blank :: Picture+blank   = Blank++-- | A convex polygon filled with a solid color.+polygon :: Path -> Picture+polygon = Polygon . fmap toTuple++-- | A line along an arbitrary path.+line :: Path -> Picture+line = Line . fmap toTuple++-- | A circle with the given radius.+circle  :: Float  -> Picture+circle  = Circle++-- | A circle with the given thickness and radius.+--   If the thickness is 0 then this is equivalent to `Circle`.+thickCircle  :: Float -> Float -> Picture+thickCircle = ThickCircle++-- | A circular arc drawn counter-clockwise between two angles (in degrees)+--   at the given radius.+arc     :: Float -> Float -> Float -> Picture+arc = Arc++-- | A circular arc drawn counter-clockwise between two angles (in degrees),+--   with the given radius  and thickness.+--   If the thickness is 0 then this is equivalent to `Arc`.+thickArc :: Float -> Float -> Float -> Float -> Picture+thickArc = ThickArc++-- | Some text to draw with a vector font.+text :: String -> Picture+text = Text++-- | A bitmap image+bitmap  :: BitmapData -> Picture+bitmap bitmapData = Bitmap bitmapData++-- | a subsection of a bitmap image+--   first argument selects a sub section in the bitmap+--   second argument determines the bitmap data+bitmapSection  :: Rectangle -> BitmapData -> Picture+bitmapSection = BitmapSection++-- | A picture drawn with this color.+color :: Color -> Picture -> Picture+color = Color++-- | A picture translated by the given x and y coordinates.+translate :: Vec -> Picture -> Picture+translate (Vec x y) = Translate x y++-- | A picture rotated clockwise by the given angle (in tau's).+-- 1 Tau is full circle.+rotate  :: Float -> Picture -> Picture+rotate x = Rotate (360 * x)++-- | A picture scaled by the given x and y factors.+scale   :: Vec -> Picture -> Picture+scale (Vec x y) = Scale x y++-- | A picture consisting of several others.+pictures :: [Picture] -> Picture+pictures = Pictures+++-- Other Shapes ---------------------------------------------------------------+-- | A closed loop along a path.+lineLoop :: Path -> Picture+lineLoop xs     = line $ case xs of+   []     -> []+   (x:xs) -> (x:xs) ++ [x]+++-- Circles and Arcs -----------------------------------------------------------+-- | A solid circle with the given radius.+circleSolid :: Float -> Picture+circleSolid r+        = thickCircle (r/2) r+++-- | A solid arc, drawn counter-clockwise between two angles at the given radius.+arcSolid  :: Float -> Float -> Float -> Picture+arcSolid a1 a2 r+        = thickArc a1 a2 (r/2) r+++-- | A wireframe sector of a circle.+--   An arc is draw counter-clockwise from the first to the second angle at+--   the given radius. Lines are drawn from the origin to the ends of the arc.+---+--   NOTE: We take the absolute value of the radius incase it's negative.+--   It would also make sense to draw the sector flipped around the+--   origin, but I think taking the absolute value will be less surprising+--   for the user.+--+sectorWire :: Float -> Float -> Float -> Picture+sectorWire a1 a2 r_+ = let r        = abs r_+   in  Pictures+        [ Arc a1 a2 r+        , line [0, r *^ unitVecAtAngle (degToRad a1) ]+        , line [0, r *^ unitVecAtAngle (degToRad a2) ]+        ]++-- Rectangles -----------------------------------------------------------------+-- NOTE: Only the first of these rectangle functions has haddocks on the+--       arguments to reduce the amount of noise in the extracted docs.++-- | A path representing a rectangle centered about the origin+rectanglePath+        :: Float        -- ^ width of rectangle+        -> Float        -- ^ height of rectangle+        -> Path+rectanglePath sizeX sizeY+ = let  sx      = sizeX / 2+        sy      = sizeY / 2+   in   [Vec (-sx) (-sy), Vec (-sx) sy, Vec sx sy, Vec sx (-sy)]++-- | A wireframe rectangle centered about the origin.+rectangleWire :: Float -> Float -> Picture+rectangleWire sizeX sizeY+        = lineLoop $ rectanglePath sizeX sizeY++-- | A wireframe rectangle in the y > 0 half of the x-y plane.+rectangleUpperWire :: Float -> Float -> Picture+rectangleUpperWire sizeX sizeY+        = lineLoop $ rectangleUpperPath sizeX sizeY++-- | A path representing a rectangle in the y > 0 half of the x-y plane.+rectangleUpperPath :: Float -> Float -> Path+rectangleUpperPath sizeX sy+ = let  sx      = sizeX / 2+   in   [Vec (-sx) 0, Vec (-sx) sy, Vec sx sy, Vec sx 0]++-- | A solid rectangle centered about the origin.+rectangleSolid :: Float -> Float -> Picture+rectangleSolid sizeX sizeY+        = Polygon $ rectanglePath' sizeX sizeY+  where+    rectanglePath' sizeX sizeY =+        let  sx      = sizeX / 2+             sy      = sizeY / 2+        in   [(-sx, -sy), (-sx, sy), (sx, sy), (sx, -sy)]++-- | A solid rectangle in the y > 0 half of the x-y plane.+rectangleUpperSolid :: Float -> Float -> Picture+rectangleUpperSolid sizeX sizeY = Polygon $ path sizeX sizeY+  where+    path sizeX sy+      = let  sx      = sizeX / 2+        in   [(-sx, 0), (-sx, sy), (sx, sy), (sx, 0)]+
+ src/Dyna/Gloss/Data/Point.hs view
@@ -0,0 +1,30 @@+module Dyna.Gloss.Data.Point+        ( Point, Path+        , pointInBox)+where++import Dyna.Gloss.Data.Vec++type Point = Vec+type Path = [Point]++-- | Test whether a point lies within a rectangular box that is oriented+--   on the x-y plane. The points P1-P2 are opposing points of the box,+--   but need not be in a particular order.+--+-- @+--    P2 +-------++--       |       |+--       | + P0  |+--       |       |+--       +-------+ P1+-- @+--+pointInBox :: Point -> Point -> Point -> Bool+pointInBox (Vec x0 y0) (Vec x1 y1) (Vec x2 y2)+  =  x0 >= min x1 x2+  && x0 <= max x1 x2+  && y0 >= min y1 y2+  && y0 <= max y1 y2++
+ src/Dyna/Gloss/Data/Vec.hs view
@@ -0,0 +1,168 @@+module Dyna.Gloss.Data.Vec(+    Vec(..)+  , magV+  , argV+  , dotV+  , detV+  , mulSV+  , rotateV+  , angleVV+  , normalizeV+  , unitVecAtAngle+  , e+  , VecBasis(..)+  , fromTuple+  , toTuple+  ) where++import Graphics.Gloss.Geometry.Angle+import Dyna (BasisArity(..))+import Data.AdditiveGroup+import Data.AffineSpace+import Data.Basis+import Data.Cross+import Data.VectorSpace++-- | Pair of unboxed floats. All operations on vectors are strict+-- which is more suitable for computation intensive domains such as computer graphics.+data Vec = Vec+  { vec'x :: {-# UNPACK #-} !Float+  , vec'y :: {-# UNPACK #-} !Float+  }+  deriving (Show, Eq, Ord)++-- | Converts vector to tuple of Floats+toTuple :: Vec -> (Float, Float)+toTuple (Vec x y) = (x, y)++-- | Converts tuple of floats to vector+fromTuple :: (Float, Float) -> Vec+fromTuple (x, y) = Vec x y++lift0 :: Float -> Vec+lift0 a = Vec a a++lift1 :: (Float -> Float) -> Vec -> Vec+lift1 f (Vec a b) = Vec (f a) (f b)++lift2 :: (Float -> Float -> Float) -> Vec -> Vec -> Vec+lift2 f (Vec a1 b1) (Vec a2 b2) = Vec (f a1 a2) (f b1 b2)++-- numeric instances++instance Num Vec where+  fromInteger = lift0 . fromInteger+  (+) = lift2 (+)+  (*) = lift2 (*)+  (-) = lift2 (-)+  negate = lift1 negate+  abs = lift1 abs+  signum = lift1 signum++instance Fractional Vec where+  fromRational = lift0 . fromRational+  recip = lift1 recip+  (/) = lift2 (/)++-- vector space instances++instance AdditiveGroup Vec where+  zeroV = lift0 zeroV+  (^+^) = lift2 (^+^)+  (^-^) = lift2 (^-^)+  negateV = lift1 negateV++instance VectorSpace Vec where+  type Scalar Vec = Float+  (*^) k = lift1 (k *^)++instance AffineSpace Vec where+  type Diff Vec = Vec+  (.-.) = lift2 (.-.)+  (.+^) = lift2 (.+^)++instance BasisArity Vec where+  basisArity _ = 2++data VecBasis = VecX | VecY++instance HasBasis Vec where+  type Basis Vec = VecBasis+  basisValue = \case+    VecX -> Vec 1 0+    VecY -> Vec 0 1++  decompose (Vec x y) = [(VecX, x), (VecY, y)]++  decompose' (Vec x y) = \case+    VecX -> x+    VecY -> y++instance HasNormal Vec where+  normalVec = normalizeV++instance HasCross2 Vec where+  cross2 (Vec x y) = Vec (negate y) x -- or @(y,-x)@?++-------------------------------------------------------------------+-- gloss functions on Vectors++-- | Normalise a vector, so it has a magnitude of 1.+normalizeV :: Vec -> Vec+normalizeV v = lift1 ((1 / magV v) * ) v+{-# INLINE normalizeV #-}++-- | The magnitude of a vector.+magV :: Vec -> Float+magV (Vec x y) = sqrt (x * x + y * y)+{-# INLINE magV #-}++-- | The angle of this vector, relative to the +ve x-axis.+argV :: Vec -> Float+argV (Vec x y) = normalizeAngle $ atan2 y x+{-# INLINE argV #-}++-- | The dot product of two vectors.+dotV :: Vec -> Vec -> Float+dotV (Vec x1 x2) (Vec y1 y2) = x1 * y1 + x2 * y2+{-# INLINE dotV #-}++-- | The determinant of two vectors.+detV :: Vec -> Vec -> Float+detV (Vec x1 y1) (Vec x2 y2) = x1 * y2 - y1 * x2+{-# INLINE detV #-}++-- | Multiply a vector by a scalar.+mulSV :: Float -> Vec -> Vec+mulSV s (Vec x y) = Vec (s * x) (s * y)+{-# INLINE mulSV #-}++-- | Rotate a vector by an angle (in radians). +ve angle is counter-clockwise.+rotateV :: Float -> Vec -> Vec+rotateV r (Vec x y)+ = Vec (x * cos r - y * sin r)+       (x * sin r + y * cos r)+{-# INLINE rotateV #-}++-- | Compute the inner angle (in radians) between two vectors.+angleVV :: Vec -> Vec -> Float+angleVV p1 p2+ = let  m1      = magV p1+        m2      = magV p2+        d       = p1 `dotV` p2+        aDiff   = acos $ d / (m1 * m2)++   in   aDiff+{-# INLINE angleVV #-}++-- | Produce a unit vector at a given angle relative to the +ve x-axis.+--      The provided angle is in radians.+unitVecAtAngle :: Float -> Vec+unitVecAtAngle r = Vec (cos r) (sin r)+{-# INLINE unitVecAtAngle #-}++-- | Shortcut for @unitVecAtAngle@+e :: Float -> Vec+e = unitVecAtAngle+{-# INLINE e #-}+
+ src/Dyna/Gloss/Frp.hs view
@@ -0,0 +1,655 @@+-- | FRP main types and combinators+module Dyna.Gloss.Frp(+  -- * Events+  Evt,+  once,+  never,+  -- * Dynamics+  Dyn,+  constDyn,+  -- ** Observing the Dyn+  DynRef,+  runDyn,+  readDyn,+  cancelDyn,++  -- * Control+  newEvt,+  newDyn,++  -- * API+  -- * Event API+  scan,+  scanMay,+  mapMay,+  foldMap,+  accum,+  accumB,+  accumMay,+  filters,+  filterJust,+  whens,+  splits,+  lefts,+  rights,+  iterates,+  withIterates,++  fix1,+  fix2,+  fix3,+  fix4,+  switch,+  joins,++  delay,+  delayFork,++  sums,+  sumD,+  integrate,+  integrate2,+  products,+  count,+  withCount,+  appends,+  takes,+  drops,+  takesWhile,+  dropsWhile,+  cycles,+  listAt,+  toToggle,++  races,+  forks,+  forevers,+  folds,+  foldls,+  foldls',+  foldrs,+  foldrs',+  prints,+  putStrLns,+  -- * Event/Dynamic interaction+  hold,+  unhold,+  scanD,+  scanMayD,+  switchD,+  switchDyn,+  apply,+  applyMay,+  snap,+  attach,+  attachWith,+  attachWithMay,+  (<@>),+  (<@),+  -- * Effectful API+  RunFunctor(..),+  foreach,+  posteach,+  iterates',+  scan',+  scanMay',+  accum',+  accumMay',+  filters',+  mapMay',+  apply',+  applyMay',+  -- * Utilities++  -- **  Channels (interaction with the world)+  mchanEvt,+  tchanEvt,+  uchanEvt,++  -- ** Clock+  clock,+  pulse,+  ticks,+  timer,+  timerD,+  -- ** Random+  toRandom,+  toRandomR,+  withRandom,+  withRandomR,+  oneOf,+  withOneOf,+  freqOf,+  withFreqOf,+  randSkip,+  randSkipBy,++  -- * Re-exports+  liftA2,+  liftA3,+) where++import Control.Applicative (liftA2, liftA3)+import Control.Concurrent.Chan qualified as M+import Control.Concurrent.STM+import Control.Concurrent.Chan.Unagi (InChan)+import Data.Bifunctor+import Data.Time+import System.Random+import Data.VectorSpace++import Dyna.Gloss.Types+import Dyna qualified as D++infixl 4 <@>+infixl 4 <@++-- | Reference to running dynamic process by which we can query values (@readDyn@).+-- Also note that we no longer need the reference we should release the resources+-- by calling @cancelDyn@.+newtype DynRef a = DynRef { unDynRef :: D.DynRef Run a }++-- | Runs dynamic within the scope of the function.+-- It provides a callback with dyn getter as argument and after+-- callback finishes it shutdowns the dyn process.+withDyn :: Dyn a -> (Run a -> Run b) -> Run b+withDyn (Dyn dyn) f = D.withDyn dyn f++-- | Dyn that is constructed from effectful callback.+constDyn :: Run a -> Dyn a+constDyn act = Dyn $ D.constDyn act++-- | Executes dynamic for observation. The dynamic is step-wise constant+-- function that is driven by some event stream. The function runs the event stream+-- process in background and samples the updated state.+--+-- We can observe the value with @readDyn@. We need to shut down the stream when+-- we no longer need it with @cancelDyn@ function.+runDyn :: Dyn a -> Run (DynRef a)+runDyn (Dyn d) = DynRef <$> D.runDyn d+--+-- | Event that happens only once and happens right away.+once :: Run a -> Evt a+once ask = Evt $ D.once ask++-- | Event that never happens. Callback function is ignored.+never :: Evt a+never = Evt D.never++-- | Runs the argument event stream as background process+-- and produces event stream that is fed with events over channel (unagi-channel package).+-- When result event stream shuts down the background process also shuts down.+newEvt :: Evt a -> Run (Evt a)+newEvt (Evt evt) = Evt <$> D.newEvt evt++-- | Runs the dynamic process in background and returns dynamic+-- that just samples the background proces with @readDyn@.+newDyn :: Dyn a -> Run (Dyn a)+newDyn (Dyn dyn) = Dyn <$> D.newDyn dyn++-- | Accumulate over event stream.+accum :: (a -> s -> (b, s)) -> s -> Evt a -> Evt b+accum f s (Evt evt) = Evt $ D.accum f s evt++-- | Accumulate over event stream.+accum' :: (a -> s -> Run (b, s)) -> s -> Evt a -> Evt b+accum' f s (Evt evt) = Evt $ D.accum' f s evt++-- | Accumulate over event stream.+accumMay :: (a -> s -> Maybe (b, s)) -> s -> Evt a -> Evt b+accumMay f s (Evt evt) = Evt $ D.accumMay f s evt++-- | Accumulate over event stream.+accumMay' :: (a -> s -> Run (Maybe (b, s))) -> s -> Evt a -> Evt b+accumMay' f s (Evt evt) = Evt $ D.accumMay' f s evt++-- | scan over event stream. Example:+--+-- > naturals = scan (+) 0 pulse+scan :: (a -> b -> b) -> b -> Evt a -> Evt b+scan f s (Evt evt) = Evt $ D.scan f s  evt++-- | scan over event stream with effectful function.+scan' :: (a -> b -> Run b) -> b -> Evt a -> Evt b+scan' f s (Evt evt) = Evt $ D.scan' f s evt++-- | scan combined with filter. If accumulator function produces @Nothing@ on event then+-- that event is ignored and state is kept to previous state.+scanMay :: (a -> b -> Maybe b) -> b -> Evt a -> Evt b+scanMay f s (Evt evt) = Evt $ D.scanMay f s evt++-- | scan combined with filter for effectful function. See @scanMay@ for details.+scanMay' :: (a -> b -> Run (Maybe b)) -> b -> Evt a -> Evt b+scanMay' f s (Evt evt) = Evt $ D.scanMay' f s evt++-- | Combo of @fmap@ and @appends@+foldMaps :: Monoid b => (a -> b) -> Evt a -> Evt b+foldMaps f evt = appends (fmap f evt)++-- | Repeatedly executes the same event stream+races :: Evt a -> Evt a -> Evt a+races (Evt evtA) (Evt evtB) = Evt (D.races evtA evtB)++-- | Repeatedly executes the same event stream+forks :: Evt a -> Evt a+forks (Evt evt) = Evt (D.forks evt)++-- | Repeatedly executes the same event stream+forevers :: Evt a -> Evt a+forevers (Evt evt) = Evt (D.forevers evt)++-- | Iterates over event stream. It's like scan but it ignores the values of underying stream+-- and starts with initial value as first element.+iterates :: (a -> a) -> a -> Evt b -> Evt a+iterates f val (Evt evt) = Evt $ D.iterates f val evt++withIterates :: (a -> a) -> a -> Evt b -> Evt (a, b)+withIterates f val (Evt evt) = Evt $ D.withIterates f val evt++-- | Effectful version for @iterateE@.+iterates' :: (a -> Run a) -> a -> Evt b -> Evt a+iterates' f val (Evt evt) = Evt $ D.iterates' f val evt++-- | Reads current dynamic value.+readDyn :: DynRef  a -> Run a+readDyn (DynRef ref) = D.readDyn ref++-- | Shuts down the background process for dynamic and releases resulrces for+-- event stream that drives the dynamic.+cancelDyn :: DynRef a -> Run ()+cancelDyn (DynRef ref) = D.cancelDyn ref++-- | Turns event stream to dynamic. It holds the values of+-- events until the next event happen. It starts with initial value.+--+-- > hold initVal events = ...+hold :: a -> Evt a -> Dyn a+hold s (Evt evt) = Dyn $ D.hold s evt++-- | Counts how many events accured so far on the stream.+count :: Evt a -> Evt Int+count (Evt evt) = Evt (D.count evt)++withCount :: Evt a -> Evt (Int, a)+withCount (Evt evt) = Evt (D.withCount evt)++-- | Turns dynamic into event stream of underlying events+-- that trigger dynamic updates.+unhold :: Dyn a -> Evt a+unhold (Dyn dyn) = Evt $ D.unhold dyn++-- | scans over event stream and converts it to dynamic.+scanD :: (a -> b -> b) -> b -> Evt a -> Dyn b+scanD f s (Evt evt) = Dyn $ D.scanD f s evt++-- | Accumulates the values with event stream that produce functions.+accumB :: a -> Evt (a -> a) -> Dyn a+accumB a (Evt evt) = Dyn $ D.accumB a evt++-- | Dynamic scan that can also filter out events. If Nothing is produced then the event is skipped.+scanMayD :: (a -> b -> Maybe b) -> b -> Evt a -> Dyn b+scanMayD f s (Evt evt) = Dyn $ D.scanMayD f s evt++-- | Adds some procedure to callback. Procedure is called prior to callback execution.+foreach :: (a -> Run ()) -> Evt a -> Evt a+foreach call (Evt evt) = Evt $ D.foreach call evt++-- | Adds some procedure to callback. Procedure is called after callback execution.+posteach :: (a -> Run ()) -> Evt a -> Evt a+posteach call (Evt evt) = Evt $ D.posteach call evt++--------------------------------------------------------------------------------+-- applications++-- | Applies a function to event stream value. The function is sampled+-- from dynamic process.+apply :: Dyn (a -> b) -> Evt a -> Evt b+apply (Dyn dyn) (Evt evt) = Evt $ D.apply dyn evt++-- | Effectful variant of @apply@.+apply' :: Dyn (a -> Run b) -> Evt a -> Evt b+apply' (Dyn dyn) (Evt evt) = Evt $ D.apply' dyn evt++-- | Infix variant of @apply@+(<@>) :: Dyn (a -> b) -> Evt a -> Evt b+(<@>) = apply++-- | Infix variant of @snap@.+(<@) :: Dyn a -> Evt b -> Evt a+(<@) = snap++-- | Apply combined with filter.+applyMay :: Dyn (a -> Maybe b) -> Evt a -> Evt b+applyMay (Dyn dyn) (Evt evt) = Evt $ D.applyMay dyn evt++-- | Effectful @applyMay@.+applyMay' :: Dyn (a -> Run (Maybe b)) -> Evt a -> Evt b+applyMay' (Dyn dyn) (Evt evt) = Evt $ D.applyMay' dyn evt++-- | Snapshot of dynamic process with event stream. All values+-- in the event stream are substituted with current value of dynamic.+snap :: Dyn a -> Evt b -> Evt a+snap (Dyn dyn) (Evt evt) = Evt (D.snap dyn evt)++-- | Kind of @zipWith@ function for dynamics and event streams.+attach :: Dyn a -> Evt b -> Evt (a, b)+attach (Dyn dyn) (Evt evt) = Evt $ D.attach dyn evt++-- | Kind of @zipWith@ function for dynamics and event streams.+attachWith :: (a -> b -> c) -> Dyn a -> Evt b -> Evt c+attachWith f (Dyn dyn) (Evt evt) = Evt $ D.attachWith f dyn evt++-- | Attach with filtering. When @Nothing@ is produced event is omitted from the stream.+attachWithMay :: (a -> b -> Maybe c) -> Dyn a -> Evt b -> Evt c+attachWithMay f (Dyn dyn) (Evt evt) = Evt $ D.attachWithMay f dyn evt++-- | Map with filtering. When @Nothing@ is produced event is omitted from the stream.+mapMay :: (a -> Maybe b) -> Evt a -> Evt b+mapMay f (Evt evt) = Evt $ D.mapMay f evt++-- | Map with filtering. When @Nothing@ is produced event is omitted from the stream.+mapMay' :: (a -> Run (Maybe b)) -> Evt a -> Evt b+mapMay' f (Evt evt) = Evt $ D.mapMay' f evt++--------------------------------------------------------------------------------+-- filters++-- | Filtering of the event strewams. Only events that produce True remain in the stream.+filters :: (a -> Bool) -> Evt a -> Evt a+filters f (Evt evt) = Evt $ D.filters f evt++-- | Effectful filtering for event streams.+filters' :: (a -> Run Bool) -> Evt a -> Evt a+filters' f (Evt evt) = Evt $ D.filters' f evt++-- | Filters based on Maybe. If @Nothing@ is produced forthe event it is omitted from the stream.+filterJust :: Evt (Maybe a) -> Evt a+filterJust (Evt evt) = Evt $ D.filterJust evt++-- | Filters with dynamic. When dynamic is true events pass through and when it's false+-- events are omitted.+whens :: Dyn Bool -> Evt a -> Evt a+whens (Dyn dyn) (Evt evt) = Evt $ D.whens dyn evt++-- | Splits the either event stream.+splits :: Evt (Either a b) -> (Evt a, Evt b)+splits evt = (lefts evt, rights evt)++-- | Gets all left events from the stream+lefts :: Evt (Either a b) -> Evt a+lefts (Evt evt) = Evt $ D.lefts evt++-- | Gets all right events from the stream+rights :: Evt (Either a b) -> Evt b+rights (Evt evt) = Evt $ D.rights evt++-- | Takes only so many events from the stream+takes :: Int -> Evt a -> Evt a+takes n (Evt evt) = Evt $ D.takes n evt++-- | Takes only so many events from the stream+drops :: Int -> Evt a -> Evt a+drops n (Evt evt) = Evt $ D.drops n evt++-- | Takes events only while predicate is true.+takesWhile :: (a -> Bool) -> Evt a -> Evt a+takesWhile pred (Evt evt) = Evt $ D.takesWhile pred evt++-- | Takes events only while predicate is true.+dropsWhile :: (a -> Bool) -> Evt a -> Evt a+dropsWhile pred (Evt evt) = Evt $ D.dropsWhile pred evt++-- | Takes elements from the list by index. If index is out of bounds the event is omitted.+listAt :: [a] -> Evt Int -> Evt a+listAt vals (Evt evt) = Evt $ D.listAt vals evt++-- | Turns event stream to toggle stream. It produce cyclic sequence of [True, False]+toToggle :: Evt a -> Evt Bool+toToggle (Evt evt) = Evt (D.toToggle evt)++-- | Cycles the values in the list over event sream.+cycles :: [a] -> Evt b -> Evt a+cycles vals (Evt evt) = Evt (D.cycles vals evt)++-- | Sums all the elements in the event stream+sums :: (Num a) => Evt a -> Evt a+sums = scan (+) 0++-- | Sums all the elements in the event stream+sumD :: (Num a) => Float -> Dyn a -> Dyn a+sumD dt (Dyn dyn) = Dyn (D.sumD (realToFrac dt) dyn)++integrate :: (VectorSpace v, Scalar v ~ Float) => Float -> Dyn v -> Dyn v+integrate dt (Dyn dyn) = Dyn $ D.integrate dt dyn++integrate2 :: (VectorSpace v, Scalar v ~ Float) => Float -> Dyn v -> Dyn v+integrate2 dt (Dyn dyn) = Dyn $ D.integrate2 dt dyn++-- | Finds the product of all elements in the event stream.+products :: (Num a) => Evt a -> Evt a+products = scan (*) 1++-- | Monoidal append of all elements in the stream+appends :: (Monoid a) => Evt a -> Evt a+appends (Evt evt) = Evt (D.appends evt)++-- | Monoidal fold for event streams, note that stream have to be finite for+-- the function to complete+folds :: Monoid a => Evt a -> Run a+folds = foldls (<>) mempty++-- | Left fold for event streams, note that stream have to be finite for+-- the function to complete+foldls :: (b -> a -> b) -> b -> Evt a -> Run b+foldls f s (Evt evt) = D.foldls f s evt++-- | Effectful left fold+foldls' :: (b -> a -> Run b) -> b -> Evt a -> Run b+foldls' f s (Evt evt) = D.foldls' f s evt++-- | Right fold for event streams, note that stream have to be finite for+-- the function to complete+foldrs :: (a -> b -> b) -> b -> Evt a -> Run b+foldrs f s (Evt evt) = D.foldrs f s evt++-- | Effectful right fold+foldrs' :: (a -> b -> Run b) -> b -> Evt a -> Run b+foldrs' f s (Evt evt) = D.foldrs' f s evt++-- | Starts event stream process and as callback prints it values.+prints :: (Show a) => Evt a -> Run ()+prints (Evt evt) = D.prints evt++-- | Starts event stream process and as callback prints it values.+putStrLns :: Evt String -> Run ()+putStrLns (Evt evt) = D.putStrLns evt++-- | Queries the event stream form dynamic and runs it all next event streams are ignored.+switchDyn :: Dyn (Evt a) -> Evt a+switchDyn (Dyn dyn) = Evt $ D.switchDyn $ fmap unEvt dyn++-- | Joins event stream of streams. If stream is started it runs until the end.+joins :: Evt (Evt a) -> Evt a+joins (Evt evt) = Evt $ D.joins $ fmap unEvt evt++-- | Recursion on event streams. As event streams are functions we can not use+-- normal recursion that haskell provides. It will stuck the execution.+-- But we can use @fix1@ to create event stream that feeds back the events to itself.+--+-- Note that any sort of recursion can be implemented with @fix1@.+-- For example if we need 3-recursive event stream:+--+--  > fixE3 ::+--  >      (Evt a -> Evt b -> Evt c -> (Evt a, Evt b, Evt c))+--  >   -> (Evt a, Evt b, Evt c)+--+-- we can use sum tpye tags+-- to join it to single stream:+--+-- > data Tag a b c = TagA a | TagB b | TagC c+--+-- > fix3 f = unwrap $ fix1 g+-- >   where+-- >      g x = wrap (f (unwrapA x) (unwrapB x) (unwrapC x))+-- >+-- >      wrap a b c = mconcat [TagA <$> a, TagB <$> b, TagC <$> c]+-- >      unwrap evt = (unwrapA evt, unwrapB evt, unwrapC evt)+-- >+-- >      unwrapA = flip mapMay $ \x -> case x of+-- >                                  TagA a -> Just a+-- >                                  _      -> Nothing+--+-- We can use this trck with any number of streams. There are helper functions: @fix2@, @fix3@, @fix4@+fix1 :: (Evt a -> Run (Evt a)) -> Evt a+fix1 f = Evt $ D.fix1 (fmap unEvt . f . Evt)++-- | Recursion for binary functions+fix2 :: (Evt a -> Evt b -> Run (Evt a, Evt b)) -> (Evt a, Evt b)+fix2 f = bimap Evt Evt $ D.fix2 (\a b -> bimap unEvt unEvt <$> f (Evt a) (Evt b))++-- | Recursion for ternary functions+fix3 ::+     (Evt a -> Evt b -> Evt c -> Run (Evt a, Evt b, Evt c))+  -> (Evt a, Evt b, Evt c)+fix3 f = wrap $ D.fix3 (\a b c -> unwrap <$> f (Evt a) (Evt b) (Evt c))+  where+    wrap (a, b, c) = (Evt a, Evt b, Evt c)+    unwrap (a, b, c) = (unEvt a, unEvt b, unEvt c)++-- | Recursion for functions of four arguments+fix4 ::+     (Evt a -> Evt b -> Evt c -> Evt d -> Run (Evt a, Evt b, Evt c, Evt d))+  -> (Evt a, Evt b, Evt c, Evt d)+fix4 f = wrap $ D.fix4 (\a b c d -> unwrap <$> f (Evt a) (Evt b) (Evt c) (Evt d))+  where+    wrap (a, b, c, d) = (Evt a, Evt b, Evt c, Evt d)+    unwrap (a, b, c, d) = (unEvt a, unEvt b, unEvt c, unEvt d)++-- | Flattens event stream producer by switching between event streams.+-- When next event stream happens it shuts down the previous one.+switch :: Evt (Evt a) -> Evt a+switch (Evt evt) = Evt $ D.switch $ fmap unEvt evt++-- | Switches between dynamic producers.+switchD :: Dyn a -> Evt (Dyn a) -> Dyn a+switchD (Dyn d) (Evt evts) = Dyn $ D.switchD d (fmap unDyn evts)++---------------------------------------------------------+-- channels++-- | Creates the event stream that listens to MVar based channel.+-- If any value is put chan the event stream fires the callback.+mchanEvt :: M.Chan a -> Evt a+mchanEvt mchan = Evt $ D.mchanEvt mchan++-- | Creates the event stream that listens to MVar based channel.+-- If any value is put chan the event stream fires the callback.+tchanEvt :: TChan a -> Evt a+tchanEvt tchan = Evt $ D.tchanEvt tchan++-- | Creates the event stream that listens to unagi channel (package @unagi-chan@).+-- If any value is put chan the event stream fires the callback.+uchanEvt :: InChan a -> Evt a+uchanEvt uchan = Evt $ D.uchanEvt uchan++---------------------------------------------------------------------------+-- utilities++-- | Queries current time periodically with given period in seconds.+clock :: NominalDiffTime -> Evt UTCTime+clock t = Evt $ D.clock t++-- | Produces pulse events with given period in seconds.+pulse :: NominalDiffTime -> Evt ()+pulse t = Evt $ D.pulse t++-- | Produces pulse events with given period in seconds+-- and also tells how many seconds exactly has passed.+-- It can be useful for simulations of models that are based on differential equations.+-- As event streams carries how much time has passed between simulation steps.+ticks :: Float -> Evt Float+ticks t = Evt $ realToFrac <$> D.ticks (realToFrac t)++-- | Timer behaves like tocks only it produces accumulated time since beginning+-- of the process. It calculates them by querying current time and suntracting start time from it.+--+-- It can be though of as:+--+-- > sumE ticks+timer :: Float -> Evt Float+timer t = Evt $ realToFrac <$> D.timer (realToFrac t)++-- | Continuous timeline updated at given interval.+timerD :: Float -> Dyn Float+timerD t = Dyn $ realToFrac <$> D.timerD (realToFrac t)++--------------------------------------------------------------------------------++-- | Substitutes values in event stream with random values.+toRandom :: (Random b) => Evt a -> Evt b+toRandom (Evt evt) = Evt $ D.toRandom evt++-- | Substitutes values in event stream with random values from the given range.+toRandomR :: (Random b) => (b, b) -> Evt a -> Evt b+toRandomR range (Evt evt) = Evt $ D.toRandomR range evt++-- | Substitutes values in event stream with random values.+withRandom :: (Random b) => Evt a -> Evt (b, a)+withRandom (Evt evt) = Evt $ D.withRandom evt++-- | Substitutes values in event stream with random values from the given range.+withRandomR :: Random b => (b, b) -> Evt a -> Evt (b, a)+withRandomR range (Evt evt) = Evt $ D.withRandomR range evt++-- | Picks at random one element from the list+oneOf :: [a] -> Evt b -> Evt a+oneOf xs (Evt evt) = Evt $ D.oneOf xs evt++-- | Picks at random one element from the list+withOneOf :: [a] -> Evt b -> Evt (a, b)+withOneOf xs (Evt evt) = Evt (D.withOneOf xs evt)++-- | Picks at random one element from the list. We also provide distribution of events.+-- Probability to pick up the element. Sum of probabilities should equal to 1.+freqOf :: Dyn [(a, Rational)] -> Evt b -> Evt a+freqOf (Dyn dynVals) (Evt evts) = Evt $ D.freqOf dynVals evts++-- | Picks at random one element from the list. We also provide distribution of events.+-- Probability to pick up the element. Sum of probabilities should equal to 1.+withFreqOf :: Dyn [(a, Rational)] -> Evt b -> Evt (a, b)+withFreqOf (Dyn dynVals) (Evt evts) = Evt $ D.withFreqOf dynVals evts++-- | Skips at random elements from the list. We provide frequency to skip events with dynamic first argument.+randSkip :: Dyn Double -> Evt a -> Evt a+randSkip (Dyn prob) (Evt evt) = Evt $ D.randSkip prob evt++-- | Skips elements at random. The probability to skip element depends on the element itself.+randSkipBy :: Dyn (a -> Double) -> Evt a -> Evt a+randSkipBy  (Dyn prob) (Evt evt) = Evt $ D.randSkipBy prob evt++--------------------------------------------------------------------------------++-- | Delays in the thread of execution. Note that it can interfere+-- and screw up functions like clock, timer, pulse, ticks+delay :: NominalDiffTime -> Evt a -> Evt a+delay dt (Evt evt) = Evt $ D.delay dt evt++-- | Delays in background by forking on each event.+-- Note tht if delayed event was put into background prior+-- to stopping of the main event stream it will fire anyway.+-- There is no way to stop it.+delayFork :: NominalDiffTime -> Evt a -> Evt a+delayFork dt (Evt evt) = Evt $ D.delayFork dt evt++--------------------------------------------------------------------------------+-- effectful functor++class RunFunctor f where+  fmap' :: (a -> Run b) -> f a -> f b++instance RunFunctor Evt where+  fmap' f (Evt evt) = Evt $ D.fmap' f evt++instance RunFunctor Dyn where+  fmap' f (Dyn dyn) = Dyn $ D.fmap' f dyn+
+ src/Dyna/Gloss/Geometry/Line.hs view
@@ -0,0 +1,323 @@+{-# LANGUAGE PatternGuards #-}++-- | Geometric functions concerning lines and segments.+--+--   A @Line@ is taken to be infinite in length, while a @Seg@ is finite length+--   line segment represented by its two endpoints.+module Dyna.Gloss.Geometry.Line+        ( segClearsBox++        -- * Closest points+        , closestPointOnLine+        , closestPointOnLineParam++        -- * Line-Line intersection+        , intersectLineLine++        -- * Seg-Line intersection+        , intersectSegLine+        , intersectSegHorzLine+        , intersectSegVertLine++        -- * Seg-Seg intersection+        , intersectSegSeg+        , intersectSegHorzSeg+        , intersectSegVertSeg)++where+import Dyna.Gloss.Data.Point+import Dyna.Gloss.Data.Vec++-- | Check if line segment (P1-P2) clears a box (P3-P4) by being well outside it.+segClearsBox+        :: Point        -- ^ P1 First point of segment.+        -> Point        -- ^ P2 Second point of segment.+        -> Point        -- ^ P3 Lower left point of box.+        -> Point        -- ^ P4 Upper right point of box.+        -> Bool++segClearsBox (Vec x1 y1) (Vec x2 y2) (Vec xa ya) (Vec xb yb)+        | x1 < xa, x2 < xa      = True+        | x1 > xb, x2 > xb      = True+        | y1 < ya, y2 < ya      = True+        | y1 > yb, y2 > yb      = True+        | otherwise             = False+++-- | Given an infinite line which intersects `P1` and `P1`,+--      return the point on that line that is closest to `P3`+closestPointOnLine+        :: Point        -- ^ `P1`+        -> Point        -- ^ `P2`+        -> Point        -- ^ `P3`+        -> Point        -- ^ the point on the line P1-P2 that is closest to `P3`++{-# INLINE closestPointOnLine #-}++closestPointOnLine p1 p2 p3+        = p1 + (u `mulSV` (p2 - p1))+        where   u       = closestPointOnLineParam p1 p2 p3+++-- | Given an infinite line which intersects P1 and P2,+--      let P4 be the point on the line that is closest to P3.+--+--      Return an indication of where on the line P4 is relative to P1 and P2.+--+-- @+--      if P4 == P1 then 0+--      if P4 == P2 then 1+--      if P4 is halfway between P1 and P2 then 0.5+-- @+--+-- @+--        |+--       P1+--        |+--     P4 +---- P3+--        |+--       P2+--        |+-- @+--+{-# INLINE closestPointOnLineParam #-}+closestPointOnLineParam+        :: Point        -- ^ `P1`+        -> Point        -- ^ `P2`+        -> Point        -- ^ `P3`+        -> Float++closestPointOnLineParam p1 p2 p3+        = (p3 - p1) `dotV` (p2 - p1)+        / (p2 - p1) `dotV` (p2 - p1)++++-- Line-Line intersection -----------------------------------------------------++-- | Given four points specifying two lines, get the point where the two lines+--   cross, if any. Note that the lines extend off to infinity, so the+--   intersection point might not line between either of the two pairs of points.+--+-- @+--     \\      /+--      P1  P4+--       \\ /+--        ++--       / \\+--      P3  P2+--     /     \\+-- @+--+intersectLineLine+        :: Point        -- ^ `P1`+        -> Point        -- ^ `P2`+        -> Point        -- ^ `P3`+        -> Point        -- ^ `P4`+        -> Maybe Point++intersectLineLine (Vec x1 y1) (Vec x2 y2) (Vec x3 y3) (Vec x4 y4)+ = let  dx12    = x1 - x2+        dx34    = x3 - x4++        dy12    = y1 - y2+        dy34    = y3 - y4++        den     = dx12 * dy34  - dy12 * dx34++   in if den == 0+        then Nothing+        else let+                det12   = x1*y2 - y1*x2+                det34   = x3*y4 - y3*x4++                numx    = det12 * dx34 - dx12 * det34+                numy    = det12 * dy34 - dy12 * det34+             in Just (Vec (numx / den) (numy / den))+++-- Segment-Line intersection --------------------------------------------------+-- | Get the point where a segment @P1-P2@ crosses an infinite line @P3-P4@,+--   if any.+--+intersectSegLine+        :: Point        -- ^ `P1`+        -> Point        -- ^ `P2`+        -> Point        -- ^ `P3`+        -> Point        -- ^ `P4`+        -> Maybe Point++intersectSegLine p1 p2 p3 p4+        -- TODO: merge closest point check with intersection, reuse subterms.+        | Just p0       <- intersectLineLine p1 p2 p3 p4+        , t12           <- closestPointOnLineParam p1 p2 p0+        , t12 >= 0 && t12 <= 1+        = Just p0++        | otherwise+        = Nothing+++-- | Get the point where a segment crosses a horizontal line, if any.+--+-- @+--                + P1+--               /+--       -------+---------+--             /        y0+--         P2 ++-- @+--+intersectSegHorzLine+        :: Point        -- ^ P1 First point of segment.+        -> Point        -- ^ P2 Second point of segment.+        -> Float        -- ^ y value of line.+        -> Maybe Point+intersectSegHorzLine (Vec x1 y1) (Vec x2 y2) y0++        -- seg is on line+        | y1 == y0, y2 == y0    = Nothing++        -- seg is above line+        | y1 > y0,  y2 > y0     = Nothing++        -- seg is below line+        | y1 < y0,  y2 < y0     = Nothing++        -- seg is a single point on the line.+        -- this should be caught by the first case,+        -- but we'll test for it anyway.+        | y2 - y1 == 0+        = Just (Vec x1 y1)++        | otherwise+        = Just (Vec ((y0 - y1) * (x2 - x1) / (y2 - y1) + x1)+                y0)++++-- | Get the point where a segment crosses a vertical line, if any.+--+-- @+--              |+--              |   + P1+--              | /+--              ++--            / |+--       P2 +   |+--              | x0+-- @+--+intersectSegVertLine+        :: Point        -- ^ P1 First point of segment.+        -> Point        -- ^ P2 Second point of segment.+        -> Float        -- ^ x value of line.+        -> Maybe Point++intersectSegVertLine (Vec x1 y1) (Vec x2 y2) x0++        -- seg is on line+        | x1 == x0, x2 == x0    = Nothing++        -- seg is to right of line+        | x1 > x0,  x2 > x0     = Nothing++        -- seg is to left of line+        | x1 < x0,  x2 < x0     = Nothing++        -- seg is a single point on the line.+        -- this should be caught by the first case,+        -- but we'll test for it anyway.+        | x2 - x1 == 0+        = Just (Vec x1 y1)++        | otherwise+        = Just (Vec x0+               ((x0 - x1) * (y2 - y1) / (x2 - x1) + y1))+++-- Segment-Segment intersection -----------------------------------------------++-- | Get the point where a segment @P1-P2@ crosses another segement @P3-P4@,+--   if any.+intersectSegSeg+        :: Point        -- ^ `P1`+        -> Point        -- ^ `P2`+        -> Point        -- ^ `P3`+        -> Point        -- ^ `P4`+        -> Maybe Point++intersectSegSeg p1 p2 p3 p4+        -- TODO: merge closest point checks with intersection, reuse subterms.+        | Just p0       <- intersectLineLine p1 p2 p3 p4+        , t12           <- closestPointOnLineParam p1 p2 p0+        , t23           <- closestPointOnLineParam p3 p4 p0+        , t12 >= 0 && t12 <= 1+        , t23 >= 0 && t23 <= 1+        = Just p0++        | otherwise+        = Nothing+++-- | Check if an arbitrary segment intersects a horizontal segment.+--+-- @+--                 + P2+--                /+-- (xa, y3)  +---+----+ (xb, y3)+--              /+--          P1 ++-- @++intersectSegHorzSeg+        :: Point        -- ^ P1 First point of segment.+        -> Point        -- ^ P2 Second point of segment.+        -> Float        -- ^ (y3) y value of horizontal segment.+        -> Float        -- ^ (xa) Leftmost x value of horizontal segment.+        -> Float        -- ^ (xb) Rightmost x value of horizontal segment.+        -> Maybe Point  -- ^ (x3, y3) Intersection point, if any.++intersectSegHorzSeg p1@(Vec x1 y1) p2@(Vec x2 y2) y0 xa xb+        | segClearsBox p1 p2 (Vec xa y0) (Vec xb y0)+        = Nothing++        | x0 < xa       = Nothing+        | x0 > xb       = Nothing+        | otherwise     = Just (Vec x0 y0)++        where x0 | (y2 - y1) == 0 = x1+                 | otherwise      = (y0 - y1) * (x2 - x1) / (y2 - y1) + x1+++-- | Check if an arbitrary segment intersects a vertical segment.+--+-- @+--      (x3, yb) ++--               |   + P1+--               | /+--               ++--             / |+--        P2 +   |+--               + (x3, ya)+-- @++intersectSegVertSeg+        :: Point        -- ^ P1 First point of segment.+        -> Point        -- ^ P2 Second point of segment.+        -> Float        -- ^ (x3) x value of vertical segment+        -> Float        -- ^ (ya) Lowest y value of vertical segment.+        -> Float        -- ^ (yb) Highest y value of vertical segment.+        -> Maybe Point  -- ^ (x3, y3) Intersection point, if any.++intersectSegVertSeg p1@(Vec x1 y1) p2@(Vec x2 y2) x0 ya yb+        | segClearsBox p1 p2 (Vec x0 ya) (Vec x0 yb)+        = Nothing++        | y0 < ya       = Nothing+        | y0 > yb       = Nothing+        | otherwise     = Just (Vec x0 y0)++        where y0 | (x2 - x1) == 0 = y1+                 | otherwise      = (x0 - x1) * (y2 - y1) / (x2 - x1) + y1+
+ src/Dyna/Gloss/Run.hs view
@@ -0,0 +1,208 @@+-- | Run the game application.+module Dyna.Gloss.Run(+  -- * App execution+  Run,+  Spec(..),+  defSpec,+  runApp,+  -- * IO interface+  mouse,+  mouseV,+  isDrag,+  drag,+  dragV,+  mouseA,+  mouseRight,+  mouseLeft,+  mouseWheel,+  Click(..),+  getClicks,+  getFrames,+  getResize,+  keyUp, keyDown,+  charUp, charDown,+  -- * Re-exports+  Key(..),+  SpecialKey(..),+  MouseButton(..),+  KeyState(..),+  Modifiers(..),+) where++import Control.Exception.Lifted+import Control.Concurrent.Chan.Unagi qualified as U+import Control.Monad.Reader+import Data.IORef++import Graphics.Gloss+import Graphics.Gloss.Interface.IO.Game+import Dyna qualified as D+import Dyna.Gloss.Types+import Dyna.Gloss.Data.Vec++-- | Initial parameters for the Game.+data Spec = Spec+  { spec'display    :: Display   -- ^ display settings+  , spec'background :: Color     -- ^ background color to clear each frame+  , spec'steps      :: Int       -- ^ number of steps for simulation+  }++-- | Default settings. Runs in ullscreen mode.+defSpec :: Spec+defSpec = Spec FullScreen white 1++-- | Run the aplication. It accepts initial settings+-- and the dynamic value of pictures wrapped in the Run monad.+--+-- Note that to work properly we need to compile to executable with+-- options -O2 and -threaded. The function does not work in ghci or with runhaskell+-- because it requires support for multiple threads.+--+-- Define the application with the Main module. Then compie it:+--+-- > stack exec -- ghc -O2 -threaded dyna-gloss/examples/Ball.hs+--+-- And run the result:+--+-- > 	./dyna-gloss/examples/Ball+--+-- How it works? It runs the dynamic process at the background thread and+-- every time the gloss function requests new frame it takes a snapshot of the current+-- value of the main dynamic process which produces pictures. It's exactly what gloss+-- simulation function needs to render it on the screen.+runApp :: Spec -> Run (Dyn Picture) -> IO ()+runApp Spec{..} dynAct = do+  env <- newEnv+  ref <- runReaderT (unRun $ D.runDyn . unDyn =<< dynAct) env+  playIO spec'display spec'background spec'steps ref (draw env) (onEvents env) (onIterate env)+    `finally` (runReaderT (unRun $ D.cancelDyn ref) env)+  where+    draw env ref = runReaderT (unRun $ D.readDyn ref) env++    onEvents Env{..} evt ref = do+      case evt of+        EventResize sizes      -> U.writeChan (fst env'resizeChan) sizes+        EventMotion (x, y)     -> do+          let pos = Vec x y+          prevPos  <- readIORef env'mousePos+          prevDif1 <- readIORef env'mouseDif1+          let dif1 = pos - prevPos+          writeIORef env'mousePos pos+          writeIORef env'mouseDif1 dif1+          writeIORef env'mouseDif2 (dif1 - prevDif1)+        EventKey k st mods pos -> U.writeChan (fst env'keyChan) (Click k st mods (fromTuple pos))+      pure ref++    onIterate Env{..} time ref = do+      U.writeChan (fst env'frameChan) time+      pure ref++----------------------------------------------------------------++-- | Read mouse positions. It produces dynamic of vectors. @(0, 0)@ is a center of the screen.+mouse :: Dyn Vec+mouse = Dyn $ D.constDyn $ do+  ref <- asks env'mousePos+  liftIO $ readIORef ref++-- | Mouse velocity or displacement+mouseV :: Dyn Vec+mouseV = Dyn $ D.constDyn $ do+  ref <- asks env'mouseDif1+  liftIO $ readIORef ref++-- | Mouse accelartion or speed of displacement+mouseA :: Dyn Vec+mouseA = Dyn $ D.constDyn $ do+  ref <- asks env'mouseDif2+  liftIO $ readIORef ref++isDrag :: MouseButton -> Dyn Bool+isDrag btn = Dyn $ D.scanD collect False $ D.mapMay go $ unEvt getClicks+  where+    go (Click key st mods pos) = case key of+      MouseButton mbtn | mbtn == btn -> Just st+      _                              -> Nothing++    collect a st = case a of+      Up   -> False+      Down -> True+++-- | Displacement on drag, if no drag it becomes zero+dragV :: MouseButton -> Dyn Vec+dragV btn = (\x -> if x then id else const 0) <$> isDrag btn <*> mouseV++-- | Position of the mouse during drag, if no drag it becomes zero+drag :: MouseButton -> Dyn Vec+drag btn = (\x -> if x then id else const 0) <$> isDrag btn <*> mouse++-- | Event stream of clicks of the mouse right button+mouseRight :: Evt Vec+mouseRight = Evt $ D.mapMay go $ unEvt getClicks+  where+    go = \case+      Click (MouseButton RightButton) Down mods pos -> Just pos+      _                                             -> Nothing++-- | Event stream of key up actions+keyUp :: Key -> Evt Modifiers+keyUp = keyBy Up++-- | Event stream of key down actions+keyDown :: Key -> Evt Modifiers+keyDown = keyBy Down++-- | Event stream of char press up actions+charUp :: Char -> Evt Modifiers+charUp = keyUp . Char++-- | Event stream of char press down actions+charDown :: Char -> Evt Modifiers+charDown = keyDown . Char++keyBy :: KeyState -> Key -> Evt Modifiers+keyBy st' key' = Evt $ D.mapMay go $ unEvt getClicks+  where+    go (Click key st mods pos)+      | key == key' && st == st' = Just mods+      | otherwise                = Nothing++-- | Event stream of clicks of the mouse left button+mouseLeft :: Evt Vec+mouseLeft = Evt $ D.mapMay go $ unEvt getClicks+  where+    go = \case+      Click (MouseButton LeftButton) Down mods pos -> Just pos+      _                                            -> Nothing++-- | Mouse wheel displacement.+-- If positive then it goes up, if negative then it goes down.+mouseWheel :: Evt Float+mouseWheel = Evt $ D.mapMay go $ unEvt getClicks+  where+    go (Click key st mods pos) = case key of+      MouseButton WheelUp   -> Just 1+      MouseButton WheelDown -> Just (-1)+      _                     -> Nothing++-- | Reads generic click events+getClicks :: Evt Click+getClicks = Evt $ D.Evt $ \go -> do+  keyChan <- asks env'keyChan+  D.runEvt (D.uchanEvt (fst keyChan)) go++-- | Reads frame updates. Value of the event is a time that has passed since the previous frame.+--+-- Note that if we want to use the sort of event stream as a timeline for the game or simulation+-- we can also use time utilities from the FRP library: @clock@, @pulse@, @ticks@, @timer@.+getFrames :: Evt Float+getFrames = Evt $ D.Evt $ \go -> do+  frameChan <- asks env'frameChan+  D.runEvt (D.uchanEvt (fst frameChan)) go++-- | Reads window resize events+getResize :: Evt (Int, Int)+getResize = Evt $ D.Evt $ \go -> do+  resizeChan <- asks env'resizeChan+  D.runEvt (D.uchanEvt $ fst resizeChan) go
+ src/Dyna/Gloss/Types.hs view
@@ -0,0 +1,165 @@+-- | Types of the gloss application+module Dyna.Gloss.Types(+  Run(..),+  Evt(..),+  Dyn(..),+  Env(..),+  newEnv,+  Click(..),+) where++import Prelude hiding ((<*))+import Control.Applicative (liftA2, liftA3)+import Control.Concurrent.Chan.Unagi+import Control.Monad.Reader+import Control.Monad.Base+import Control.Monad.Random.Class+import Control.Monad.Trans.Control (MonadBaseControl(..))+import Data.IORef+import Data.String+import Data.Boolean+import Data.AdditiveGroup+import Data.AffineSpace+import Data.VectorSpace+import Data.Basis+import Data.Cross+import Temporal.Class++import Graphics.Gloss+import Graphics.Gloss.Interface.IO.Game++import Dyna qualified as D+import Dyna.Gloss.Data.Vec++-- | Monad that drives the application+newtype Run a = Run { unRun :: ReaderT Env IO a }+  deriving (Functor, Applicative, Monad, MonadReader Env, MonadIO, MonadBase IO, MonadRandom)++newtype StMRun a = StMRun { unStMRun :: StM (ReaderT Env IO) a }++instance MonadBaseControl IO Run where+    type StM Run a = StMRun a+    liftBaseWith f = Run $ liftBaseWith $ \q -> f (fmap StMRun . q . unRun)+    restoreM = Run . restoreM . unStMRun++instance D.Frp Run where+  type Ref Run = IORef++-------------------------------------------------------------------------------+-- FRP type wrappers++-- | Event stream. The meaning of an event is a callback consumer function.+-- If we give callback to it it will do something useful based on it.+--+-- The main function is runEvt:+--+-- > runEvt :: Evt m a -> (a -> m ()) -> m ()+-- > runEvt events callback = ...+--+-- Let's look at simple examples of the event streams:+--+-- Event that never produce anything:+--+-- > never = Evt {+-- >    runEvt _ = pure ()+-- >  }+--+-- So it just ignores the callback and returns right away.+--+-- Event that happens only once:+--+-- > once :: m a -> Evt m a+-- > once get = Evt {+-- >     runEvt go = go =<< get+-- >  }+--+-- It just gets the value right away and applies callback to it.+-- We can try it out in the interpreter:+--+-- > putStrLnE $ fmap ("Your message: " <> ) $ once getLine+--+-- We have useful functions to print out the events: @putStrLnE@ and @printE@.+--+-- Also we have event streams that happen periodically:+--+-- > printE $ clock 1  -- prints time every second+--+-- ## Duplication of the events.+--+-- Note that event streams are functions that do side-effects within some monad.+-- We use them as values but it means that two values with the same event stream definition+-- can produce different results. For example:+--+-- > a = toRandomR (0, 10) $ clock 1+-- > b = a+--+-- Note that a and b will each have their own copy of underlying random event stream.+-- So if you use it in the code don't expect values to be the same.+--+-- But if we want them to be the same we can copy event from it's definition with function:+--+-- > newEvt :: Evt m a -> m (Evt m a)+--+-- It starts the underying event stream process n background and sends all events+-- to the result by channel. With nice property of when we shut down the result event the+-- background process also shuts down.+--+-- > a <- newEvt toRandomR (0, 10) $ clock 1+-- > b = a+--+-- In this example event streams @a@ and @b@ will have the same events during execution.+newtype Evt a = Evt { unEvt :: D.Evt Run a }+  deriving (Functor, Semigroup, Monoid, Applicative, Monad, Melody, Harmony, Compose, Loop)++type instance DurOf (Evt a) = Float++instance Limit (Evt a) where+  lim t (Evt evt) = Evt $ lim (realToFrac t) evt++-- | Dynamic step-wise continuous process+newtype Dyn a = Dyn { unDyn :: D.Dyn Run a }+  deriving (Functor, Applicative, Num, Fractional, Semigroup, Monoid, IsString,+            Boolean, AdditiveGroup, VectorSpace, HasNormal, HasCross2, HasCross3, AffineSpace, HasBasis)++type instance BooleanOf (Dyn a) = Dyn (BooleanOf a)++instance (IfB a) => IfB (Dyn a) where+  ifB = liftA3 ifB++instance (EqB a) => EqB (Dyn a) where+  (==*) = liftA2 (==*)++instance (OrdB a) => OrdB (Dyn a) where+  (<*) = liftA2 (<*)+  (>*) = liftA2 (>*)+  (<=*) = liftA2 (<=*)+  (>=*) = liftA2 (>=*)++-------------------------------------------------------------------------------++-- | All sorts of clicks+data Click = Click Key KeyState Modifiers Vec++-- | Applicaition environment+data Env = Env+  { env'frameChan   :: D.UChan Float+  , env'eventChan   :: D.UChan Event+  , env'resizeChan  :: D.UChan (Int, Int)+  , env'keyChan     :: D.UChan Click+  , env'mousePos    :: IORef Vec+  , env'mouseDif1   :: IORef Vec+  , env'mouseDif2   :: IORef Vec+  }++-- | Create new environment+newEnv :: IO Env+newEnv = do+  env'frameChan <- newChan+  env'eventChan <- newChan+  env'resizeChan <- newChan+  env'keyChan <- newChan+  env'mousePos <- newIORef (Vec 0 0)+  env'mouseDif1 <- newIORef (Vec 0 0)+  env'mouseDif2 <- newIORef (Vec 0 0)+  pure Env{..}+
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"