packages feed

gore-and-ash (empty) → 1.1.0.1

raw patch · 25 files changed

+3466/−0 lines, 25 filesdep +basedep +containersdep +deepseqsetup-changed

Dependencies added: base, containers, deepseq, exceptions, hashable, linear, mtl, parallel, profunctors, random, semigroups, time, transformers, unordered-containers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Gushcha Anton (c) 2015-2016++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  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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ gore-and-ash.cabal view
@@ -0,0 +1,83 @@+name:                gore-and-ash+version:             1.1.0.1+synopsis:            Core of FRP game engine called Gore&Ash+description:         Please see README.md+homepage:            https://github.com/Teaspot-Studio/gore-and-ash+license:             BSD3+license-file:        LICENSE+author:              Anton Gushcha, Levon Oganyan+maintainer:          ncrashed@gmail.com+copyright:           2015-2016 Anton Gushcha+                   , 2016 Levon Oganyan+                   , 2014-2016 Ertugrul Soeylemez+category:            Game+build-type:          Simple+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     +                      Control.Wire+                      Control.Wire.Core+                      Control.Wire.Event+                      Control.Wire.Interval+                      Control.Wire.Run+                      Control.Wire.Session+                      Control.Wire.Switch+                      Control.Wire.Time+                      Control.Wire.Unsafe.Event+                      Data.Filterable+                      FRP.Netwire+                      FRP.Netwire.Analyze+                      FRP.Netwire.Move+                      FRP.Netwire.Noise+                      FRP.Netwire.Utils.Timeline+                      Game.GoreAndAsh+                      Game.GoreAndAsh.Core+                      Game.GoreAndAsh.Core.Arrow+                      Game.GoreAndAsh.Core.Monad+                      Game.GoreAndAsh.Core.Session+                      Game.GoreAndAsh.Core.State+                      Game.GoreAndAsh.Math++  default-language:    Haskell2010+  build-depends:       base >= 4.7 && < 5+                     , containers >= 0.5.6.2+                     , deepseq >= 1.4+                     , exceptions >= 0.8.0.2+                     , hashable >= 1.2.3.3+                     , linear >= 1.20.3+                     , mtl >= 2.2+                     , parallel >= 3.2+                     , profunctors >= 4.3+                     , random >= 1.1+                     , semigroups >= 0.15+                     , time >= 1.5.0.1+                     , transformers >= 0.4+                     , unordered-containers >= 0.2.5.1++  default-extensions:  +                      Arrows+                      DataKinds+                      DeriveDataTypeable+                      DeriveFoldable+                      DeriveFunctor+                      DeriveGeneric+                      DeriveTraversable+                      FlexibleContexts+                      FlexibleInstances+                      FunctionalDependencies+                      GADTs+                      GeneralizedNewtypeDeriving+                      MultiParamTypeClasses+                      RankNTypes+                      RecordWildCards+                      ScopedTypeVariables+                      TupleSections+                      TypeFamilies+                      TypeOperators+                      UndecidableInstances+                      +source-repository head+  type:     git+  location: https://github.com/Teaspot-Studio/gore-and-ash.git
+ src/Control/Wire.hs view
@@ -0,0 +1,53 @@+-- |+-- Module:     Control.Wire+-- Copyright:  (c) 2013 Ertugrul Soeylemez+-- License:    BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>++module Control.Wire+    ( -- * Reexports+      module Control.Wire.Core,+      module Control.Wire.Event,+      module Control.Wire.Interval,+      module Control.Wire.Run,+      module Control.Wire.Session,+      module Control.Wire.Switch,+      module Control.Wire.Time,++      -- * Convenient type aliases+      WireP,+      SimpleWire,++      -- * External+      module Control.Applicative,+      module Control.Arrow,+      module Control.Category,+      module Data.Semigroup,+      Identity(..),+      NominalDiffTime+    )+    where++import Control.Applicative+import Control.Arrow+import Control.Category+import Control.Wire.Core+import Control.Wire.Event+import Control.Wire.Interval+import Control.Wire.Run+import Control.Wire.Session+import Control.Wire.Switch+import Control.Wire.Time+import Data.Functor.Identity+import Data.Semigroup+import Data.Time.Clock+++-- | Pure wires.++type WireP s e = Wire s e Identity+++-- | Simple wires with time.++type SimpleWire = Wire (Timed NominalDiffTime ()) () Identity
+ src/Control/Wire/Core.hs view
@@ -0,0 +1,470 @@+-- |+-- Module:     Control.Wire.Core+-- Copyright:  (c) 2013 Ertugrul Soeylemez+-- License:    BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>++module Control.Wire.Core+    ( -- * Wires+      Wire(..),+      stepWire,++      -- * Constructing wires+      mkConst,+      mkEmpty,+      mkGen,+      mkGen_,+      mkGenN,+      mkId,+      mkPure,+      mkPure_,+      mkPureN,+      mkSF,+      mkSF_,+      mkSFN,++      -- * Data flow and dependencies+      delay,+      evalWith,+      force,+      forceNF,++      -- * Utilities+      (&&&!),+      (***!),+      lstrict,+      mapWire+    )+    where++import qualified Data.Semigroup as Sg+import Control.Applicative+import Control.Arrow+import Control.Category+import Control.DeepSeq hiding (force)+import Control.Monad+import Control.Monad.Fix+import Control.Parallel.Strategies+import Data.Profunctor+import Data.Monoid+import Data.String+import Prelude hiding ((.), id)+++-- | A wire is a signal function.  It maps a reactive value to another+-- reactive value.++data Wire s e m a b where+    WArr   :: (Either e a -> Either e b) -> Wire s e m a b+    WConst :: Either e b -> Wire s e m a b+    WGen   :: (s -> Either e a -> m (Either e b, Wire s e m a b)) -> Wire s e m a b+    WId    :: Wire s e m a a+    WPure  :: (s -> Either e a -> (Either e b, Wire s e m a b)) -> Wire s e m a b++instance (Monad m, Monoid e) => Alternative (Wire s e m a) where+    empty = WConst (Left mempty)++    w1@(WConst (Right _)) <|> _ = w1+    w1@WId <|> _ = w1++    WConst (Left ex) <|> w2 = mapLeft (ex <>) w2++    w1' <|> w2' =+        WGen $ \ds mx' ->+            liftM2 (\(mx1, w1) (mx2, w2) -> lstrict (choose mx1 mx2, w1 <|> w2))+                   (stepWire w1' ds mx')+                   (stepWire w2' ds mx')++        where+        choose mx1@(Right _) _       = mx1+        choose _ mx2@(Right _)       = mx2+        choose (Left ex1) (Left ex2) = Left (ex1 <> ex2)++instance (Monad m) => Applicative (Wire s e m a) where+    pure = WConst . Right++    wf' <*> wx' =+        WGen $ \ds mx' ->+            liftM2 (\(mf, wf) (mx, wx) -> lstrict (mf <*> mx, wf <*> wx))+                   (stepWire wf' ds mx')+                   (stepWire wx' ds mx')++instance (Monad m) => Arrow (Wire s e m) where+    arr f = WArr (fmap f)++    first w' =+        WGen $ \ds mxy' ->+            liftM (\(mx, w) -> lstrict (liftA2 (,) mx (fmap snd mxy'), first w))+                  (stepWire w' ds (fmap fst mxy'))++instance (Monad m, Monoid e) => ArrowChoice (Wire s e m) where+    left w' =+        WGen $ \ds mmx' ->+            liftM (fmap Left ***! left) .+            stepWire w' ds $+            case mmx' of+              Right (Left x)  -> Right x+              Right (Right _) -> Left mempty+              Left ex         -> Left ex++    right w' =+        WGen $ \ds mmx' ->+            liftM (fmap Right ***! right) .+            stepWire w' ds $+            case mmx' of+              Right (Right x)  -> Right x+              Right (Left _)   -> Left mempty+              Left ex          -> Left ex++    wl' +++ wr' =+        WGen $ \ds mmx' ->+            case mmx' of+              Right (Left x) -> do+                  liftM2 (\(mx, wl) (_, wr) -> lstrict (fmap Left mx, wl +++ wr))+                         (stepWire wl' ds (Right x))+                         (stepWire wr' ds (Left mempty))+              Right (Right x) -> do+                  liftM2 (\(_, wl) (mx, wr) -> lstrict (fmap Right mx, wl +++ wr))+                         (stepWire wl' ds (Left mempty))+                         (stepWire wr' ds (Right x))+              Left ex ->+                  liftM2 (\(_, wl) (_, wr) -> lstrict (Left ex, wl +++ wr))+                         (stepWire wl' ds (Left ex))+                         (stepWire wr' ds (Left ex))++    wl' ||| wr' =+        WGen $ \ds mmx' ->+            case mmx' of+              Right (Left x) -> do+                  liftM2 (\(mx, wl) (_, wr) -> lstrict (mx, wl ||| wr))+                         (stepWire wl' ds (Right x))+                         (stepWire wr' ds (Left mempty))+              Right (Right x) -> do+                  liftM2 (\(_, wl) (mx, wr) -> lstrict (mx, wl ||| wr))+                         (stepWire wl' ds (Left mempty))+                         (stepWire wr' ds (Right x))+              Left ex ->+                  liftM2 (\(_, wl) (_, wr) -> lstrict (Left ex, wl ||| wr))+                         (stepWire wl' ds (Left ex))+                         (stepWire wr' ds (Left ex))++instance (MonadFix m) => ArrowLoop (Wire s e m) where+    loop w' =+        WGen $ \ds mx' ->+            liftM (fmap fst ***! loop) .+            mfix $ \ ~(mx, _) ->+                let d | Right (_, d') <- mx = d'+                      | otherwise = error "Feedback broken by inhibition"+                in stepWire w' ds (fmap (, d) mx')++instance (Monad m, Monoid e) => ArrowPlus (Wire s e m) where+    (<+>) = (<|>)++instance (Monad m, Monoid e) => ArrowZero (Wire s e m) where+    zeroArrow = empty++instance (Monad m) => Category (Wire s e m) where+    id = WId++    w2' . w1' =+        WGen $ \ds mx0 -> do+            (mx1, w1) <- stepWire w1' ds mx0+            (mx2, w2) <- stepWire w2' ds mx1+            mx2 `seq` return (mx2, w2 . w1)++instance (Monad m, Monoid e) => Choice (Wire s e m) where+  left' = left+  right' = right++instance (Monad m, Floating b) => Floating (Wire s e m a b) where+    (**) = liftA2 (**)+    acos = fmap acos+    acosh = fmap acosh+    asin = fmap asin+    asinh = fmap asinh+    atan = fmap atan+    atanh = fmap atanh+    cos = fmap cos+    cosh = fmap cosh+    exp = fmap exp+    log = fmap log+    logBase = liftA2 logBase+    pi = pure pi+    sin = fmap sin+    sinh = fmap sinh+    sqrt = fmap sqrt+    tan = fmap tan+    tanh = fmap tanh++instance (Monad m, Fractional b) => Fractional (Wire s e m a b) where+    (/)   = liftA2 (/)+    recip = fmap recip+    fromRational = pure . fromRational++instance (Monad m) => Functor (Wire s e m a) where+    fmap f (WArr g)    = WArr (fmap f . g)+    fmap f (WConst mx) = WConst (fmap f mx)+    fmap f (WGen g)    = WGen (\ds -> liftM (fmap f ***! fmap f) . g ds)+    fmap f WId         = WArr (fmap f)+    fmap f (WPure g)   = WPure (\ds -> (fmap f ***! fmap f) . g ds)++instance (Monad m, IsString b) => IsString (Wire s e m a b) where+    fromString = pure . fromString++instance (Monad m, Monoid b) => Monoid (Wire s e m a b) where+    mempty = pure mempty+    mappend = liftA2 mappend++instance (Monad m, Num b) => Num (Wire s e m a b) where+    (+) = liftA2 (+)+    (-) = liftA2 (-)+    (*) = liftA2 (*)+    abs    = fmap abs+    negate = fmap negate+    signum = fmap signum+    fromInteger = pure . fromInteger++instance (Monad m) => Profunctor (Wire s e m) where+    dimap f g (WArr h)    = WArr (fmap g . h . fmap f)+    dimap _ g (WConst mx) = WConst (fmap g mx)+    dimap f g (WGen h)    = WGen (\ds -> liftM (fmap g ***! dimap f g) . h ds . fmap f)+    dimap f g WId         = WArr (fmap (g . f))+    dimap f g (WPure h)   = WPure (\ds -> (fmap g ***! dimap f g) . h ds . fmap f)++    lmap f (WArr g)       = WArr (g . fmap f)+    lmap _ (WConst mx)    = WConst mx+    lmap f (WGen g)       = WGen (\ds -> liftM (fmap (lmap f)) . g ds . fmap f)+    lmap f WId            = WArr (fmap f)+    lmap f (WPure g)      = WPure (\ds -> fmap (lmap f) . g ds . fmap f)++    rmap = fmap++instance (Monad m, Sg.Semigroup b) => Sg.Semigroup (Wire s e m a b) where+    (<>) = liftA2 (Sg.<>)++instance (Monad m, Monoid e) => Strong (Wire s e m) where+  first' = first+  second' = second+++-- | Left-strict version of '&&&' for functions.++(&&&!) :: (a -> b) -> (a -> c) -> (a -> (b, c))+(&&&!) f g x' =+    let (x, y) = (f x', g x')+    in x `seq` (x, y)+++-- | Left-strict version of '***' for functions.++(***!) :: (a -> c) -> (b -> d) -> ((a, b) -> (c, d))+(***!) f g (x', y') =+    let (x, y) = (f x', g y')+    in x `seq` (x, y)+++-- | This wire delays its input signal by the smallest possible+-- (semantically infinitesimal) amount of time.  You can use it when you+-- want to use feedback ('Arrowloop''):  If the user of the feedback+-- depends on /now/, delay the value before feeding it back.  The+-- argument value is the replacement signal at the beginning.+--+-- * Depends: before now.++delay :: a -> Wire s e m a a+delay x' = mkSFN $ \x -> (x', delay x)+++-- | Evaluate the input signal using the given 'Strategy' here.  This+-- wire evaluates only produced values.+--+-- * Depends: now.++evalWith :: Strategy a -> Wire s e m a a+evalWith s =+    WArr $ \mx ->+        case mx of+          Right x -> (x `using` s) `seq` mx+          Left _  -> mx+++-- | Force the input signal to WHNF here.  This wire forces both+-- produced values and inhibition values.+--+-- * Depends: now.++force :: Wire s e m a a+force =+    WArr $ \mx ->+        case mx of+          Right x -> x `seq` mx+          Left ex -> ex `seq` mx+++-- | Force the input signal to NF here.  This wire forces only produced+-- values.+--+-- * Depends: now.++forceNF :: (NFData a) => Wire s e m a a+forceNF =+    WArr $ \mx ->+        case mx of+          Right x -> x `deepseq` mx+          Left _  -> mx+++-- | Left-strict tuple.++lstrict :: (a, b) -> (a, b)+lstrict (x, y) = x `seq` (x, y)+++-- | Apply the given function to the wire's inhibition value.++mapLeft :: (Monad m) => (e -> e) -> Wire s e m a b -> Wire s e m a b+mapLeft _ w1@WId = w1+mapLeft f' w = mapOutput f w+    where+    f (Left ex) = Left (f' ex)+    f (Right x) = Right x+++-- | Apply the given function to the wire's output.++mapOutput :: (Monad m) => (Either e b' -> Either e b) -> Wire s e m a b' -> Wire s e m a b+mapOutput f (WArr g)    = WArr (f . g)+mapOutput f (WConst mx) = WConst (f mx)+mapOutput f (WGen g)    = WGen (\ds -> liftM (f *** mapOutput f) . g ds)+mapOutput f WId         = WArr f+mapOutput f (WPure g)   = WPure (\ds -> (f *** mapOutput f) . g ds)+++-- | Apply the given monad morphism to the wire's underlying monad.++mapWire ::+    (Monad m', Monad m)+    => (forall a'. m' a' -> m a')+    -> Wire s e m' a b+    -> Wire s e m a b+mapWire _ (WArr g)    = WArr g+mapWire _ (WConst mx) = WConst mx+mapWire f (WGen g)    = WGen (\ds -> liftM (lstrict . second (mapWire f)) . f . g ds)+mapWire _ WId         = WId+mapWire f (WPure g)   = WPure (\ds -> lstrict . second (mapWire f) . g ds)+++-- | Construct a stateless wire from the given signal mapping function.++mkConst :: Either e b -> Wire s e m a b+mkConst = WConst+++-- | Construct the empty wire, which inhibits forever.++mkEmpty :: (Monoid e) => Wire s e m a b+mkEmpty = mkConst (Left mempty)+++-- | Construct a stateful wire from the given transition function.++mkGen :: (Monad m, Monoid s) => (s -> a -> m (Either e b, Wire s e m a b)) -> Wire s e m a b+mkGen f = loop' mempty+    where+    loop' s' =+        WGen $ \ds mx ->+            let s = s' <> ds in+            s `seq`+            case mx of+              Left ex  -> return (Left ex, loop' s)+              Right x' -> liftM lstrict (f s x')+++-- | Construct a stateless wire from the given transition function.++mkGen_ :: (Monad m) => (a -> m (Either e b)) -> Wire s e m a b+mkGen_ f = loop'+    where+    loop' =+        WGen $ \_ mx ->+            case mx of+              Left ex -> return (Left ex, loop')+              Right x -> liftM (lstrict . (, loop')) (f x)+++-- | Construct a stateful wire from the given transition function.++mkGenN :: (Monad m) => (a -> m (Either e b, Wire s e m a b)) -> Wire s e m a b+mkGenN f = loop'+    where+    loop' =+        WGen $ \_ mx ->+            case mx of+              Left ex  -> return (Left ex, loop')+              Right x' -> liftM lstrict (f x')+++-- | Construct the identity wire.++mkId :: Wire s e m a a+mkId = WId+++-- | Construct a pure stateful wire from the given transition function.++mkPure :: (Monoid s) => (s -> a -> (Either e b, Wire s e m a b)) -> Wire s e m a b+mkPure f = loop' mempty+    where+    loop' s' =+        WPure $ \ds mx ->+            let s = s' <> ds in+            s `seq`+            case mx of+              Left ex  -> (Left ex, loop' s)+              Right x' -> lstrict (f s x')+++-- | Construct a pure stateless wire from the given transition function.++mkPure_ :: (a -> Either e b) -> Wire s e m a b+mkPure_ f = WArr $ (>>= f)+++-- | Construct a pure stateful wire from the given transition function.++mkPureN :: (a -> (Either e b, Wire s e m a b)) -> Wire s e m a b+mkPureN f = loop'+    where+    loop' =+        WPure $ \_ mx ->+            case mx of+              Left ex  -> (Left ex, loop')+              Right x' -> lstrict (f x')+++-- | Construct a pure stateful wire from the given signal function.++mkSF :: (Monoid s) => (s -> a -> (b, Wire s e m a b)) -> Wire s e m a b+mkSF f = mkPure (\ds -> lstrict . first (Right) . f ds)+++-- | Construct a pure stateless wire from the given function.++mkSF_ :: (a -> b) -> Wire s e m a b+mkSF_ f = WArr (fmap f)+++-- | Construct a pure stateful wire from the given signal function.++mkSFN :: (a -> (b, Wire s e m a b)) -> Wire s e m a b+mkSFN f = mkPureN (lstrict . first (Right) . f)+++-- | Perform one step of the given wire.++stepWire :: (Monad m) => Wire s e m a b -> s -> Either e a -> m (Either e b, Wire s e m a b)+stepWire w@(WArr f)    _  mx' = return (f mx', w)+stepWire w@(WConst mx) _  mx' = return (mx' *> mx, w)+stepWire (WGen f)      ds mx' = f ds mx'+stepWire w@WId         _  mx' = return (mx', w)+stepWire (WPure f)     ds mx' = return (f ds mx')
+ src/Control/Wire/Event.hs view
@@ -0,0 +1,351 @@+-- |+-- Module:     Control.Wire.Event+-- Copyright:  (c) 2013 Ertugrul Soeylemez+-- License:    BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>++module Control.Wire.Event+    ( -- * Events+      Event,++      -- * Time-based+      at,+      never,+      now,+      periodic,+      periodicList,++      -- * Signal analysis+      became,+      noLonger,+      edge,++      -- * Modifiers+      (<&),+      (&>),+      dropE,+      dropWhileE,+      filterE,+      merge,+      mergeL,+      mergeR,+      notYet,+      once,+      takeE,+      takeWhileE,++      -- * Scans+      accumE,+      accum1E,+      iterateE,+      -- ** Special scans+      maximumE,+      minimumE,+      productE,+      sumE+    )+    where++import Control.Applicative+import Control.Arrow+import Control.Monad.Fix+import Control.Wire.Core+import Control.Wire.Session+import Control.Wire.Unsafe.Event+import Data.Fixed+++-- | Merge events with the leftmost event taking precedence.  Equivalent+-- to using the monoid interface with 'First'.  Infixl 5.+--+-- * Depends: now on both.+--+-- * Inhibits: when any of the two wires inhibit.++(<&) :: (Monad m) => Wire s e m a (Event b) -> Wire s e m a (Event b) -> Wire s e m a (Event b)+(<&) = liftA2 (merge const)++infixl 5 <&+++-- | Merge events with the rightmost event taking precedence.+-- Equivalent to using the monoid interface with 'Last'.  Infixl 5.+--+-- * Depends: now on both.+--+-- * Inhibits: when any of the two wires inhibit.++(&>) :: (Monad m) => Wire s e m a (Event b) -> Wire s e m a (Event b) -> Wire s e m a (Event b)+(&>) = liftA2 (merge (const id))++infixl 5 &>+++-- | Left scan for events.  Each time an event occurs, apply the given+-- function.+--+-- * Depends: now.++accumE ::+    (b -> a -> b)  -- ^ Fold function+    -> b           -- ^ Initial value.+    -> Wire s e m (Event a) (Event b)+accumE f = loop'+    where+    loop' x' =+        mkSFN $+            event (NoEvent, loop' x')+                  (\y -> let x = f x' y in (Event x, loop' x))+++-- | Left scan for events with no initial value.  Each time an event+-- occurs, apply the given function.  The first event is produced+-- unchanged.+--+-- * Depends: now.++accum1E ::+    (a -> a -> a)  -- ^ Fold function+    -> Wire s e m (Event a) (Event a)+accum1E f = initial+    where+    initial =+        mkSFN $ event (NoEvent, initial) (Event &&& accumE f)+++-- | At the given point in time.+--+-- * Depends: now when occurring.++at ::+    (HasTime t s)+    => t  -- ^ Time of occurrence.+    -> Wire s e m a (Event a)+at t' =+    mkSF $ \ds x ->+        let t = t' - dtime ds+        in if t <= 0+             then (Event x, never)+             else (NoEvent, at t)+++-- | Occurs each time the predicate becomes true for the input signal,+-- for example each time a given threshold is reached.+--+-- * Depends: now.++became :: (a -> Bool) -> Wire s e m a (Event a)+became p = off+    where+    off = mkSFN $ \x -> if p x then (Event x, on) else (NoEvent, off)+    on = mkSFN $ \x -> (NoEvent, if p x then on else off)+++-- | Forget the first given number of occurrences.+--+-- * Depends: now.++dropE :: Int -> Wire s e m (Event a) (Event a)+dropE n | n <= 0 = mkId+dropE n =+    fix $ \again ->+    mkSFN $ \mev ->+        (NoEvent, if occurred mev then dropE (pred n) else again)+++-- | Forget all initial occurrences until the given predicate becomes+-- false.+--+-- * Depends: now.++dropWhileE :: (a -> Bool) -> Wire s e m (Event a) (Event a)+dropWhileE p =+    fix $ \again ->+    mkSFN $ \mev ->+        case mev of+          Event x | not (p x) -> (mev, mkId)+          _ -> (NoEvent, again)+++-- | Forget all occurrences for which the given predicate is false.+--+-- * Depends: now.++filterE :: (a -> Bool) -> Wire s e m (Event a) (Event a)+filterE p =+    mkSF_ $ \mev ->+        case mev of+          Event x | p x -> mev+          _ -> NoEvent+++-- | On each occurrence, apply the function the event carries.+--+-- * Depends: now.++iterateE :: a -> Wire s e m (Event (a -> a)) (Event a)+iterateE = accumE (\x f -> f x)+++-- | Maximum of all events.+--+-- * Depends: now.++maximumE :: (Ord a) => Wire s e m (Event a) (Event a)+maximumE = accum1E max+++-- | Minimum of all events.+--+-- * Depends: now.++minimumE :: (Ord a) => Wire s e m (Event a) (Event a)+minimumE = accum1E min+++-- | Left-biased event merge.++mergeL :: Event a -> Event a -> Event a+mergeL = merge const+++-- | Right-biased event merge.++mergeR :: Event a -> Event a -> Event a+mergeR = merge (const id)+++-- | Never occurs.++never :: Wire s e m a (Event b)+never = mkConst (Right NoEvent)+++-- | Occurs each time the predicate becomes false for the input signal,+-- for example each time a given threshold is no longer exceeded.+--+-- * Depends: now.++noLonger :: (a -> Bool) -> Wire s e m a (Event a)+noLonger p = off+    where+    off = mkSFN $ \x -> if p x then (NoEvent, off) else (Event x, on)+    on = mkSFN $ \x -> (NoEvent, if p x then off else on)+++-- | Events occur first when the predicate is false then when it is+-- true, and then this pattern repeats.+--+-- * Depends: now.++edge :: (a -> Bool) -> Wire s e m a (Event a)+edge p = off+    where+    off = mkSFN $ \x -> if p x then (Event x, on) else (NoEvent, off)+    on = mkSFN $ \x -> if p x then (NoEvent, on) else (Event x, off)+++-- | Forget the first occurrence.+--+-- * Depends: now.++notYet :: Wire s e m (Event a) (Event a)+notYet =+    mkSFN $ event (NoEvent, notYet) (const (NoEvent, mkId))+++-- | Occurs once immediately.+--+-- * Depends: now when occurring.++now :: Wire s e m a (Event a)+now = mkSFN $ \x -> (Event x, never)+++-- | Forget all occurrences except the first.+--+-- * Depends: now when occurring.++once :: Wire s e m (Event a) (Event a)+once =+    mkSFN $ \mev ->+        (mev, if occurred mev then never else once)+++-- | Periodic occurrence with the given time period.  First occurrence+-- is now.+--+-- * Depends: now when occurring.++periodic :: (HasTime t s) => t -> Wire s e m a (Event a)+periodic int | int <= 0 = error "periodic: Non-positive interval"+periodic int = mkSFN $ \x -> (Event x, loop' int)+    where+    loop' 0 = loop' int+    loop' t' =+        mkSF $ \ds x ->+            let t = t' - dtime ds+            in if t <= 0+                 then (Event x, loop' (mod' t int))+                 else (NoEvent, loop' t)+++-- | Periodic occurrence with the given time period.  First occurrence+-- is now.  The event values are picked one by one from the given list.+-- When the list is exhausted, the event does not occur again.++periodicList :: (HasTime t s) => t -> [b] -> Wire s e m a (Event b)+periodicList int _ | int <= 0 = error "periodic: Non-positive interval"+periodicList _ [] = never+periodicList int (x:xs) = mkSFN $ \_ -> (Event x, loop' int xs)+    where+    loop' _ [] = never+    loop' 0 xs' = loop' int xs'+    loop' t' xs0@(x':xs') =+        mkSF $ \ds _ ->+            let t = t' - dtime ds+            in if t <= 0+                 then (Event x', loop' (mod' t int) xs')+                 else (NoEvent, loop' t xs0)+++-- | Product of all events.+--+-- * Depends: now.++productE :: (Num a) => Wire s e m (Event a) (Event a)+productE = accumE (*) 1+++-- | Sum of all events.+--+-- * Depends: now.++sumE :: (Num a) => Wire s e m (Event a) (Event a)+sumE = accumE (+) 0+++-- | Forget all but the first given number of occurrences.+--+-- * Depends: now.++takeE :: Int -> Wire s e m (Event a) (Event a)+takeE n | n <= 0 = never+takeE n =+    fix $ \again ->+    mkSFN $ \mev ->+        (mev, if occurred mev then takeE (pred n) else again)+++-- | Forget all but the initial occurrences for which the given+-- predicate is true.+--+-- * Depends: now.++takeWhileE :: (a -> Bool) -> Wire s e m (Event a) (Event a)+takeWhileE p =+    fix $ \again ->+    mkSFN $ \mev ->+        case mev of+          Event x | not (p x) -> (NoEvent, never)+          _ -> (mev, again)
+ src/Control/Wire/Interval.hs view
@@ -0,0 +1,184 @@+-- |+-- Module:     Control.Wire.Interval+-- Copyright:  (c) 2013 Ertugrul Soeylemez+-- License:    BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>++module Control.Wire.Interval+    ( -- * Basic intervals+      inhibit,++      -- * Time intervals+      after,+      for,++      -- * Signal analysis+      unless,+      when,++      -- * Event-based intervals+      asSoonAs,+      between,+      hold,+      holdFor,+      until+    )+    where++import Control.Arrow+import Control.Wire.Core+import Control.Wire.Event+import Control.Wire.Session+import Control.Wire.Unsafe.Event+import Data.Monoid+import Prelude hiding (until)+++-- | After the given time period.+--+-- * Depends: now after the given time period.+--+-- * Inhibits: for the given time period.++after :: (HasTime t s, Monoid e) => t -> Wire s e m a a+after t' =+    mkPure $ \ds x ->+        let t = t' - dtime ds in+        if t <= 0+          then (Right x, mkId)+          else (Left mempty, after t)+++-- | Alias for 'hold'.++asSoonAs :: (Monoid e) => Wire s e m (Event a) a+asSoonAs = hold+++-- | Start each time the left event occurs, stop each time the right+-- event occurs.+--+-- * Depends: now when active.+--+-- * Inhibits: after the right event occurred, before the left event+-- occurs.++between :: (Monoid e) => Wire s e m (a, Event b, Event c) a+between =+    mkPureN $ \(x, onEv, _) ->+        event (Left mempty, between)+              (const (Right x, active))+              onEv++    where+    active =+        mkPureN $ \(x, _, offEv) ->+            event (Right x, active)+                  (const (Left mempty, between))+                  offEv+++-- | For the given time period.+--+-- * Depends: now for the given time period.+--+-- * Inhibits: after the given time period.++for :: (HasTime t s, Monoid e) => t -> Wire s e m a a+for t' =+    mkPure $ \ds x ->+        let t = t' - dtime ds in+        if t <= 0+          then (Left mempty, mkEmpty)+          else (Right x, for t)+++-- | Start when the event occurs for the first time reflecting its+-- latest value.+--+-- * Depends: now.+--+-- * Inhibits: until the event occurs for the first time.++hold :: (Monoid e) => Wire s e m (Event a) a+hold =+    mkPureN $+        event (Left mempty, hold)+              (Right &&& holdWith)++    where+    holdWith x =+        mkPureN $+            event (Right x, holdWith x)+                  (Right &&& holdWith)+++-- | Hold each event occurrence for the given time period.  Inhibits+-- when no event occurred for the given amount of time.  New occurrences+-- override old occurrences, even when they are still held.+--+-- * Depends: now.+--+-- * Inhibits: when no event occurred for the given amount of time.++holdFor :: (HasTime t s, Monoid e) => t -> Wire s e m (Event a) a+holdFor int | int <= 0 = error "holdFor: Non-positive interval."+holdFor int = off+    where+    off =+        mkPure $ \_ ->+            event (Left mempty, off)+                  (Right &&& on int)++    on t' x' =+        mkPure $ \ds ->+            let t = t' - dtime ds in+            event (if t <= 0+                     then (Left mempty, off)+                     else (Right x', on t x'))+                  (Right &&& on int)+++-- | Inhibit forever with the given value.+--+-- * Inhibits: always.++inhibit :: e -> Wire s e m a b+inhibit = mkConst . Left+++-- | When the given predicate is false for the input signal.+--+-- * Depends: now.+--+-- * Inhibits: unless the predicate is false.++unless :: (Monoid e) => (a -> Bool) -> Wire s e m a a+unless p =+    mkPure_ $ \x ->+        if p x then Left mempty else Right x+++-- | Produce until the given event occurs.  When it occurs, inhibit with+-- its value forever.+--+-- * Depends: now until event occurs.+--+-- * Inhibits: forever after event occurs.++until :: (Monoid e) => Wire s e m (a, Event b) a+until =+    mkPureN . uncurry $ \x ->+        event (Right x, until) (const (Left mempty, mkEmpty))+++-- | When the given predicate is true for the input signal.+--+-- * Depends: now.+--+-- * Inhibits: when the predicate is false.++when :: (Monoid e) => (a -> Bool) -> Wire s e m a a+when p =+    mkPure_ $ \x ->+        if p x then Right x else Left mempty
+ src/Control/Wire/Run.hs view
@@ -0,0 +1,63 @@+-- |+-- Module:     Control.Wire.Run+-- Copyright:  (c) 2013 Ertugrul Soeylemez+-- License:    BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>++module Control.Wire.Run+    ( -- * Testing wires+      testWire,+      testWireM+    )+    where++import Control.Monad.IO.Class+import Control.Wire.Core+import Control.Wire.Session+import Data.Functor.Identity+import System.IO+++-- | This function runs the given wire using the given state delta+-- generator.  It constantly shows the output of the wire on one line on+-- stdout.  Press Ctrl-C to abort.++testWire ::+    (MonadIO m, Show b, Show e)+    => Session m s+    -> (forall a. Wire s e Identity a b)+    -> m c+testWire s0 w0 = loop s0 w0+    where+    loop s' w' = do+        (ds, s) <- stepSession s'+        let Identity (mx, w) = stepWire w' ds (Right ())+        liftIO $ do+            putChar '\r'+            putStr (either (\ex -> "I: " ++ show ex) show mx)+            putStr "\027[K"+            hFlush stdout+        loop s w+++-- | This function runs the given wire using the given state delta+-- generator.  It constantly shows the output of the wire on one line on+-- stdout.  Press Ctrl-C to abort.++testWireM ::+    (Monad m', MonadIO m, Show b, Show e)+    => (forall a. m' a -> m a)+    -> Session m s+    -> (forall a. Wire s e m' a b)+    -> m c+testWireM run s0 w0 = loop s0 w0+    where+    loop s' w' = do+        (ds, s) <- stepSession s'+        (mx, w) <- run (stepWire w' ds (Right ()))+        liftIO $ do+            putChar '\r'+            putStr (either (\ex -> "I: " ++ show ex) show mx)+            putStr "\027[K"+            hFlush stdout+        loop s w
+ src/Control/Wire/Session.hs view
@@ -0,0 +1,109 @@+-- |+-- Module:     Control.Wire.Session+-- Copyright:  (c) 2013 Ertugrul Soeylemez+-- License:    BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>++module Control.Wire.Session+    ( -- * State delta types+      HasTime(..),+      Session(..),++      -- ** Wires with time+      Timed(..),+      clockSession,+      clockSession_,+      countSession,+      countSession_+    )+    where++import Control.Applicative+import Control.Monad.IO.Class+import Data.Data+import Data.Monoid+import Data.Time.Clock+++-- | State delta types with time deltas.++class (Monoid s, Real t) => HasTime t s | s -> t where+    -- | Extract the current time delta.+    dtime :: s -> t+++-- | State delta generators as required for wire sessions, most notably+-- to generate time deltas.  These are mini-wires with the sole purpose+-- of generating these deltas.++newtype Session m s =+    Session {+      stepSession :: m (s, Session m s)+    }+    deriving (Functor)++instance (Applicative m) => Applicative (Session m) where+    pure x = let s = Session (pure (x, s)) in s++    Session ff <*> Session fx =+        Session $ liftA2 (\(f, sf) (x, sx) -> (f x, sf <*> sx)) ff fx+++-- | This state delta type denotes time deltas.  This is necessary for+-- most FRP applications.++data Timed t s = Timed t s+    deriving (Data, Eq, Foldable, Functor,+              Ord, Read, Show, Traversable, Typeable)++instance (Monoid s, Real t) => HasTime t (Timed t s) where+    dtime (Timed dt _) = dt++instance (Monoid s, Num t) => Monoid (Timed t s) where+    mempty = Timed 0 mempty++    mappend (Timed dt1 ds1) (Timed dt2 ds2) =+        let dt = dt1 + dt2+            ds = ds1 <> ds2+        in dt `seq` ds `seq` Timed dt ds+++-- | State delta generator for a real time clock.++clockSession :: (MonadIO m) => Session m (s -> Timed NominalDiffTime s)+clockSession =+    Session $ do+        t0 <- liftIO getCurrentTime+        return (Timed 0, loop t0)++    where+    loop t' =+        Session $ do+            t <- liftIO getCurrentTime+            let dt = diffUTCTime t t'+            dt `seq` return (Timed dt, loop t)+++-- | Non-extending version of 'clockSession'.++clockSession_ :: (Applicative m, MonadIO m) => Session m (Timed NominalDiffTime ())+clockSession_ = clockSession <*> pure ()+++-- | State delta generator for a simple counting clock.  Denotes a fixed+-- framerate.  This is likely more useful than 'clockSession' for+-- simulations and real-time games.++countSession ::+    (Applicative m)+    => t  -- ^ Increment size.+    -> Session m (s -> Timed t s)+countSession dt =+    let loop = Session (pure (Timed dt, loop))+    in loop+++-- | Non-extending version of 'countSession'.++countSession_ :: (Applicative m) => t -> Session m (Timed t ())+countSession_ dt = countSession dt <*> pure ()
+ src/Control/Wire/Switch.hs view
@@ -0,0 +1,293 @@+-- |+-- Module:     Control.Wire.Switch+-- Copyright:  (c) 2013 Ertugrul Soeylemez+-- License:    BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>++module Control.Wire.Switch+    ( -- * Simple switching+      (-->),+      (>--),+      -- * Context switching+      modes,++      -- * Event-based switching+      -- ** Intrinsic+      switch,+      dSwitch,+      -- ** Intrinsic continuable+      kSwitch,+      dkSwitch,+      -- ** Extrinsic+      rSwitch,+      drSwitch,+      alternate,+      -- ** Extrinsic continuable+      krSwitch,+      dkrSwitch+    )+    where++import qualified Data.Map as M+import Control.Applicative+import Control.Arrow+import Control.Monad+import Control.Wire.Core+import Control.Wire.Event+import Control.Wire.Unsafe.Event++-- | Acts like the first wire until it inhibits, then switches to the+-- second wire.  Infixr 1.+--+-- * Depends: like current wire.+--+-- * Inhibits: after switching like the second wire.+--+-- * Switch: now.++(-->) :: (Monad m) => Wire s e m a b -> Wire s e m a b -> Wire s e m a b+w1' --> w2' =+    WGen $ \ds mx' -> do+        (mx, w1) <- stepWire w1' ds mx'+        case mx of+          Left _ | Right _ <- mx' -> stepWire w2' ds mx'+          _                       -> mx `seq` return (mx, w1 --> w2')++infixr 1 -->++-- | Acts like the first wire until the second starts producing, at which point+-- it switches to the second wire.  Infixr 1.+--+-- * Depends: like current wire.+--+-- * Inhibits: after switching like the second wire.+--+-- * Switch: now.++(>--) :: (Monad m) => Wire s e m a b -> Wire s e m a b -> Wire s e m a b+w1' >-- w2' =+    WGen $ \ds mx' -> do+        (m2, w2) <- stepWire w2' ds mx'+        case m2 of+          Right _ -> m2 `seq` return (m2, w2)+          _       -> do (m1, w1) <- stepWire w1' ds mx'+                        m1 `seq` return (m1, w1 >-- w2)++infixr 1 >--+++-- | Intrinsic continuable switch:  Delayed version of 'kSwitch'.+--+-- * Inhibits: like the first argument wire, like the new wire after+--   switch.  Inhibition of the second argument wire is ignored.+--+-- * Switch: once, after now, restart state.++dkSwitch ::+    (Monad m)+    => Wire s e m a b+    -> Wire s e m (a, b) (Event (Wire s e m a b -> Wire s e m a b))+    -> Wire s e m a b+dkSwitch w1' w2' =+    WGen $ \ds mx' -> do+        (mx,  w1) <- stepWire w1' ds mx'+        (mev, w2) <- stepWire w2' ds (liftA2 (,) mx' mx)+        let w | Right (Event sw) <- mev = sw w1+              | otherwise = dkSwitch w1 w2+        return (mx, w)+++-- | Extrinsic switch:  Delayed version of 'rSwitch'.+--+-- * Inhibits: like the current wire.+--+-- * Switch: recurrent, after now, restart state.++drSwitch ::+    (Monad m)+    => Wire s e m a b+    -> Wire s e m (a, Event (Wire s e m a b)) b+drSwitch w' =+    WGen $ \ds mx' ->+        let nw w | Right (_, Event w1) <- mx' = w1+                 | otherwise = w+        in liftM (second (drSwitch . nw)) (stepWire w' ds (fmap fst mx'))+++-- | Acts like the first wire until an event occurs then switches+-- to the second wire. Behaves like this wire until the event occurs+-- at which point a *new* instance of the first wire is switched to.+--+-- * Depends: like current wire.+--+-- * Inhibits: like the argument wires.+--+-- * Switch: once, now, restart state.++alternate ::+  (Monad m)+  => Wire s e m a b+  -> Wire s e m a b+  -> Wire s e m (a, Event x) b+alternate w1 w2 = go w1 w2 w1+    where+    go w1' w2' w' =+        WGen $ \ds mx' ->+            let (w1'', w2'', w) | Right (_, Event _) <- mx' = (w2', w1', w2')+                            | otherwise  = (w1', w2', w')+            in liftM (second (go w1'' w2'')) (stepWire w ds (fmap fst mx'))+++-- | Intrinsic switch:  Delayed version of 'switch'.+--+-- * Inhibits: like argument wire until switch, then like the new wire.+--+-- * Switch: once, after now, restart state.++dSwitch ::+    (Monad m)+    => Wire s e m a (b, Event (Wire s e m a b))+    -> Wire s e m a b+dSwitch w' =+    WGen $ \ds mx' -> do+        (mx, w) <- stepWire w' ds mx'+        let nw | Right (_, Event w1) <- mx = w1+               | otherwise = dSwitch w+        return (fmap fst mx, nw)+++-- | Extrinsic continuable switch.  Delayed version of 'krSwitch'.+--+-- * Inhibits: like the current wire.+--+-- * Switch: recurrent, after now, restart state.++dkrSwitch ::+    (Monad m)+    => Wire s e m a b+    -> Wire s e m (a, Event (Wire s e m a b -> Wire s e m a b)) b+dkrSwitch w' =+    WGen $ \ds mx' ->+        let nw w | Right (_, Event f) <- mx' = f w+                 | otherwise = w+        in liftM (second (dkrSwitch . nw)) (stepWire w' ds (fmap fst mx'))+++-- | Intrinsic continuable switch:  @kSwitch w1 w2@ starts with @w1@.+-- Its signal is received by @w2@, which may choose to switch to a new+-- wire.  Passes the wire we are switching away from to the new wire,+-- such that it may be reused in it.+--+-- * Inhibits: like the first argument wire, like the new wire after+--   switch.  Inhibition of the second argument wire is ignored.+--+-- * Switch: once, now, restart state.++kSwitch ::+    (Monad m, Monoid s)+    => Wire s e m a b+    -> Wire s e m (a, b) (Event (Wire s e m a b -> Wire s e m a b))+    -> Wire s e m a b+kSwitch w1' w2' =+    WGen $ \ds mx' -> do+        (mx,  w1) <- stepWire w1' ds mx'+        (mev, w2) <- stepWire w2' ds (liftA2 (,) mx' mx)+        case mev of+          Right (Event sw) -> stepWire (sw w1) mempty mx'+          _                -> return (mx, kSwitch w1 w2)+++-- | Extrinsic continuable switch.  This switch works like 'rSwitch',+-- except that it passes the wire we are switching away from to the new+-- wire.+--+-- * Inhibits: like the current wire.+--+-- * Switch: recurrent, now, restart state.++krSwitch ::+    (Monad m)+    => Wire s e m a b+    -> Wire s e m (a, Event (Wire s e m a b -> Wire s e m a b)) b+krSwitch w'' =+    WGen $ \ds mx' ->+        let w' | Right (_, Event f) <- mx' = f w''+               | otherwise = w''+        in liftM (second krSwitch) (stepWire w' ds (fmap fst mx'))+++-- | Route the left input signal based on the current mode.  The right+-- input signal can be used to change the current mode.  When switching+-- away from a mode and then switching back to it, it will be resumed.+-- Freezes time during inactivity.+--+-- * Complexity: O(n * log n) space, O(log n) lookup time on switch wrt+--   number of started, inactive modes.+--+-- * Depends: like currently active wire (left), now (right).+--+-- * Inhibits: when active wire inhibits.+--+-- * Switch: now on mode change.++modes ::+    (Monad m, Ord k)+    => k  -- ^ Initial mode.+    -> (k -> Wire s e m a b)  -- ^ Select wire for given mode.+    -> Wire s e m (a, Event k) b+modes m0 select = loop' M.empty m0 (select m0)+    where+    loop' ms' m' w'' =+        WGen $ \ds mxev' ->+            case mxev' of+              Left _ -> do+                  (mx, w) <- stepWire w'' ds (fmap fst mxev')+                  return (mx, loop' ms' m' w)+              Right (x', ev) -> do+                  let (ms, m, w') = switch' ms' m' w'' ev+                  (mx, w) <- stepWire w' ds (Right x')+                  return (mx, loop' ms m w)++    switch' ms' m' w' NoEvent = (ms', m', w')+    switch' ms' m' w' (Event m) =+        let ms = M.insert m' w' ms' in+        case M.lookup m ms of+          Nothing -> (ms, m, select m)+          Just w  -> (M.delete m ms, m, w)+++-- | Extrinsic switch:  Start with the given wire.  Each time the input+-- event occurs, switch to the wire it carries.+--+-- * Inhibits: like the current wire.+--+-- * Switch: recurrent, now, restart state.++rSwitch ::+    (Monad m)+    => Wire s e m a b+    -> Wire s e m (a, Event (Wire s e m a b)) b+rSwitch w'' =+    WGen $ \ds mx' ->+        let w' | Right (_, Event w1) <- mx' = w1+               | otherwise = w''+        in liftM (second rSwitch) (stepWire w' ds (fmap fst mx'))+++-- | Intrinsic switch:  Start with the given wire.  As soon as its event+-- occurs, switch to the wire in the event's value.+--+-- * Inhibits: like argument wire until switch, then like the new wire.+--+-- * Switch: once, now, restart state.++switch ::+    (Monad m, Monoid s)+    => Wire s e m a (b, Event (Wire s e m a b))+    -> Wire s e m a b+switch w' =+    WGen $ \ds mx' -> do+        (mx, w) <- stepWire w' ds mx'+        case mx of+          Right (_, Event w1) -> stepWire w1 mempty mx'+          _                   -> return (fmap fst mx, switch w)
+ src/Control/Wire/Time.hs view
@@ -0,0 +1,38 @@+-- |+-- Module:     Control.Wire.Time+-- Copyright:  (c) 2013 Ertugrul Soeylemez+-- License:    BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>++module Control.Wire.Time+    ( -- * Time wires+      time,+      timeF,+      timeFrom+    )+    where++import Control.Wire.Core+import Control.Wire.Session+++-- | Local time starting from zero.++time :: (HasTime t s) => Wire s e m a t+time = timeFrom 0+++-- | Local time starting from zero, converted to your favorite+-- fractional type.++timeF :: (Fractional b, HasTime t s, Monad m) => Wire s e m a b+timeF = fmap realToFrac time+++-- | Local time starting from the given value.++timeFrom :: (HasTime t s) => t -> Wire s e m a t+timeFrom t' =+    mkSF $ \ds _ ->+        let t = t' + dtime ds+        in lstrict (t, timeFrom t)
+ src/Control/Wire/Unsafe/Event.hs view
@@ -0,0 +1,78 @@+-- |+-- Module:     Control.Wire.Unsafe.Event+-- Copyright:  (c) 2013 Ertugrul Soeylemez+-- License:    BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>++module Control.Wire.Unsafe.Event+    ( -- * Events+      Event(..),++      -- * Helper functions+      event,+      merge,+      occurred,+      onEventM+    )+    where++import Control.DeepSeq+import Control.Monad+import Control.Wire.Core+import Data.Semigroup+import Data.Typeable+++-- | Denotes a stream of values, each together with time of occurrence.+-- Since 'Event' is commonly used for functional reactive programming it+-- does not define most of the usual instances to protect continuous+-- time and discrete event occurrence semantics.++data Event a = Event a | NoEvent  deriving (Typeable)++instance Functor Event where+    fmap f = event NoEvent (Event . f)++instance (Semigroup a) => Monoid (Event a) where+    mempty = NoEvent+    mappend = (<>)++instance (NFData a) => NFData (Event a) where+    rnf (Event x) = rnf x+    rnf NoEvent   = ()++instance (Semigroup a) => Semigroup (Event a) where+    (<>) = merge (<>)+++-- | Fold the given event.++event :: b -> (a -> b) -> Event a -> b+event _ j (Event x) = j x+event n _ NoEvent   = n+++-- | Merge two events using the given function when both occur at the+-- same time.++merge :: (a -> a -> a) -> Event a -> Event a -> Event a+merge _ NoEvent NoEvent     = NoEvent+merge _ (Event x) NoEvent   = Event x+merge _ NoEvent (Event y)   = Event y+merge f (Event x) (Event y) = Event (f x y)+++-- | Did the given event occur?++occurred :: Event a -> Bool+occurred = event False (const True)+++-- | Each time the given event occurs, perform the given action with the+-- value the event carries.  The resulting event carries the result of+-- the action.+--+-- * Depends: now.++onEventM :: (Monad m) => (a -> m b) -> Wire s e m (Event a) (Event b)+onEventM c = mkGen_ $ liftM Right . event (return NoEvent) (liftM Event . c)
+ src/Data/Filterable.hs view
@@ -0,0 +1,68 @@+{-|+Module      : Data.Filterable+Description : Generalization of filter function.+Copyright   : (c) Anton Gushcha, 2015-2016+                  Oganyan Levon, 2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX++Defines generic filter utilities for collections.+-}+module Data.Filterable(+    Filterable(..)+  , KeyHashMap(..)+  ) where++import Control.Monad (filterM)+import Data.Hashable +import GHC.Exts+import qualified Data.Foldable as F +import qualified Data.HashMap.Strict as H +import qualified Data.Sequence as S ++-- | Generic filter for collections+class Filterable f where +  -- | Specific constraint for instance+  type FilterConstraint f o :: Constraint +  type FilterConstraint f o = ()++  -- | Test collection for emptiness+  fNull :: FilterConstraint f a => f a -> Bool +  -- | Filter function for collection+  fFilter :: FilterConstraint f a => (a -> Bool) -> f a -> f a+  -- | Monad version of filter +  fFilterM :: (FilterConstraint f a, Monad m) => (a -> m Bool) -> f a -> m (f a)++instance Filterable [] where +  fNull = null  +  fFilter = filter +  fFilterM = filterM++instance Filterable S.Seq where +  fNull = S.null  +  fFilter = S.filter +  fFilterM p = F.foldlM (\xs x -> do+    f <- p x +    return $! if f then xs S.|> x else xs) S.empty++-- | Wrapper around HashMap to Filterable instance over keys+newtype KeyHashMap v k = KeyHashMap { unKeyHashMap :: H.HashMap k v }++instance Filterable (KeyHashMap v) where+  type FilterConstraint (KeyHashMap v) o = (Eq o, Hashable o)+  fNull = H.null . unKeyHashMap+  fFilter p (KeyHashMap m) = KeyHashMap $ H.filterWithKey (\k _ -> p k) m+  fFilterM p (KeyHashMap m) = fmap KeyHashMap $ H.foldlWithKey' (\mxs k x -> do +    xs <- mxs+    f <- p k +    return $! if f then H.insert k x xs else xs) (return H.empty) m++instance (Eq k, Hashable k) => Filterable (H.HashMap k) where+  fNull = H.null  +  fFilter = H.filter +  fFilterM p = H.foldlWithKey' (\mxs k x -> do +    xs <- mxs+    f <- p x+    return $! if f then H.insert k x xs else xs) (return H.empty)
+ src/FRP/Netwire.hs view
@@ -0,0 +1,46 @@+-- |+-- Module:     FRP.Netwire+-- Copyright:  (c) 2013 Ertugrul Soeylemez+-- License:    BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>++module FRP.Netwire+    ( -- * Netwire reexports+      Wire,+      WireP,+      SimpleWire,+      delay, evalWith, force, forceNF,+      module Control.Wire.Event,+      module Control.Wire.Interval,+      module Control.Wire.Run,+      module Control.Wire.Session,+      module Control.Wire.Switch,+      module Control.Wire.Time,++      -- * Additional wires+      module FRP.Netwire.Analyze,+      module FRP.Netwire.Move,+      module FRP.Netwire.Noise,++      -- * External+      module Control.Applicative,+      module Control.Arrow,+      module Control.Category,+      module Data.Semigroup+    )+    where++import Control.Applicative+import Control.Arrow+import Control.Category+import Control.Wire+import Control.Wire.Event+import Control.Wire.Interval+import Control.Wire.Run+import Control.Wire.Session+import Control.Wire.Switch+import Control.Wire.Time+import Data.Semigroup+import FRP.Netwire.Analyze+import FRP.Netwire.Move+import FRP.Netwire.Noise
+ src/FRP/Netwire/Analyze.hs view
@@ -0,0 +1,310 @@+-- |+-- Module:     FRP.Netwire.Analyze+-- Copyright:  (c) 2013 Ertugrul Soeylemez+-- License:    BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>++module FRP.Netwire.Analyze+    ( -- * Linear graphs+      lAvg,+      lGraph,+      lGraphN,++      -- * Staircase graphs+      sAvg,+      sGraph,+      sGraphN,++      -- * Peaks+      highPeak,+      highPeakBy,+      lowPeak,+      lowPeakBy,++      -- * Debug+      avgFps,+      framerate+    )+    where++import qualified FRP.Netwire.Utils.Timeline as Tl+import qualified Data.Foldable as F+import qualified Data.Sequence as Seq+import Control.Wire+import Prelude hiding ((.), id)+++-- | Average framerate over the last given number of samples.  One+-- important thing to note is that the value of this wire will generally+-- disagree with 'sAvg' composed with 'framerate'.  This is expected,+-- because this wire simply calculates the arithmetic mean, whereas+-- 'sAvg' will actually integrate the framerate graph.+--+-- Note:  This wire is for debugging purposes only, because it exposes+-- discrete time.  Do not taint your application with discrete time.+--+-- * Complexity: O(n) time and space wrt number of samples.++avgFps ::+    (RealFloat b, HasTime t s)+    => Int  -- ^ Number of samples.+    -> Wire s e m a b+avgFps int | int < 1 = error "avgFps: Non-positive number of samples"+avgFps int = loop' Seq.empty+    where+    intf = fromIntegral int+    afps = (/ intf) . F.foldl' (+) 0++    loop' ss' =+        mkSF $ \ds _ ->+            let fps = recip . realToFrac . dtime $ ds+                ss  = Seq.take int (fps Seq.<| ss')+            in if isInfinite fps+                 then (afps ss', loop' ss')+                 else ss `seq` (afps ss, loop' ss)+++-- | Current framerate.+--+-- Note:  This wire is for debugging purposes only, because it exposes+-- discrete time.  Do not taint your application with discrete time.+--+-- * Inhibits: when the clock stopped ticking.++framerate ::+    (Eq b, Fractional b, HasTime t s, Monoid e)+    => Wire s e m a b+framerate =+    mkPure $ \ds _ ->+        let dt = realToFrac (dtime ds)+        in (if dt == 0 then Left mempty else Right (recip dt), framerate)+++-- | High peak.+--+-- * Depends: now.++highPeak :: (Ord a) => Wire s e m a a+highPeak = highPeakBy compare+++-- | High peak with respect to the given comparison function.+--+-- * Depends: now.++highPeakBy :: (a -> a -> Ordering) -> Wire s e m a a+highPeakBy = peakBy GT+++-- | Calculate the average of the signal over the given interval (from+-- now).  This is done by calculating the integral of the corresponding+-- linearly interpolated graph and dividing it by the interval length.+-- See 'Tl.linAvg' for details.+--+-- Linear interpolation can be slow.  If you don't need it, you can use+-- the staircase variant 'sAvg'.+--+-- Example: @lAvg 2@+--+-- * Complexity: O(s) space, O(s) time wrt number of samples in the+--   interval.+--+-- * Depends: now.++lAvg ::+    (Fractional a, Fractional t, HasTime t s)+    => t    -- ^ Interval size.+    -> Wire s e m a a+lAvg int =+    mkSF $ \ds x ->+        let t = dtime ds in+        (x, loop' t (Tl.singleton t x))++    where+    loop' t' tl' =+        mkSF $ \ds x ->+            let t  = t' + dtime ds+                t0 = t - int+                tl = Tl.linCutL t0 (Tl.insert t x tl')+                a  = Tl.linAvg t0 t tl+            in (a, loop' t tl)+++-- | Produce a linearly interpolated graph for the given points in time,+-- where the magnitudes of the points are distances from /now/.+--+-- Linear interpolation can be slow.  If you don't need it, you can use+-- the faster staircase variant 'sGraph'.+--+-- Example: @lGraph [0, 1, 2]@ will output the interpolated inputs at+-- /now/, one second before now and two seconds before now.+--+-- * Complexity: O(s) space, O(n * log s) time, where s = number of+--   samples in the interval, n = number of requested data points.+--+-- * Depends: now.++lGraph ::+    (Fractional a, Fractional t, HasTime t s)+    => [t]  -- ^ Data points to produce.+    -> Wire s e m a [a]+lGraph qts =+    mkSF $ \ds x ->+        let t = dtime ds in+        (x <$ qts, loop' t (Tl.singleton t x))++    where+    earliest = maximum (map abs qts)++    loop' t' tl' =+        mkSF $ \ds x ->+            let t  = t' + dtime ds+                tl = Tl.linCutL (t - earliest) (Tl.insert t x tl')+                ps = map (\qt -> Tl.linLookup (t - abs qt) tl) qts+            in (ps, loop' t tl)+++-- | Graph the given interval from now with the given number of evenly+-- distributed points in time.  Convenience interface to 'lGraph'.+--+-- Linear interpolation can be slow.  If you don't need it, you can use+-- the faster staircase variant 'sGraphN'.+--+-- * Complexity: O(s) space, O(n * log s) time, where s = number of+--   samples in the interval, n = number of requested data points.+--+-- * Depends: now.++lGraphN ::+    (Fractional a, Fractional t, HasTime t s)+    => t    -- ^ Interval to graph from now.+    -> Int  -- ^ Number of data points to produce.+    -> Wire s e m a [a]+lGraphN int n+    | int <= 0 = error "lGraphN: Non-positive interval"+    | n <= 0   = error "lGraphN: Non-positive number of data points"+lGraphN int n =+    let n1   = n - 1+        f qt = realToFrac int * fromIntegral qt / fromIntegral n1+    in lGraph (map f [0..n1])+++-- | Low peak.+--+-- * Depends: now.++lowPeak :: (Ord a) => Wire s e m a a+lowPeak = lowPeakBy compare+++-- | Low peak with respect to the given comparison function.+--+-- * Depends: now.++lowPeakBy :: (a -> a -> Ordering) -> Wire s e m a a+lowPeakBy = peakBy LT+++-- | Given peak with respect to the given comparison function.++peakBy ::+    (Eq o)+    => o  -- ^ This ordering means the first argument is larger.+    -> (a -> a -> o)  -- ^ Compare two elements.+    -> Wire s e m a a+peakBy o comp = mkSFN $ \x -> (x, loop' x)+    where+    loop' x' =+        mkSFN $ \x ->+            id &&& loop' $+            if comp x x' == o then x else x'+++-- | Calculate the average of the signal over the given interval (from+-- now).  This is done by calculating the integral of the corresponding+-- staircase graph and dividing it by the interval length.  See+-- 'Tl.scAvg' for details.+--+-- See also 'lAvg'.+--+-- Example: @sAvg 2@+--+-- * Complexity: O(s) space, O(s) time wrt number of samples in the+--   interval.+--+-- * Depends: now.++sAvg ::+    (Fractional a, Fractional t, HasTime t s)+    => t    -- ^ Interval size.+    -> Wire s e m a a+sAvg int =+    mkSF $ \ds x ->+        let t = dtime ds in+        (x, loop' t (Tl.singleton t x))++    where+    loop' t' tl' =+        mkSF $ \ds x ->+            let t  = t' + dtime ds+                t0 = t - int+                tl = Tl.scCutL t0 (Tl.insert t x tl')+                a  = Tl.scAvg t0 t tl+            in (a, loop' t tl)+++-- | Produce a staircase graph for the given points in time, where the+-- magnitudes of the points are distances from /now/.+--+-- See also 'lGraph'.+--+-- Example: @sGraph [0, 1, 2]@ will output the inputs at /now/, one+-- second before now and two seconds before now.+--+-- * Complexity: O(s) space, O(n * log s) time, where s = number of+--   samples in the interval, n = number of requested data points.+--+-- * Depends: now.++sGraph ::+    (Fractional t, HasTime t s)+    => [t]  -- ^ Data points to produce.+    -> Wire s e m a [a]+sGraph qts =+    mkSF $ \ds x ->+        let t = dtime ds in+        (x <$ qts, loop' t (Tl.singleton t x))++    where+    earliest = maximum (map abs qts)++    loop' t' tl' =+        mkSF $ \ds x ->+            let t  = t' + dtime ds+                tl = Tl.scCutL (t - earliest) (Tl.insert t x tl')+                ps = map (\qt -> Tl.scLookup (t - abs qt) tl) qts+            in (ps, loop' t tl)+++-- | Graph the given interval from now with the given number of evenly+-- distributed points in time.  Convenience interface to 'sGraph'.+--+-- See also 'lGraphN'.+--+-- * Complexity: O(s) space, O(n * log s) time, where s = number of+--   samples in the interval, n = number of requested data points.+--+-- * Depends: now.++sGraphN ::+    (Fractional t, HasTime t s)+    => t    -- ^ Interval to graph from now.+    -> Int  -- ^ Number of data points to produce.+    -> Wire s e m a [a]+sGraphN int n+    | int <= 0 = error "sGraphN: Non-positive interval"+    | n <= 0   = error "sGraphN: Non-positive number of data points"+sGraphN int n =+    let n1   = n - 1+        f qt = realToFrac int * fromIntegral qt / fromIntegral n1+    in sGraph (map f [0..n1])
+ src/FRP/Netwire/Move.hs view
@@ -0,0 +1,77 @@+-- |+-- Module:     FRP.Netwire.Move+-- Copyright:  (c) 2013 Ertugrul Soeylemez+-- License:    BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>++module FRP.Netwire.Move+    ( -- * Calculus+      derivative,+      integral,+      integralWith+    )+    where++import Control.Wire+++-- | Time derivative of the input signal.+--+-- * Depends: now.+--+-- * Inhibits: at singularities.++derivative ::+    (RealFloat a, HasTime t s, Monoid e)+    => Wire s e m a a+derivative = mkPure $ \_ x -> (Left mempty, loop' x)+    where+    loop' x' =+        mkPure $ \ds x ->+            let dt  = realToFrac (dtime ds)+                dx  = (x - x') / dt+                mdx | isNaN dx      = Right 0+                    | isInfinite dx = Left mempty+                    | otherwise     = Right dx+            in mdx `seq` (mdx, loop' x)+++-- | Integrate the input signal over time.+--+-- * Depends: before now.++integral ::+    (Fractional a, HasTime t s)+    => a  -- ^ Integration constant (aka start value).+    -> Wire s e m a a+integral x' =+    mkPure $ \ds dx ->+        let dt = realToFrac (dtime ds)+        in x' `seq` (Right x', integral (x' + dt*dx))+++-- | Integrate the left input signal over time, but apply the given+-- correction function to it.  This can be used to implement collision+-- detection/reaction.+--+-- The right signal of type @w@ is the /world value/.  It is just passed+-- to the correction function for reference and is not used otherwise.+--+-- The correction function must be idempotent with respect to the world+-- value: @f w (f w x) = f w x@.  This is necessary and sufficient to+-- protect time continuity.+--+-- * Depends: before now.++integralWith ::+    (Fractional a, HasTime t s)+    => (w -> a -> a)  -- ^ Correction function.+    -> a              -- ^ Integration constant (aka start value).+    -> Wire s e m (a, w) a+integralWith correct = loop'+    where+    loop' x' =+        mkPure $ \ds (dx, w) ->+            let dt = realToFrac (dtime ds)+                x  = correct w (x' + dt*dx)+            in x' `seq` (Right x', loop' x)
+ src/FRP/Netwire/Noise.hs view
@@ -0,0 +1,98 @@+-- |+-- Module:     FRP.Netwire.Noise+-- Copyright:  (c) 2013 Ertugrul Soeylemez+-- License:    BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>++module FRP.Netwire.Noise+    ( -- * Noise generators+      noise,+      noiseR,+      wackelkontakt,++      -- * Convenience+      stdNoise,+      stdNoiseR,+      stdWackelkontakt+    )+    where++import Control.Wire+import Prelude hiding ((.), id)+import System.Random+++-- | Noise events with the given distance between events.  Use 'hold' or+-- 'holdFor' to generate a staircase.++noise ::+    (HasTime t s, Random b, RandomGen g)+    => t  -- ^ Time period.+    -> g  -- ^ Random number generator.+    -> Wire s e m a (Event b)+noise int | int <= 0 = error "noise: Non-positive interval"+noise int = periodicList int . randoms+++-- | Noise events with the given distance between events.  Noise will be+-- in the given range.  Use 'hold' or 'holdFor' to generate a staircase.++noiseR ::+    (HasTime t s, Random b, RandomGen g)+    => t       -- ^ Step duration.+    -> (b, b)  -- ^ Noise range.+    -> g       -- ^ Random number generator.+    -> Wire s e m a (Event b)+noiseR int _ | int <= 0 = error "noiseR: Non-positive interval"+noiseR int r = periodicList int . randomRs r+++-- | Convenience interface to 'noise' for 'StdGen'.++stdNoise ::+    (HasTime t s, Random b)+    => t    -- ^ Step duration.+    -> Int  -- ^ 'StdGen' seed.+    -> Wire s e m a (Event b)+stdNoise int = noise int . mkStdGen+++-- | Convenience interface to 'noiseR' for 'StdGen'.++stdNoiseR ::+    (HasTime t s, Monad m, Random b)+    => t       -- ^ Step duration.+    -> (b, b)  -- ^ Noise range.+    -> Int     -- ^ 'StdGen' seed.+    -> Wire s e m a (Event b)+stdNoiseR int r = noiseR int r . mkStdGen+++-- | Convenience interface to 'wackelkontakt' for 'StdGen'.++stdWackelkontakt ::+    (HasTime t s, Monad m, Monoid e)+    => t    -- ^ Step duration.+    -> Double    -- ^ Probability to produce.+    -> Int  -- ^ 'StdGen' seed.+    -> Wire s e m a a+stdWackelkontakt int p = wackelkontakt int p . mkStdGen+++-- | Randomly produce or inhibit with the given probability, each time+-- for the given duration.+--+-- The name /Wackelkontakt/ (German for /slack joint/) is a Netwire+-- running gag.  It makes sure that you revisit the documentation from+-- time to time. =)+--+-- * Depends: now.++wackelkontakt ::+    (HasTime t s, Monad m, Monoid e, RandomGen g)+    => t  -- ^ Duration.+    -> Double  -- ^ Probability to produce.+    -> g  -- ^ Random number generator.+    -> Wire s e m a a+wackelkontakt int _ _ | int <= 0 = error "wackelkontakt: Non-positive duration"+wackelkontakt int p g = fmap snd $ when (< p) . hold . noise int g &&& id
+ src/FRP/Netwire/Utils/Timeline.hs view
@@ -0,0 +1,175 @@+-- |+-- Module:     FRP.Netwire.Utils.Timeline+-- Copyright:  (c) 2013 Ertugrul Soeylemez+-- License:    BSD3+-- Maintainer: Ertugrul Soeylemez <es@ertes.de>++module FRP.Netwire.Utils.Timeline+    ( -- * Time lines for statistics wires+      Timeline,++      -- * Constructing time lines+      insert,+      singleton,+      union,++      -- * Linear sampling+      linAvg,+      linCutL,+      linCutR,+      linLookup,++      -- * Staircase sampling+      scAvg,+      scCutL,+      scCutR,+      scLookup+    )+    where++import qualified Data.Map.Strict as M+import Data.Data+import Data.Map.Strict (Map)+++-- | A time line is a non-empty set of samples together with time+-- information.++newtype Timeline t a =+    Timeline {+      timeline :: Map t a+    }+    deriving (Data, Eq, Ord, Read, Show, Typeable)++instance Functor (Timeline t) where+    fmap f (Timeline m) = Timeline (M.map f m)+++-- | Insert the given data point.++insert :: (Ord t) => t -> a -> Timeline t a -> Timeline t a+insert t x (Timeline m) = Timeline (M.insert t x m)+++-- | Linearly interpolate the points in the time line, integrate the+-- given time interval of the graph, divide by the interval length.++linAvg ::+    (Fractional a, Fractional t, Real t)+    => t -> t -> Timeline t a -> a+linAvg t0 t1+    | t0 > t1 = const (error "linAvg: Invalid interval")+    | t0 == t1 = linLookup t0+linAvg t0 t1 = avg 0 . M.assocs . timeline . linCutR t1 . linCutL t0+    where+    avg a' ((t', y1) : xs@((t, y2) : _)) =+        let dt = realToFrac (t - t')+            a  = a' + dt*(y1 + y2)/2+        in a `seq` avg a xs+    avg a' _ = a' / realToFrac (t1 - t0)+++-- | Cut the timeline at the given point in time @t@, such that all+-- samples up to but not including @t@ are forgotten.  The most recent+-- sample before @t@ is moved and interpolated accordingly.++linCutL ::+    (Fractional a, Fractional t, Real t)+    => t -> Timeline t a -> Timeline t a+linCutL t tl@(Timeline m) =+    Timeline $+    case M.splitLookup t m of+      (_, Just x, mr) -> M.insert t x mr+      (_, _, mr)      -> M.insert t (linLookup t tl) mr+++-- | Cut the timeline at the given point in time @t@, such that all+-- samples later than @t@ are forgotten.  The most recent sample after+-- @t@ is moved and interpolated accordingly.++linCutR ::+    (Fractional a, Fractional t, Real t)+    => t -> Timeline t a -> Timeline t a+linCutR t tl@(Timeline m) =+    Timeline $+    case M.splitLookup t m of+      (ml, Just x, _) -> M.insert t x ml+      (ml, _, _)      -> M.insert t (linLookup t tl) ml+++-- | Look up with linear sampling.++linLookup :: (Fractional a, Fractional t, Real t) => t -> Timeline t a -> a+linLookup t (Timeline m) =+    case M.splitLookup t m of+      (_, Just x, _) -> x+      (ml, _, mr)    ->+          case (fst <$> M.maxViewWithKey ml, fst <$> M.minViewWithKey mr) of+            (Just (t1, x1), Just (t2, x2)) ->+                let f = realToFrac ((t - t1) / (t2 - t1))+                in x1*(1 - f) + x2*f+            (Just (_, x), _) -> x+            (_, Just (_, x)) -> x+            _                -> error "linLookup: BUG: querying empty Timeline"+++-- | Integrate the given time interval of the staircase, divide by the+-- interval length.++scAvg :: (Fractional a, Real t) => t -> t -> Timeline t a -> a+scAvg t0 t1+    | t0 > t1 = const (error "scAvg: Invalid interval")+    | t0 == t1 = scLookup t0+scAvg t0 t1 = avg 0 . M.assocs . timeline . scCutR t1 . scCutL t0+    where+    avg a' ((t', y) : xs@((t, _) : _)) =+        let dt = realToFrac (t - t')+            a  = a' + dt*y+        in a `seq` avg a xs+    avg a' _ = a' / realToFrac (t1 - t0)+++-- | Cut the timeline at the given point in time @t@, such that all+-- samples up to but not including @t@ are forgotten.  The most recent+-- sample before @t@ is moved accordingly.++scCutL :: (Ord t) => t -> Timeline t a -> Timeline t a+scCutL t tl@(Timeline m) =+    Timeline $+    case M.splitLookup t m of+      (_, Just x, mr) -> M.insert t x mr+      (_, _, mr)      -> M.insert t (scLookup t tl) mr+++-- | Cut the timeline at the given point in time @t@, such that all+-- samples later than @t@ are forgotten.  The earliest sample after @t@+-- is moved accordingly.++scCutR :: (Ord t) => t -> Timeline t a -> Timeline t a+scCutR t tl@(Timeline m) =+    Timeline $+    case M.splitLookup t m of+      (ml, Just x, _) -> M.insert t x ml+      (ml, _, _)      -> M.insert t (scLookup t tl) ml+++-- | Look up on staircase.++scLookup :: (Ord t) => t -> Timeline t a -> a+scLookup t (Timeline m) =+    case (M.lookupLE t m, M.lookupGE t m) of+      (Just (_, x), _) -> x+      (_, Just (_, x)) -> x+      _                -> error "linLookup: BUG: querying empty Timeline"+++-- | Singleton timeline with the given point.++singleton :: t -> a -> Timeline t a+singleton t = Timeline . M.singleton t+++-- | Union of two time lines.  Right-biased.++union :: (Ord t) => Timeline t a -> Timeline t a -> Timeline t a+union (Timeline m1) (Timeline m2) = Timeline (M.union m2 m1)
+ src/Game/GoreAndAsh.hs view
@@ -0,0 +1,17 @@+{-|+Module      : Game.GoreAndAsh+Description : Entry point of Gore&Ash core.+Copyright   : (c) Anton Gushcha, 2015-2016+                  Oganyan Levon, 2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX+-}+module Game.GoreAndAsh(+    module X+  ) where++import Game.GoreAndAsh.Core as X+import Game.GoreAndAsh.Math as X+import Data.Filterable as X
+ src/Game/GoreAndAsh/Core.hs view
@@ -0,0 +1,65 @@+{-|+Module      : Game.GoreAndAsh.Core+Description : Engine Core that controls modules execution+Copyright   : (c) Anton Gushcha, 2015-2016+                  Oganyan Levon, 2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX++The core of all engine. It contains generic arrow operations and helpers,+definition of core module system, game session declaration and utilities+to control main loop of application.+-}+module Game.GoreAndAsh.Core(+  -- * Reexports of used time types+    GameTime+  , GameSession+  , NominalDiffTime+  -- * Game loop control+  , GameState+  , stepGame+  , newGameState+  , newGameStateM+  , cleanupGameState+  -- * Core module definition+  , GameMonadT+  , GameModule(..)+  , ModuleStack+  -- * Arrow combinators and helpers+  , GameWire+  -- ** Lifting monad to arrow+  , liftGameMonad+  , liftGameMonad1+  , liftGameMonad2+  , liftGameMonad3+  , liftGameMonad4+  , liftGameMonadOnce+  , liftGameMonad1Once+  , liftGameMonad2Once+  , liftGameMonad3Once+  , liftGameMonad4Once+  -- ** Event functions+  , once'+  , mapE+  , filterE+  , filterEG+  , filterEGM+  , filterJustE+  , filterJustLE+  , liftGameMonadEvent1+  , changes+  -- ** Helpers+  , stateWire+  , chainWires+  , dispense+  , dDispense+  -- ** Time utilities+  , deltaTime+  ) where++import Game.GoreAndAsh.Core.Arrow as X+import Game.GoreAndAsh.Core.Monad as X+import Game.GoreAndAsh.Core.Session as X+import Game.GoreAndAsh.Core.State as X
+ src/Game/GoreAndAsh/Core/Arrow.hs view
@@ -0,0 +1,258 @@+{-|+Module      : Game.GoreAndAsh.Core.Arrow+Description : Core operations with arrows.+Copyright   : (c) Anton Gushcha, 2015-2016+                  Oganyan Levon, 2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX++The module defines 'GameWire' type as fundamental type for all applications arrows. Also+there are utilities for lifting 'GameMonadT' actions to 'GameWire', event processing helpers+and some other utilities.+-}+module Game.GoreAndAsh.Core.Arrow(+    GameWire+  -- * Lifting monad to arrow+  , liftGameMonad+  , liftGameMonad1+  , liftGameMonad2+  , liftGameMonad3+  , liftGameMonad4+  , liftGameMonadOnce+  , liftGameMonad1Once+  , liftGameMonad2Once+  , liftGameMonad3Once+  , liftGameMonad4Once+  -- * Event functions+  , once'+  , mapE+  , filterE+  , filterEG+  , filterEGM+  , filterJustE+  , filterJustLE+  , liftGameMonadEvent1+  , changes+  -- * Helpers+  , stateWire+  , chainWires+  , dispense+  , dDispense+  -- * Time+  , deltaTime+  ) where++import Control.Monad.Fix+import Control.Wire+import Control.Wire.Unsafe.Event+import Data.Filterable+import Data.Maybe (fromJust, isJust)+import Prelude hiding (id, (.))++import Game.GoreAndAsh.Core.Monad+import Game.GoreAndAsh.Core.Session++-- | Game wire with given API 'm' and input value 'a' and output value 'b'.+--+-- Typically end point application defines a type synonyms:+--+-- @+-- -- | Arrow that is build over the monad stack+-- type AppWire a b = GameWire AppMonad a b+-- @+type GameWire m a b = Wire GameTime () (GameMonadT m) a b++-- | Takes game monad and wraps it into game wire.+--+-- Note: Result of wire is calclulated each frame.+liftGameMonad :: Monad m => GameMonadT m b -> GameWire m a b+liftGameMonad action = mkGen_ $ \ _ -> do +  val <- action +  return $ Right val++-- | Takes game monad and wraps it into game wire.+--+-- Note: Result of wire is calclulated each frame.+liftGameMonad1 :: Monad m => (a -> GameMonadT m b) -> GameWire m a b+liftGameMonad1 action = mkGen_ $ \ a -> do +  val <- action a+  return $ Right val++-- | Takes game monad and wraps it into game wire.+--+-- Note: Result of wire is calclulated each frame.+liftGameMonad2 :: Monad m => (a -> b -> GameMonadT m c) -> GameWire m (a, b) c+liftGameMonad2 action = mkGen_ $ \ (a, b) -> do +  val <- action a b+  return $ Right val++-- | Takes game monad and wraps it into game wire.+--+-- Note: Result of wire is calclulated each frame.+liftGameMonad3 :: Monad m => (a -> b -> c -> GameMonadT m d) -> GameWire m (a, b, c) d+liftGameMonad3 action = mkGen_ $ \ (a, b, c) -> do +  val <- action a b c+  return $ Right val++-- | Takes game monad and wraps it into game wire.+--+-- Note: Result of wire is calclulated each frame.+liftGameMonad4 :: Monad m => (a -> b -> c -> d -> GameMonadT m e) -> GameWire m (a, b, c, d) e+liftGameMonad4 action = mkGen_ $ \ (a, b, c, d) -> do +  val <- action a b c d+  return $ Right val++-- | Takes game monad and wraps it into game wire.+--+-- Note: Result of wire is calculated ONCE and next execution returns cached value+liftGameMonadOnce :: Monad m => GameMonadT m b -> GameWire m a b +liftGameMonadOnce action = mkGen $ \_ _ -> do +  val <- action +  return (Right val, pure val)++-- | Takes game monad and wraps it into game wire.+--+-- Note: Result of wire is calculated ONCE and next execution returns cached value+liftGameMonad1Once :: Monad m => (a -> GameMonadT m b) -> GameWire m a b +liftGameMonad1Once action = mkGen $ \_ a -> do +  val <- action a+  return (Right val, pure val)++-- | Takes game monad and wraps it into game wire.+--+-- Note: Result of wire is calculated ONCE and next execution returns cached value+liftGameMonad2Once :: Monad m => (a -> b -> GameMonadT m c) -> GameWire m (a, b) c +liftGameMonad2Once action = mkGen $ \_ (a, b) -> do +  val <- action a b+  return (Right val, pure val)++-- | Takes game monad and wraps it into game wire.+--+-- Note: Result of wire is calculated ONCE and next execution returns cached value+liftGameMonad3Once :: Monad m => (a -> b -> c -> GameMonadT m d) -> GameWire m (a, b, c) d +liftGameMonad3Once action = mkGen $ \_ (a, b, c) -> do +  val <- action a b c+  return (Right val, pure val)++-- | Takes game monad and wraps it into game wire.+--+-- Note: Result of wire is calculated ONCE and next execution returns cached value+liftGameMonad4Once :: Monad m => (a -> b -> c -> d -> GameMonadT m e) -> GameWire m (a, b, c, d) e +liftGameMonad4Once action = mkGen $ \_ (a, b, c, d) -> do +  val <- action a b c d+  return (Right val, pure val)++-- | Pass through first occurence and then forget about event producer.+--+-- Note: netwire once combinator still holds it event producer when event+-- is produced.+once' :: Monad m => GameWire m a (Event b) -> GameWire m a (Event b)+once' w = proc a -> do +  e <- w -< a +  drSwitch id -< (e, fmap (const never) e)++-- | Mapping events as a wire.+--+-- It is semantically equal to:+--+-- >>> arr (fmap f)+mapE :: Monad m => (a -> b) -> GameWire m (Event a) (Event b)+mapE f = arr $ \e -> case e of +  NoEvent -> NoEvent+  Event a -> Event $ f a ++-- | Same as 'filterE' but for generic 'Foldable' and 'Filterable'.+filterEG :: (Foldable f, Filterable f, FilterConstraint f a, Monad m)+  => (a -> Bool) -- ^ Predicate to test elements that are left in collection+  -> GameWire m (Event (f a)) (Event (f a)) -- ^ Wire that leaves only non empty collections+filterEG p = arr $ \e -> case e of +  NoEvent -> NoEvent+  Event as -> let+    as' = fFilter p as+    in if fNull as' +      then NoEvent+      else length as' `seq` Event as'++-- | Same as 'filterEG' but with monadic action.+filterEGM :: (Foldable f, Filterable f, FilterConstraint f a, Monad m)+  => (a -> GameMonadT m Bool) -- ^ Predicate to test elements that are left in collection+  -> GameWire m (Event (f a)) (Event (f a)) -- ^ Wire that leaves only non empty collections+filterEGM p = mkGen_ $ \e -> case e of +  NoEvent -> return $! Right NoEvent+  Event as -> do+    as' <- fFilterM p as+    if fNull as' +      then return $! Right NoEvent+      else return . Right $! length as' `seq` Event as'++-- | Filters only Just events+--+-- Shortcut for:+--+-- >>> mapE fromJust . filterE isJust+filterJustE :: Monad m => GameWire m (Event (Maybe a)) (Event a)+filterJustE = mapE fromJust . filterE isJust++-- | Filters only Just events in foldable struct+filterJustLE :: (Monad m, Filterable f, FilterConstraint f (Maybe a), Functor f) => GameWire m (Event (f (Maybe a))) (Event (f a))+filterJustLE = mapE (fmap fromJust . fFilter isJust)++-- | Lifting game monad action to event processing arrow+--+-- Synonym for 'onEventM' from "Control.Wire.Core.Unsafe.Event".+liftGameMonadEvent1 :: Monad m => (a -> GameMonadT m b) -> GameWire m (Event a) (Event b)+liftGameMonadEvent1 = onEventM++-- | Loops output of wire to it input, first parameter is start value of state+--+-- Common combinator for build game actors.+stateWire :: MonadFix m => b -> GameWire m (a, b) b -> GameWire m a b+stateWire ib w = loop $ proc (a, b_) -> do +  b <- delay ib -< b_ -- either it will hang+  b2 <- w -< (a, b)+  returnA -< (b2, b2)++-- | Sequence compose list of wires (right to left order)+chainWires :: Monad m => [GameWire m a a] -> GameWire m a a +chainWires [] = id +chainWires (w:ws) = w . chainWires ws++-- | Fires when input value changes+changes :: (Monad m, Eq a) => GameWire m a (Event a)+changes = mkPureN $ \a -> (Right $! Event a, go a)+  where+    go cura = mkPureN $ \a -> if a == cura +      then (Right NoEvent, go cura)+      else a `seq` (Right $! Event a, go a)++-- | Infinitely dispense given elements and switches to next item on event.+--+-- Note: is not defined on empty list.+--+-- Note: not delayed version, new item is returned on same frame when input event occurs.+dispense :: (Monad m) => [a] -> GameWire m (Event b) a+dispense = go . cycle+  where+    go [] = error "dispense: empty list"+    go (a:as) = mkPureN $ \e -> case e of +      NoEvent -> (Right a, go $ a:as)+      Event _ -> (Right $ head as, go as)++-- | Infinitely dispense given elements and switches to next item on event.+--+-- Note: is not defined on empty list.+--+-- Note: delayed version, new item is returned on frame after input event occurs.+dDispense :: (Monad m) => [a] -> GameWire m (Event b) a+dDispense = go . cycle+  where+    go [] = error "dDispense: empty list" +    go (a:as) = mkPureN $ \e -> case e of +      NoEvent -> (Right a, go $ a:as)+      Event _ -> (Right a, go as)++-- | Returns delta time scince last frame.+deltaTime :: (Fractional b, Monad m) => GameWire m a b +deltaTime = mkSF $ \ds _ -> let t = realToFrac (dtime ds) in t `seq` (t, deltaTime)
+ src/Game/GoreAndAsh/Core/Monad.hs view
@@ -0,0 +1,286 @@+{-|+Module      : Game.GoreAndAsh.Core.Monad+Description : Definition of game monad and core modules.+Copyright   : (c) Anton Gushcha, 2015-2016+                  Oganyan Levon, 2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX++The module defines 'GameMonadT' monad transformer as base monad for all arrows of ther engine.+Also there is 'GameModule' class that must be implemented by all core modules. Finally 'ModuleStack'+type family is for user usage to compose all modules in single monad stack.+-}+module Game.GoreAndAsh.Core.Monad(+    GameMonadT+  , GameContext(..)+  , newGameContext+  , evalGameMonad+  , GameModule(..)+  , IOState+  , IdentityState+  , ModuleStack+  ) where++import Control.DeepSeq+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.State.Strict+import Data.Functor.Identity+import Data.Proxy (Proxy(..))+import GHC.Generics (Generic)++-- | Basic game monad transformer which wraps core modules.+--+-- Here goes all core API that accessable from each +-- game object. All specific (mods etc) API should+-- be included in inner `m` monad.+--+-- [@m@] Core modules monads stacked up here.+--+-- [@a@] Value caried by the monad.+--+-- The monad is used to create new arrows, there a 90% chances+-- that you will create your own arrows. You could use "Control.Wire.Core"+-- module and especially 'mkGen', 'mkGen_' and 'mkSFN' functions to create+-- new arrows.+newtype GameMonadT m a = GameMonadT { +  runGameMonadT :: StateT GameContext m a+} deriving (MonadThrow, MonadCatch, MonadMask)++-- | State of core.+--+-- At the moment it is empty, but left for future+-- extensions. For example, some introspection API+-- of enabled modules would be added.+data GameContext = GameContext {+  +} deriving Generic++instance NFData GameContext++-- | Create empty context+newGameContext :: GameContext +newGameContext = GameContext++instance Functor m => Functor (GameMonadT m) where +  fmap f (GameMonadT m) = GameMonadT $ fmap f m++-- | Monad is needed as StateT Applicative instance requires it+instance Monad m => Applicative (GameMonadT m) where+  pure a = GameMonadT $ pure a+  (GameMonadT f) <*> (GameMonadT m) = GameMonadT $ f <*> m++instance Monad m => Monad (GameMonadT m) where +  return = pure +  (GameMonadT ma) >>= f = GameMonadT $ do +    a <- ma+    runGameMonadT $ f a++instance MonadFix m => MonadFix (GameMonadT m) where+  mfix f = GameMonadT $ mfix (runGameMonadT . f)++instance MonadTrans GameMonadT where +  lift = GameMonadT . lift++instance MonadIO m => MonadIO (GameMonadT m) where +  liftIO = GameMonadT . liftIO++-- | Runs game monad with given context+evalGameMonad :: GameMonadT m a -> GameContext -> m (a, GameContext)+evalGameMonad (GameMonadT m) ctx = runStateT m ctx++-- | Describes how to run core modules. Each core module must define+-- an instance of the class.+--+-- The class describes how the module is executed each game frame+-- and how to pass its own state to the next state.+--+-- The state 's' must be unique for each game module.+--+-- 'GameMonadT' has 'm' parameter that should implement the class.+--+-- Typical backbone of new core module:+--+-- @+--   -- | State of your module+--   data MyModuleState s = MyModuleState {+--     -- | Next state in state chain of modules+--   , myModuleNextState :: !s+--   } deriving (Generic)+--   +--   -- | Needed to step game state+--   instance NFData s => NFData (MyModuleState s)+--  +--   -- | Creation of initial state+--   emptyMyModuleState :: s -> MyModuleState s +--   emptyMyModuleState s = MyModuleState {+--       myModuleNextState = s+--     }+--   +--   -- Your monad transformer that implements module API+--   newtype MyModuleT s m a = MyModuleT { runMyModuleT :: StateT (MyModuleState s) m a }+--     deriving (Functor, Applicative, Monad, MonadState (MyModuleState s), MonadFix, MonadTrans, MonadIO, MonadThrow, MonadCatch, MonadMask)+--   +--   instance GameModule m s => GameModule (MyModuleT s m) (MyModuleState s) where +--     type ModuleState (MyModuleT s m) = MyModuleState s+--     runModule (MyModuleT m) s = do+--       -- First phase: execute all dependent modules actions and transform own state +--       ((a, s'), nextState) <- runModule (runStateT m s) (myModuleNextState s)+--       -- Second phase: here you could execute your IO actions+--       return (a, s' { +--          myModuleNextState = nextState +--         })+--   +--     newModuleState = emptyMyModuleState <$> newModuleState+--   +--     withModule _ = id+--     cleanupModule _ = return ()+--   +--   -- | Define your module API+--   class OtherModuleMonad m => MyModuleMonad m where+--     -- | The function would be seen in any arrow+--     myAwesomeFunction :: AnotherModule m => a -> b -> m (a, b) +--   +--   -- | Implementation of API+--   instance {-\# OVERLAPPING #-} OtherModuleMonad m => MyModuleMonad (MyModuleT s m) where+--      myAwesomeFunction = ...+--  +--   -- | Passing calls through other modules+--   instance {-\# OVERLAPPABLE #-} (MyModuleMonad m, MonadTrans mt) => MyModuleMonad (mt m) where +--     myAwesomeFunction a b = lift $ myAwesomeFunction a b+-- @+--+-- After the backbone definition you could include your monad to application stack with 'ModuleStack'+-- and use it within any arrow in your application.+class Monad m => GameModule m s | m -> s, s -> m where+  -- | Defines what state has given module.+  --+  -- The correct implentation of the association:+  -- >>> type ModuleState (MyModuleT s m) = MyModuleState s+  type ModuleState m :: *++  -- | Executes module action with given state. Produces new state that should be passed to next step+  --+  -- Each core module has responsibility of executing underlying modules with nested call to 'runModule'.+  --+  -- Typically there are two phases of execution:+  --+  --   * Calculation of own state and running underlying modules+  --+  --   * Execution of IO actions that are queued in module state+  --+  -- Some of modules requires 'IO' monad at the end of monad stack to call 'IO' actions in place within+  -- first phase of module execution (example: network module). You should avoid the pattern and prefer +  -- to execute 'IO' actions at the second phase as bad designed use of first phase could lead to strange +  -- behavior at arrow level.+  runModule :: MonadIO m' => m a -> s -> m' (a, s)+  -- | Creates new state of module.+  -- +  -- Typically there are nested calls to 'newModuleState' for nested modules.+  -- @+  -- newModuleState = emptyMyModuleState <$> newModuleState+  -- @+  newModuleState :: MonadIO m' => m' s+  -- | Wrap action with module initialization and cleanup.+  --+  -- Could be `withSocketsDo` or another external library initalization.+  withModule :: Proxy m -> IO a -> IO a+  -- | Cleanup resources of the module, should be called on exit (actually 'cleanupGameState' do this for your)+  cleanupModule :: s -> IO ()++-- | Type level function that constucts complex module stack from given list of modules.+--+-- The type family helps to simplify chaining of core modules at user application:+--+-- @+-- -- | Application monad is monad stack build from given list of modules over base monad (IO)+-- type AppStack = ModuleStack [LoggingT, ActorT, NetworkT] IO+-- newtype AppState = AppState (ModuleState AppStack)+--   deriving (Generic)+-- +-- instance NFData AppState +-- +-- -- | Wrapper around type family to enable automatic deriving+-- -- +-- -- Note: There could be need of manual declaration of module API stub instances, as GHC can fail to derive instance automatically.+-- newtype AppMonad a = AppMonad (AppStack a)+--   deriving (Functor, Applicative, Monad, MonadFix, MonadIO, LoggingMonad, NetworkMonad, ActorMonad, MonadThrow, MonadCatch)+-- +-- -- | Top level wrapper for module stack+-- instance GameModule AppMonad AppState where +--   type ModuleState AppMonad = AppState+--   runModule (AppMonad m) (AppState s) = do +--     (a, s') <- runModule m s +--     return (a, AppState s')+--   newModuleState = AppState <$> newModuleState+--   withModule _ = withModule (Proxy :: Proxy AppStack)+--   cleanupModule (AppState s) = cleanupModule s +-- +-- -- | Arrow that is build over the monad stack+-- type AppWire a b = GameWire AppMonad a b+-- -- | Action that makes indexed app wire+-- type AppActor i a b = GameActor AppMonad i a b+-- @+--+-- There are two endpoint monads that are currently built in the core:+--+--   * 'Identity' - for modules stack that does only pure actions at it first phase;+--+--   * 'IO' - most common case, modules can execute 'IO' actions in place at firts phase.+type family ModuleStack (ms :: [* -> (* -> *) -> * -> *]) (endm :: * -> *) :: * -> * where+  ModuleStack '[] curm = curm+  ModuleStack (m ': ms) curm = ModuleStack ms (m (ModuleState curm) curm)++-- | Endpoint of state chain for Identity monad+-- +-- Could be used in 'ModuleStack' as end monad:+--+-- @+-- type AppStack = ModuleStack [LoggingT, ActorT] Identity+-- @+data IdentityState = IdentityState deriving Generic++instance NFData IdentityState++-- | Module stack that does only pure actions in its first phase.+--+-- Could be used in 'ModuleStack' as end monad:+--+-- @+-- type AppStack = ModuleStack [LoggingT, ActorT] Identity+-- @+instance GameModule Identity IdentityState where+  type ModuleState Identity = IdentityState+  runModule i _ = return $ (runIdentity i, IdentityState)+  newModuleState = return IdentityState+  withModule _ = id+  cleanupModule _ = return ()++-- | Endpoint of state chain for IO monad.+--+-- Could be used in 'ModuleStack' as end monad:+--+-- @+-- type AppStack = ModuleStack [LoggingT, ActorT, NetworkT] IO+-- @+data IOState = IOState deriving Generic++instance NFData IOState++-- | Module stack that does IO action.+--+-- Could be used in 'ModuleStack' as end monad:+--+-- @+-- type AppStack = ModuleStack [LoggingT, ActorT, NetworkT] IO+-- @+instance GameModule IO IOState where+  type ModuleState IO = IOState+  runModule io _ = do +    a <- liftIO io+    return (a, IOState)+  newModuleState = return IOState+  withModule _ = id+  cleanupModule _ = return ()
+ src/Game/GoreAndAsh/Core/Session.hs view
@@ -0,0 +1,40 @@+{-|+Module      : Game.GoreAndAsh.Core.Session+Description : Definition of game session that holds current time.+Copyright   : (c) Anton Gushcha, 2015-2016+                  Oganyan Levon, 2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX++Utilities for handling time in engine arrows.+-}+module Game.GoreAndAsh.Core.Session(+    GameTime+  , GameSession+  , NominalDiffTime+  , newGameSession+  , stepGameSession+  ) where++import Control.Monad.IO.Class+import Control.Wire.Session+import Data.Time.Clock++-- | Current value of simulation time.+type GameTime = Timed NominalDiffTime ()++-- | Session that stores time in diff format+-- The only purpose is to store time while stepping simulation.+type GameSession = Session IO GameTime++-- | Creates new empty game session+newGameSession :: GameSession+newGameSession = clockSession_++-- | Generates next value of game session and outputs current simulation time+-- That simulation time should be feeded to game wire and next+-- value of session should be used at next step of simulation.+stepGameSession :: MonadIO m => GameSession -> m (GameTime, GameSession)+stepGameSession s = liftIO $ stepSession s
+ src/Game/GoreAndAsh/Core/State.hs view
@@ -0,0 +1,174 @@+{-|+Module      : Game.GoreAndAsh.Core.State+Description : Core operations with main application loop.+Copyright   : (c) Anton Gushcha, 2015-2016+                  Oganyan Levon, 2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX++Handling of game main loop, creation of initial state, stepping and cleaning up.+-}+module Game.GoreAndAsh.Core.State(+    GameState(..)+  , stepGame+  , newGameState+  , newGameStateM+  , cleanupGameState+  ) where++import Prelude hiding (id, (.))+import Control.DeepSeq+import Control.Monad.IO.Class+import Control.Wire+import Game.GoreAndAsh.Core.Arrow+import Game.GoreAndAsh.Core.Monad +import Game.GoreAndAsh.Core.Session ++-- | Holds all data that is needed to produce next step+-- of game simulation. +--+-- You need to call 'stepGame' to get next game state repeatedly +-- and finally 'cleanupGameState' at the end of program.+--+-- [@m@] is game monad is used including all enabled API of core modules;+--+-- [@s@] is game state that includes chained state of core modules;+--+-- [@a@] is return value of main arrow;+--+-- Typical game main loop:+-- +-- @+-- main :: IO ()+-- main = withModule (Proxy :: Proxy AppMonad) $ do+--   gs <- newGameState $ runActor' mainWire+--   gsRef <- newIORef gs+--   firstStep gs gsRef `onCtrlC` exitHandler gsRef+--   where+--     -- | What to do on emergency exit+--     exitHandler gsRef = do +--       gs <- readIORef gsRef +--       cleanupGameState gs+--       exitSuccess+-- +--     -- | Initialization step+--     firstStep gs gsRef = do +--       (_, gs') <- stepGame gs $ do +--         -- ... some initialization steps+--       writeIORef gsRef gs'+--       gameLoop gs' gsRef+-- +--     -- | Normal game loop+--     gameLoop gs gsRef = do +--       (_, gs') <- stepGame gs (return ())+--       writeIORef gsRef gs'+--       gameLoop gs' gsRef+-- +-- -- | Executes given handler on Ctrl-C pressing+-- onCtrlC :: IO a -> IO () -> IO a+-- p `onCtrlC` q = catchJust isUserInterrupt p (const $ q >> p `onCtrlC` q)+--   where+--     isUserInterrupt :: AsyncException -> Maybe ()+--     isUserInterrupt UserInterrupt = Just ()+--     isUserInterrupt _             = Nothing+-- @+data GameState m s a = GameState {+  gameSession :: !GameSession +, gameWire :: !(GameWire m () a)+, gameContext :: !GameContext+, gameModuleState :: !s+}++instance NFData s => NFData (GameState m s a) where+  rnf GameState{..} = gameSession `seq`+    gameWire `seq`+    gameContext `deepseq`+    gameModuleState `deepseq` ()+    +-- | Main loop of the game where each frame is calculated.+--+-- Call it frequently enough for smooth simulation. At the end+-- of application there should be call to 'cleanupGameState'.+stepGame :: (GameModule m s, NFData s, MonadIO m') +  => GameState m s a -- ^ Current game state+  -> GameMonadT m b -- ^ Some action to perform before each frame+  -> m' (Maybe a, GameState m s a)+  -- ^ Main wire can inhibit therefore result is 'Maybe'+stepGame GameState{..} preFrame = do +  (t, gameSession') <- stepGameSession gameSession+  -- Removing layers of abstraction+  let gameMonadAction = stepWire gameWire t $ Right ()+      moduleAction = evalGameMonad (preFrame >> gameMonadAction) gameContext+      ioAction = runModule moduleAction gameModuleState+  -- Final pattern matching+  (((ma, gameWire'), gameContext'), gameModuleState') <- ioAction+  -- Collect new state+  let newState = GameState {+      gameSession = gameSession'+    , gameWire = gameWire'+    , gameContext = gameContext'+    , gameModuleState = gameModuleState'+    }+  return $ gameModuleState' +    `deepseq` gameContext'+    `deepseq` (eitherToMaybe ma, newState)++-- | Helper to throw away left value+eitherToMaybe :: Either a b -> Maybe b +eitherToMaybe (Left _) = Nothing+eitherToMaybe (Right a) = Just a++-- | Creates new game state from given main wire.+--+-- Use 'stepGame' to update the state and free it with+-- 'cleanupGameState' at the end of your application. +--+-- If you need some initialization steps, you can use+-- 'newGameStateM' version.+newGameState :: (GameModule m s, MonadIO m') => +     GameWire m () a -- ^ Wire that we calculate+  -> m' (GameState m s a)+newGameState wire = do +  moduleState <- newModuleState+  return $ GameState {+      gameSession = newGameSession+    , gameWire = wire +    , gameContext = newGameContext+    , gameModuleState = moduleState+    }++-- | Creates new game state, monadic version that allows some+-- initialization steps in game monad.+--+-- The function is helpful if you want to make an global actor from+-- your main wire.+--+-- Use 'stepGame' to update the state and free it with+-- 'cleanupGameState' at the end of your application. +--+-- See also 'newGameState'.+newGameStateM :: (GameModule m s, MonadIO m') => +    GameMonadT m (GameWire m () a) -- ^ Action that makes wire to execute+  -> m' (GameState m s a)+newGameStateM mwire = do +  moduleState <- newModuleState+  let moduleAction = evalGameMonad mwire newGameContext+      ioAction = runModule moduleAction moduleState+  ((wire, gameContext'), moduleState') <- ioAction+  return $! GameState {+      gameSession = newGameSession+    , gameWire = wire+    , gameContext = gameContext'+    , gameModuleState = moduleState'+    }++-- | Cleanups resources that is holded in game state.+--+-- The function should be called before the exit of application to+-- free all resources catched by core modules.+cleanupGameState :: (GameModule m s, MonadIO m') +  => GameState m s a -- ^ Game state with resources+  -> m' ()+cleanupGameState = liftIO . cleanupModule . gameModuleState
+ src/Game/GoreAndAsh/Math.hs view
@@ -0,0 +1,98 @@+{-|+Module      : Game.GoreAndAsh.Math+Description : Common mathematic utilities in games+Copyright   : (c) Anton Gushcha, 2015-2016+                  Oganyan Levon, 2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX++Defines common math transformations for world, camera, vieport spaces.+-}+module Game.GoreAndAsh.Math(+  -- * 3D matrix transformations+    scale+  , rotationZ+  , translate+  -- * 2D matrix transformations+  , scale2D+  , rotation2D+  , translate2D+  , toHom2D+  , fromHom2D+  , applyTransform2D+  , viewportTransform2D+  ) where++import Linear++-- | Scale matrix for 3D transformation+scale :: Num a => V3 a -> M44 a +scale (V3 x y z) = V4+  (V4 x 0 0 0)+  (V4 0 y 0 0)+  (V4 0 0 z 0)+  (V4 0 0 0 1)++-- | Rotation around Z axis for 3D transformation+rotationZ :: Floating a => a -> M44 a +rotationZ a = V4 +  (V4 (cos a) (- sin a) 0 0)+  (V4 (sin a) (  cos a) 0 0)+  (V4 0 0 1 0)+  (V4 0 0 0 1)++-- | Translation matrix for 3D transformation+translate :: Num a => V3 a -> M44 a +translate (V3 x y z) = V4 +  (V4 1 0 0 x)+  (V4 0 1 0 y)+  (V4 0 0 1 z)+  (V4 0 0 0 1)++-- | Scale matrix for 2D transformation+scale2D :: Num a => V2 a -> M33 a +scale2D (V2 x y) = V3+  (V3 x 0 0)+  (V3 0 y 0)+  (V3 0 0 1)++-- | Rotation matrix for 2D transformation+rotation2D :: Floating a => a -> M33 a +rotation2D a = V3 +  (V3 (cos a) (- sin a) 0)+  (V3 (sin a) (  cos a) 0)+  (V3 0 0 1)++-- | Translation matrix for 2D transformation+translate2D :: Num a => V2 a -> M33 a +translate2D (V2 x y) = V3 +  (V3 1 0 x)+  (V3 0 1 y)+  (V3 0 0 1)++-- | Transform to homogenius coordinates+toHom2D :: Num a => V2 a -> V3 a +toHom2D (V2 x y) = V3 x y 1++-- | Transform from homogenius coordinates+fromHom2D :: Floating a => V3 a -> V2 a +fromHom2D (V3 x y w) = V2 (x/w) (y/w)++-- | Applies transformation matrix to vector+applyTransform2D :: Floating a => M33 a -> V2 a -> V2 a +applyTransform2D mt v = fromHom2D $ mt !* toHom2D v++-- | Viewport transformation matrix+viewportTransform2D :: Floating a +  => V2 a -- ^ Viewport left top corner+  -> V2 a -- ^ Viewport right bottom corner+  -> M33 a+viewportTransform2D (V2 l t) (V2 r b) = V3 +  (V3 ((r-l)/2) 0          ((r+l)/2))+  (V3 0         (-(t-b)/2) ((t+b)/2))+  (V3 0         0          1)+  !*! scale2D (V2 1 a)+  where+    a = (r-l)/(t-b)