├── .github └── config.yml ├── .gitignore ├── .gitlab-ci.yml ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── bench └── Main.hs ├── changelog.md ├── ci.sh ├── overseer.rc ├── pack-profiling.sh ├── package.yaml ├── sosrc ├── default.sos ├── doctest.sos ├── haddock.sos └── stackage.sos ├── src └── Control │ ├── Varying.hs │ └── Varying │ ├── Core.hs │ ├── Event.hs │ ├── Spline.hs │ └── Tween.hs ├── stack.yaml ├── stack80-ghcjs.yaml ├── test ├── DocTests.hs └── Main.hs └── varying.cabal /.github/config.yml: -------------------------------------------------------------------------------- 1 | todo: 2 | keyword: "TODO" 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | stack.yaml.lock 3 | dist 4 | cabal-dev 5 | *.sw[a-z] 6 | *.o 7 | *.hi 8 | *.chi 9 | *.chs.h 10 | *.dyn_o 11 | *.dyn_hi 12 | .virtualenv 13 | .hpc 14 | .hsenv 15 | .cabal-sandbox/ 16 | cabal.sandbox.config 17 | *.prof 18 | *.aux 19 | *.hp 20 | *.ps 21 | *.aux 22 | *.prof 23 | TAGS 24 | *.js 25 | *.css 26 | -------------------------------------------------------------------------------- /.gitlab-ci.yml: -------------------------------------------------------------------------------- 1 | image: ubuntu:18.04 2 | cache: 3 | paths: 4 | - .stack/ 5 | - .stack-work/ 6 | 7 | build: 8 | stage: build 9 | script: 10 | - source ci.sh 11 | - build 12 | 13 | deploy_hackage: 14 | stage: deploy 15 | dependencies: 16 | - build 17 | environment: 18 | name: master 19 | url: https://hackage.haskell.org/package/varying 20 | only: 21 | - master 22 | when: manual 23 | script: 24 | - source ci.sh 25 | - deploy 26 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Schell Scivally 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # varying 2 | [![Hackage](https://img.shields.io/hackage/v/varying.svg)](http://hackage.haskell.org/package/varying) 3 | [![Build Status](https://gitlab.com/schell/varying/badges/master/build.svg)](https://gitlab.com/schell/varying) 4 | 5 | This library provides automaton based value streams and sequencing useful for 6 | functional reactive programming (FRP) and locally stateful programming (LSP). 7 | 8 | 9 | ## Getting started 10 | 11 | ```haskell 12 | module Main where 13 | 14 | import Control.Varying 15 | import Control.Applicative 16 | import Control.Concurrent (forkIO, killThread) 17 | import Data.Functor.Identity 18 | import Data.Time.Clock 19 | 20 | -- | A simple 2d point type. 21 | data Point = Point { px :: Float 22 | , py :: Float 23 | } deriving (Show, Eq) 24 | 25 | newtype Delta = Delta { unDelta :: Float } 26 | 27 | -- An exponential tween back and forth from 0 to 50 over 1 seconds that 28 | -- loops forever. This spline takes float values of delta time as input, 29 | -- outputs the current x value at every step. 30 | tweenx :: Monad m => TweenT Float Float m Float 31 | tweenx = do 32 | -- Tween from 0 to 50 over 1 second 33 | tween_ easeOutExpo 0 50 1 34 | -- Chain another tween back to the starting position 35 | tween_ easeOutExpo 50 0 1 36 | -- Loop forever 37 | tweenx 38 | 39 | -- An exponential tween back and forth from 0 to 50 over 1 seconds that never 40 | -- ends. 41 | tweeny :: Monad m => TweenT Float Float m Float 42 | tweeny = do 43 | tween_ easeOutExpo 50 0 1 44 | tween_ easeOutExpo 0 50 1 45 | tweeny 46 | 47 | -- Our time signal counts input delta time samples. 48 | time :: Monad m => VarT m Delta Float 49 | time = var unDelta 50 | 51 | -- | Our Point value that varies over time continuously in x and y. 52 | backAndForth :: Monad m => VarT m Delta Point 53 | backAndForth = 54 | -- Turn our splines into continuous output streams. We must provide 55 | -- a starting value since splines are not guaranteed to be defined at 56 | -- their edges. 57 | let x = tweenStream tweenx 0 58 | y = tweenStream tweeny 0 59 | in 60 | -- Construct a varying Point that takes time as an input. 61 | (Point <$> x <*> y) 62 | -- Stream in a time signal using the 'plug left' combinator. 63 | -- We could similarly use the 'plug right' (~>) function 64 | -- and put the time signal before the construction above. This is needed 65 | -- because the tween streams take time as an input. 66 | <~ time 67 | 68 | main :: IO () 69 | main = do 70 | putStrLn "An example of value streams using the varying library." 71 | putStrLn "Enter a newline to continue, and then a newline to quit" 72 | _ <- getLine 73 | 74 | t <- getCurrentTime 75 | tId <- forkIO $ loop backAndForth t 76 | 77 | _ <- getLine 78 | killThread tId 79 | 80 | loop :: Var Delta Point -> UTCTime -> IO () 81 | loop v t = do 82 | t1 <- getCurrentTime 83 | -- Here we'll run in the Identity monad using a time delta provided by 84 | -- getCurrentTime and diffUTCTime. 85 | let dt = realToFrac $ diffUTCTime t1 t 86 | Identity (Point x y, vNext) = runVarT v $ Delta dt 87 | xStr = replicate (round x) ' ' ++ "x" ++ replicate (50 - round x) ' ' 88 | yStr = replicate (round y) ' ' ++ "y" ++ replicate (50 - round y) ' ' 89 | str = zipWith f xStr yStr 90 | f 'x' 'y' = '|' 91 | f 'y' 'x' = '|' 92 | f a ' ' = a 93 | f ' ' b = b 94 | f _ _ = ' ' 95 | putStrLn str 96 | loop vNext t1 97 | ``` 98 | 99 | # Publications 100 | 101 | The concept of `VarT` that this library is built on is isomorphic to Monadic Stream Functions as defined in "[Functional Reactive Programming, Refactored](http://dl.acm.org/citation.cfm?id=2976010)" ([mirror](http://www.cs.nott.ac.uk/~psxip1/#FRPRefactored)). 102 | 103 | The isomorphism is 104 | ``` haskell 105 | toMSF :: Functor m => VarT m a b -> MSF m a b 106 | toMSF = MSF . (fmap . fmap . fmap $ toMSF) . runVarT 107 | 108 | toVarT :: Functor m => MSF m a b -> VarT m a b 109 | toVarT = VarT . (fmap . fmap . fmap $ toVarT) . unMSF 110 | ``` 111 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Concurrent (threadDelay) 4 | import Control.Varying 5 | import Data.Function (fix) 6 | import Data.Functor.Identity (Identity (..)) 7 | import Data.Time.Clock (diffUTCTime, getCurrentTime) 8 | 9 | -- | A simple 2d point type. 10 | data Point = Point { px :: Float 11 | , py :: Float 12 | } deriving (Show, Eq) 13 | 14 | 15 | -- | The duration (in seconds) to tween in each direction. 16 | dur :: Float 17 | dur = 3 18 | 19 | 20 | -- | A novel, start-stop tween. 21 | easeMiddle :: Monad m => Float -> Float -> Float -> TweenT Float Float m () 22 | easeMiddle start end t = do 23 | let change = end - start 24 | tween_ easeOutExpo start (start + change/2) $ t/2 25 | tween_ easeInExpo (start + change/2) end $ t/2 26 | 27 | -- An exponential tween back and forth from 0 to 50 over 1 seconds that 28 | -- loops forever. This spline takes float values of delta time as input, 29 | -- outputs the current x value at every step. 30 | tweenx :: Monad m => TweenT Float Float m () 31 | tweenx = do 32 | -- Tween from 0 to 50 over 'dur' seconds 33 | easeMiddle 0 50 dur 34 | -- Chain another tween back to the starting position 35 | easeMiddle 50 0 dur 36 | -- Loop forever 37 | tweenx 38 | 39 | -- A quadratic tween back and forth from 0 to 50 over 1 seconds that never 40 | -- ends. 41 | tweeny :: Monad m => TweenT Float Float m () 42 | tweeny = do 43 | easeMiddle 50 0 dur 44 | easeMiddle 0 50 dur 45 | tweeny 46 | 47 | -- | Our Point value that varies over time continuously in x and y. 48 | backAndForth :: Monad m => VarT m Float Point 49 | backAndForth = 50 | -- Turn our splines into continuous output streams. We must provide 51 | -- a starting value since splines are not guaranteed to be defined at 52 | -- their edges. 53 | let x = tweenStream tweenx 0 54 | y = tweenStream tweeny 0 55 | in 56 | -- Construct a varying Point that takes time as an input. 57 | (Point <$> x <*> y) 58 | 59 | main :: IO () 60 | main = do 61 | t <- getCurrentTime 62 | ($ t) . ($ backAndForth) $ fix $ \loop v lastT -> do 63 | thisT <- getCurrentTime 64 | -- Here we'll run in the Identity monad using a time delta provided by 65 | -- getCurrentTime and diffUTCTime. 66 | let dt = realToFrac $ diffUTCTime thisT lastT 67 | Identity (Point x y, vNext) = runVarT v dt 68 | xStr = replicate (round x) ' ' ++ "x" ++ replicate (50 - round x) ' ' 69 | yStr = replicate (round y) ' ' ++ "y" ++ replicate (50 - round y) ' ' 70 | str = zipWith f xStr yStr 71 | f 'x' 'y' = '|' 72 | f 'y' 'x' = '|' 73 | f a ' ' = a 74 | f ' ' b = b 75 | f _ _ = ' ' 76 | putStrLn str 77 | threadDelay $ floor $ 1000000 / (20 :: Double) 78 | loop vNext thisT 79 | -------------------------------------------------------------------------------- /bench/Main.hs: -------------------------------------------------------------------------------- 1 | import Control.Varying 2 | import Control.Monad 3 | import Control.Applicative 4 | import Data.Functor.Identity 5 | import Criterion.Main 6 | 7 | main :: IO () 8 | main = do 9 | let run v a = runIdentity (fst <$> runVarT v a) 10 | defaultMain [ bgroup "runVarT" [ bench "1" $ nf (run $ chain 1) 0 11 | , bench "2" $ nf (run $ chain 2) 0 12 | , bench "4" $ nf (run $ chain 4) 0 13 | , bench "8" $ nf (run $ chain 8) 0 14 | , bench "16" $ nf (run $ chain 16) 0 15 | , bench "32" $ nf (run $ chain 32) 0 16 | , bench "64" $ nf (run $ chain 64) 0 17 | , bench "128" $ nf (run $ chain 128) 0 18 | ] 19 | , bgroup "TweenT" 20 | [ bench "tweenStream" $ 21 | nf (run $ tweenStream myTween 0) 0 22 | ] 23 | ] 24 | return () 25 | 26 | chain :: Int -> Var Int Int 27 | chain n = seq x x 28 | where x = foldl (>>>) (var (+1)) $ replicate (n - 1) $ var (+1) 29 | 30 | myTween :: Tween Float Float () 31 | myTween = do 32 | void $ tween_ easeInExpo 0 100 1 33 | void $ tween_ easeOutExpo 100 0 1 34 | myTween 35 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | change log 2 | ========== 3 | 4 | 0.1.5.0 - added Control.Varying.Spline 5 | 6 | 0.2.0.0 - reordered spline type variables for MonadTrans 7 | 8 | 0.3.0.0 - updated the type of mapOutput to a more friendly, usable signature 9 | bug fixes 10 | 11 | 0.3.1.0 - added stepMany, eitherE 12 | 13 | 0.4.0.0 - Var and Spline are now parameterized with Identity, removed mix, changed 14 | the behavior of race, added untilEvent variants, added tests 15 | 16 | 0.5.0.0 - changed stepMany to remove Monoid requirement, added raceMany, added 17 | anyE, more tests and SplineT obeys Applicative and Monad laws 18 | 19 | 0.5.0.1 - removed time as dependency 20 | 21 | 0.5.0.2 - separated tweening time and value, added runSplineE, builds on all GHC 22 | since 7.6 23 | 24 | 0.6.0.0 - changed the internal type of SplineT to use Either, reducing unused 25 | output values and preventing time/space leaks. Updated tween types. 26 | Added withTween(_). 27 | 28 | 0.7.0.0 - added proofs, reduced API size by removing trivial or weird (special) 29 | combinators, changed some names, Event is a synonym of Maybe, removed 30 | Time (moved functions to Event), renamed Event.mergeE to Event.bothE, 31 | added Spline.untilProc and Spline.whileProc, documentation - working 32 | towards 1.0 33 | 34 | 0.7.1.2 - Fixed broken ArrowLoop instance, updated documentation. 35 | 36 | 0.8.0.0 - TweenT is a newtype. 37 | 38 | 0.8.1.0 - Remove senseless ArrowApply instance 39 | -------------------------------------------------------------------------------- /ci.sh: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | 3 | export DIR=`pwd` 4 | export PROJECT_DIR="." 5 | 6 | # get ready to build the project 7 | prebuild () { 8 | echo "Doing prebuild stuff (installing with apt, getting stack, etc...)" 9 | apt-get update -y 10 | apt-get install -y wget libtinfo-dev git 11 | cd $PROJECT_DIR 12 | wget -qO- https://get.haskellstack.org/ | sh 13 | export STACK_ROOT=`pwd`/.stack 14 | stack setup 15 | cd $DIR 16 | } 17 | 18 | 19 | # build the project 20 | build () { 21 | prebuild 22 | echo "Building..." 23 | stack install --only-dependencies 24 | stack build || exit 1 25 | stack test || exit 1 26 | stack bench 27 | } 28 | 29 | 30 | deploy () { 31 | prebuild 32 | echo "Deploying..." 33 | stack build 34 | stack sdist . 35 | mkdir -p $STACK_ROOT/upload 36 | echo $hackage_creds > ${STACK_ROOT}/upload/credentials.json 37 | stack upload . 38 | } 39 | -------------------------------------------------------------------------------- /overseer.rc: -------------------------------------------------------------------------------- 1 | #- patterns: 2 | # - .*\.hs$ 3 | # - .*\.cabal$ 4 | # commands: 5 | # - stack test --trace --fast --ghc-options="-fprof-cafs -fprof-auto" 6 | ## - stack exec varying-example -- +RTS -p -hc -sstderr 7 | ## - ./pack-profiling.sh 8 | # - hlint \0 9 | 10 | # These are for adding new features 11 | - patterns: 12 | - \[^#\]*\.l?hs$ 13 | - \[^#\]*\.cabal 14 | - \[^#\]*stack\.yaml$ 15 | commands: 16 | - stack test --trace --fast 17 | # These are for preparing for a stackage release 18 | #- patterns: 19 | # - .*\.l?hs$ 20 | # - .*\.cabal 21 | # - .*stack\.yaml$ 22 | # commands: 23 | # #- stack --resolver lts-1 --install-ghc test --fast # for ghc 7.6 24 | # #- stack --resolver lts-2 --install-ghc test --fast # for ghc 7.8 25 | # #- stack --resolver lts-3 --install-ghc test --fast # for ghc 7.10.2 26 | # #- stack --resolver lts-5 --install-ghc test --fast # for ghc 7.10.3 27 | # #- stack --resolver nightly --install-ghc test --fast 28 | # #- stack build --fast --stack-yaml=stack80-ghcjs.yaml 29 | -------------------------------------------------------------------------------- /pack-profiling.sh: -------------------------------------------------------------------------------- 1 | name=`date | tr ' ' -` 2 | mv varying-example.prof $name.prof 3 | mv varying-example.hp $name.hp 4 | hp2ps -e8in -c $name.hp 5 | open -e $name.prof 6 | open $name.ps 7 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: varying 2 | github: "schell/varying" 3 | # The package version. See the Haskell package versioning policy (PVP) 4 | # for standards guiding when and how versions should be incremented. 5 | # http://www.haskell.org/haskellwiki/Package_versioning_policy 6 | # PVP summary: +-+------- breaking API changes 7 | # | | +----- non-breaking API additions 8 | # | | | +--- code changes with no API change 9 | version: 0.8.1.0 10 | # A short (one-line) description of the package. 11 | synopsis: FRP through value streams and monadic splines. 12 | # A longer description of the package. 13 | description: Varying is a FRP library aimed at providing a 14 | simple way to describe values that change over a domain. 15 | It allows monadic, applicative and arrow notation and has 16 | convenience functions for tweening. Great for animation. 17 | 18 | # URL for the project homepage or repository. 19 | homepage: https://github.com/schell/varying 20 | 21 | # The license under which the package is released. 22 | license: MIT 23 | 24 | # The file containing the license text. 25 | license-file: LICENSE 26 | 27 | # The package author(s). 28 | author: Schell Scivally 29 | 30 | # An email address to which users can send suggestions, bug reports, and 31 | # patches. 32 | maintainer: schell@takt.com 33 | 34 | # A copyright notice. 35 | # copyright: 36 | 37 | category: Control, FRP 38 | 39 | extra-source-files: 40 | - README.md 41 | - changelog.md 42 | 43 | dependencies: 44 | - base >=4.8 && < 5.0 45 | - transformers >= 0.3 46 | - contravariant >= 1.4 47 | 48 | library: 49 | ghc-options: -Wall 50 | source-dirs: src 51 | 52 | executables: 53 | varying-example: 54 | source-dirs: app 55 | main: Main.hs 56 | ghc-options: 57 | - -Wall 58 | - -threaded 59 | - -rtsopts 60 | - -with-rtsopts=-N 61 | 62 | dependencies: 63 | - time >= 1.4 64 | - varying 65 | 66 | tests: 67 | doctests: 68 | main: DocTests.hs 69 | source-dirs: test 70 | other-modules: [] 71 | ghc-options: 72 | - -threaded 73 | - -rtsopts 74 | - -with-rtsopts=-N 75 | dependencies: 76 | - doctest 77 | - varying 78 | 79 | 80 | other: 81 | main: Main.hs 82 | source-dirs: test 83 | other-modules: [] 84 | ghc-options: 85 | - -threaded 86 | - -rtsopts 87 | - -with-rtsopts=-N 88 | dependencies: 89 | - hspec 90 | - time >=1.4 91 | - QuickCheck 92 | - varying 93 | 94 | 95 | benchmarks: 96 | varying-bench: 97 | source-dirs: bench 98 | main: Main.hs 99 | dependencies: 100 | - time >=1.4 101 | - transformers 102 | - varying 103 | - criterion 104 | ghc-options: 105 | - -Wall 106 | - -threaded 107 | - -rtsopts 108 | - -with-rtsopts=-N 109 | -------------------------------------------------------------------------------- /sosrc/default.sos: -------------------------------------------------------------------------------- 1 | - patterns: 2 | - .*\.hs$ 3 | - .*\.cabal$ 4 | commands: 5 | - stack test --trace --fast --ghc-options="-fprof-cafs -fprof-auto" 6 | # - stack exec varying-example -- +RTS -p -hc -sstderr 7 | # - ./pack-profiling.sh 8 | - hlint \0 9 | -------------------------------------------------------------------------------- /sosrc/doctest.sos: -------------------------------------------------------------------------------- 1 | # This is for testing documentation 2 | - patterns: 3 | - .*/[^_]*\.l?hs$ 4 | excludes: 5 | - \# 6 | - flycheck 7 | commands: 8 | - stack exec doctest -- \0 9 | -------------------------------------------------------------------------------- /sosrc/haddock.sos: -------------------------------------------------------------------------------- 1 | # This is for reviewing documentation 2 | - patterns: 3 | - .*/[^_]*\.l?hs$ 4 | excludes: 5 | - \# 6 | - flycheck 7 | commands: 8 | - stack haddock 9 | -------------------------------------------------------------------------------- /sosrc/stackage.sos: -------------------------------------------------------------------------------- 1 | ## These are for preparing for a stackage release 2 | - patterns: 3 | - .*\.l?hs$ 4 | - .*\.cabal 5 | - .*stack\.yaml$ 6 | commands: 7 | - stack --resolver lts-3 --install-ghc test --fast # for ghc 7.10.2 8 | - stack --resolver lts-5 --install-ghc test --fast # for ghc 7.10.3 9 | - stack --resolver nightly --install-ghc test --fast 10 | - stack build --fast --stack-yaml=stack80-ghcjs.yaml 11 | -------------------------------------------------------------------------------- /src/Control/Varying.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Control.Varying 3 | -- Copyright: (c) 2016 Schell Scivally 4 | -- License: MIT 5 | -- Maintainer: Schell Scivally 6 | -- 7 | -- [@Core@] 8 | -- Automaton based value streams. 9 | -- 10 | -- [@Event@] 11 | -- Discontinuous value streams that occur only sometimes. 12 | -- 13 | -- [@Spline@] 14 | -- Sequencing of value and event streams using do-notation to form complex 15 | -- behavior. 16 | -- 17 | -- [@Tween@] 18 | -- Tween numerical values over time using common easing functions. Great for 19 | -- animation. 20 | -- 21 | module Control.Varying ( 22 | -- * Reexports 23 | module V 24 | ) where 25 | 26 | import Control.Varying.Core as V 27 | import Control.Varying.Event as V 28 | import Control.Varying.Spline as V 29 | import Control.Varying.Tween as V 30 | -------------------------------------------------------------------------------- /src/Control/Varying/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | -- | 7 | -- Module: Control.Varying.Core 8 | -- Copyright: (c) 2015 Schell Scivally 9 | -- License: MIT 10 | -- Maintainer: Schell Scivally 11 | -- 12 | -- Varying values represent values that change over a given domain. 13 | -- 14 | -- A varying value takes some input as its domain (e.g. time, place, etc) 15 | -- and when run using 'runVarT' it produces a value and a new varying value. 16 | -- This pattern is known as an automaton and `varying` uses this pattern at its 17 | -- core. With the additon of monadic event sequencing, 'varying' makes it easy 18 | -- to construct complicated signals that control program and data flow. 19 | module Control.Varying.Core 20 | ( -- * Types and Typeclasses 21 | Var 22 | , VarT(..) 23 | -- * Creating vars 24 | -- $creation 25 | , done 26 | , var 27 | , arr 28 | , varM 29 | , mkState 30 | -- * Composing vars 31 | -- $composition 32 | , (<<<) 33 | , (>>>) 34 | -- * Adjusting and accumulating 35 | , delay 36 | , accumulate 37 | -- * Sampling vars (running and other entry points) 38 | -- $running 39 | , scanVar 40 | , stepMany 41 | -- * Debugging and tracing vars in flight 42 | , vtrace 43 | , vstrace 44 | , vftrace 45 | , testVarOver 46 | -- * Proofs of the Applicative laws 47 | -- $proofs 48 | ) where 49 | 50 | import Control.Applicative 51 | import Control.Arrow 52 | import Control.Category 53 | import Control.Monad 54 | import Control.Monad.Fix 55 | import Control.Monad.IO.Class 56 | import Data.Functor.Contravariant 57 | import Data.Functor.Identity 58 | import Debug.Trace 59 | import Prelude hiding (id, (.)) 60 | 61 | -------------------------------------------------------------------------------- 62 | -- Core datatypes 63 | -------------------------------------------------------------------------------- 64 | -- | A continuously varying value, with effects. 65 | -- It's a kind of 66 | -- (an automaton). 67 | newtype VarT m a b 68 | = VarT 69 | { runVarT :: a -> m (b, VarT m a b) } 70 | -- ^ Run a @VarT@ computation with an input value of 71 | -- type 'a', yielding a step - a value of type 'b' 72 | -- and a new computation for yielding the next step. 73 | 74 | 75 | -- | A var parameterized with Identity that takes input of type @a@ 76 | -- and gives output of type @b@. This is the pure, effect-free version of 77 | -- 'VarT'. 78 | type Var a b = VarT Identity a b 79 | 80 | -------------------------------------------------------------------------------- 81 | -- Typeclass instances 82 | -------------------------------------------------------------------------------- 83 | -- | You can transform the output value of any var: 84 | -- 85 | -- >>> let v = 1 >>> fmap (*3) (accumulate (+) 0) 86 | -- >>> testVarOver v [(),(),()] 87 | -- 3 88 | -- 6 89 | -- 9 90 | instance Applicative m => Functor (VarT m b) where 91 | fmap f v = VarT $ (g <$>) . runVarT v 92 | where g (b, vb) = (f b, f <$> vb) 93 | 94 | -- | A var is a category. 95 | -- 96 | -- @ 97 | -- id = var id 98 | -- f . g = g >>> f 99 | -- @ 100 | -- 101 | -- or 102 | -- 103 | -- > f . g = f <<< g 104 | -- 105 | -- >>> let v = accumulate (+) 0 . 1 106 | -- >>> testVarOver v [(),(),()] 107 | -- 1 108 | -- 2 109 | -- 3 110 | instance Monad m => Category (VarT m) where 111 | id = var id 112 | f0 . g0 = VarT $ \a -> do 113 | (b, g) <- runVarT g0 a 114 | (c, f) <- runVarT f0 b 115 | return (c, f . g) 116 | 117 | -- | Vars are applicative. 118 | -- 119 | -- >>> let v = (,) <$> pure True <*> pure "Applicative" 120 | -- >>> testVarOver v [()] 121 | -- (True,"Applicative") 122 | -- 123 | -- Note - checkout the <$proofs proofs> 124 | instance Applicative m => Applicative (VarT m a) where 125 | pure = done 126 | vf <*> vx = VarT $ \a -> 127 | g <$> runVarT vf a <*> runVarT vx a 128 | where g (f, vf1) (x, vx1) = (f x, vf1 <*> vx1) 129 | 130 | -- | Vars are arrows, which means you can use proc notation, among other 131 | -- meanings. 132 | -- 133 | -- >>> :set -XArrows 134 | -- >>> :{ 135 | -- let v = proc t -> do 136 | -- x <- accumulate (+) 0 -< t 137 | -- y <- accumulate (+) 1 -< t 138 | -- returnA -< x + y 139 | -- in testVarOver v [1,1,1] 140 | -- >>> :} 141 | -- 3 142 | -- 5 143 | -- 7 144 | -- 145 | -- which is equivalent to 146 | -- 147 | -- >>> let v = (+) <$> accumulate (+) 0 <*> accumulate (+) 1 148 | -- >>> testVarOver v [1,1,1] 149 | -- 3 150 | -- 5 151 | -- 7 152 | instance Monad m => Arrow (VarT m) where 153 | arr = var 154 | first v = VarT $ \(b, d) -> g d <$> runVarT v b 155 | where g d (c, v') = ((c, d), first v') 156 | 157 | instance MonadPlus m => ArrowZero (VarT m) where 158 | zeroArrow = varM $ const mzero 159 | 160 | instance MonadPlus m => ArrowPlus (VarT m) where 161 | VarT f <+> VarT g = VarT $ \a -> f a `mplus` g a 162 | 163 | -- | 164 | instance Monad m => ArrowChoice (VarT m) where 165 | left f = f +++ arr id 166 | right f = arr id +++ f 167 | f +++ g = (f >>> arr Left) ||| (g >>> arr Right) 168 | f ||| g = VarT $ \case 169 | Left b -> do 170 | (d, f1) <- runVarT f b 171 | return (d, f1 ||| g) 172 | Right c -> do 173 | (d, g1) <- runVarT g c 174 | return (d, f ||| g1) 175 | 176 | -- | Inputs can depend on outputs as long as no time-travel is required. 177 | -- 178 | -- This isn't the best example but it does make a good test case: 179 | -- 180 | -- >>> :{ 181 | -- let 182 | -- testVar :: VarT IO Double (Maybe Double) 183 | -- testVar = proc val -> do 184 | -- rec _ <- returnA -< 0.5 185 | -- returnA -< Just 5.0 186 | -- in 187 | -- testVarOver testVar [5.0] 188 | -- >>> :} 189 | -- Just 5.0 190 | instance MonadFix m => ArrowLoop (VarT m) where 191 | loop vmbdcd = VarT $ \b -> fmap fst $ mfix $ \(~(_, d)) -> do 192 | ((c1, d1), vmbdcd1) <- runVarT vmbdcd (b, d) 193 | return ((c1, loop vmbdcd1), d1) 194 | 195 | -- | VarT with its input and output parameters flipped. 196 | newtype FlipVarT m b a = FlipVarT { unFlipVarT :: VarT m a b } 197 | 198 | -- | A VarT is contravariant when the type arguments are flipped. 199 | instance Monad m => Contravariant (FlipVarT m b) where 200 | contramap f (FlipVarT vmab) = FlipVarT $ VarT $ \c -> do 201 | (b, vmab1) <- runVarT vmab $ f c 202 | return (b, unFlipVarT $ contramap f $ FlipVarT vmab1) 203 | 204 | #if __GLASGOW_HASKELL__ >= 804 205 | -- | Vars can be semigroups 206 | -- 207 | -- >>> let v = var (const "Hello ") <> var (const "World!") 208 | -- >>> testVarOver v [()] 209 | -- "Hello World!" 210 | instance (Applicative m, Semigroup b) => Semigroup (VarT m a b) where 211 | (<>) = liftA2 (<>) 212 | #endif 213 | 214 | -- | Vars can be monoids 215 | -- 216 | -- >>> let v = var (const "Hello ") `mappend` var (const "World!") 217 | -- >>> testVarOver v [()] 218 | -- "Hello World!" 219 | instance (Applicative m, Monoid b) => Monoid (VarT m a b) where 220 | mempty = pure mempty 221 | mappend = liftA2 mappend 222 | 223 | -- | Vars can be written as numbers. 224 | -- 225 | -- >>> let v = 1 >>> accumulate (+) 0 226 | -- >>> testVarOver v [(),(),()] 227 | -- 1 228 | -- 2 229 | -- 3 230 | instance (Monad m, Num b) => Num (VarT m a b) where 231 | (+) = liftA2 (+) 232 | (-) = liftA2 (-) 233 | (*) = liftA2 (*) 234 | abs = fmap abs 235 | signum = fmap signum 236 | fromInteger = pure . fromInteger 237 | 238 | -- | Vars can be written as floats. 239 | -- 240 | -- >>> let v = pi >>> accumulate (*) 1 >>> arr round 241 | -- >>> testVarOver v [(),(),()] 242 | -- 3 243 | -- 10 244 | -- 31 245 | instance (Monad m, Floating b) => Floating (VarT m a b) where 246 | pi = pure pi 247 | exp = fmap exp 248 | log = fmap log 249 | sin = fmap sin; sinh = fmap sinh; asin = fmap asin; asinh = fmap asinh 250 | cos = fmap cos; cosh = fmap cosh; acos = fmap acos; acosh = fmap acosh 251 | atan = fmap atan; atanh = fmap atanh 252 | 253 | -- | Vars can be written as fractionals. 254 | -- 255 | -- >>> let v = 2.5 >>> accumulate (/) 10 256 | -- >>> testVarOver v [(),(),()] 257 | -- 4.0 258 | -- 1.6 259 | -- 0.64 260 | instance (Monad m, Fractional b) => Fractional (VarT m a b) where 261 | (/) = liftA2 (/) 262 | fromRational = pure . fromRational 263 | -------------------------------------------------------------------------------- 264 | -- $creation 265 | -- You can create a pure var by lifting a function @(a -> b)@ 266 | -- with 'var': 267 | -- 268 | -- > arr (+1) == var (+1) :: VarT m Int Int 269 | -- 270 | -- 'var' is a parameterized version of 'arr'. 271 | -- 272 | -- You can create a monadic var by lifting a monadic computation 273 | -- @(a -> m b)@ using 'varM': 274 | -- 275 | -- @ 276 | -- getsFile :: VarT IO FilePath String 277 | -- getsFile = varM readFile 278 | -- @ 279 | -- 280 | -- You can create either with the raw constructor. You can also create your 281 | -- own combinators using the raw constructor, as it allows you full control 282 | -- over how vars are stepped and sampled: 283 | -- 284 | -- > delay :: Monad m => b -> VarT m a b -> VarT m a b 285 | -- > delay b v = VarT $ \a -> return (b, go a v) 286 | -- > where go a v' = VarT $ \a' -> do (b', v'') <- runVarT v' a 287 | -- > return (b', go a' v'') 288 | -- > 289 | -------------------------------------------------------------------------------- 290 | -- | Lift a pure computation to a var. This is 'arr' parameterized over the 291 | -- @a `VarT m` b@ arrow. 292 | var :: Applicative m => (a -> b) -> VarT m a b 293 | var f = VarT $ \a -> pure (f a, var f) 294 | 295 | -- | Lift a monadic computation to a var. This is 296 | -- 297 | -- parameterized over the @a `VarT m` b@ arrow. 298 | varM :: Monad m => (a -> m b) -> VarT m a b 299 | varM f = VarT $ \a -> do 300 | b <- f a 301 | return (b, varM f) 302 | 303 | -- | Lift a constant value to a var. 304 | done :: Applicative m => b -> VarT m a b 305 | done = var . const 306 | 307 | -- | Create a var from a state transformer. 308 | mkState :: Monad m 309 | => (a -> s -> (b, s)) -- ^ state transformer 310 | -> s -- ^ intial state 311 | -> VarT m a b 312 | mkState f s = VarT $ \a -> do 313 | let (b', s') = f a s 314 | return (b', mkState f s') 315 | -------------------------------------------------------------------------------- 316 | -- $composition 317 | -- You can compose vars together using Category's '>>>' and '<<<'. The "right 318 | -- plug" ('>>>') takes the output from a var on the left and "plugs" it into 319 | -- the input of the var on the right. The "left plug" does the same thing in 320 | -- the opposite direction. This allows you to write vars that read 321 | -- naturally. 322 | -------------------------------------------------------------------------------- 323 | -------------------------------------------------------------------------------- 324 | -- Adjusting and accumulating 325 | -------------------------------------------------------------------------------- 326 | -- | Accumulates input values using a folding function and yields 327 | -- that accumulated value each sample. This is analogous to a stepwise foldl. 328 | -- 329 | -- >>> testVarOver (accumulate (++) []) $ words "hey there man" 330 | -- "hey" 331 | -- "heythere" 332 | -- "heythereman" 333 | -- 334 | -- >>> print $ foldl (++) [] $ words "hey there man" 335 | -- "heythereman" 336 | accumulate :: Monad m => (c -> b -> c) -> c -> VarT m b c 337 | accumulate f b = VarT $ \a -> do 338 | let b' = f b a 339 | return (b', accumulate f b') 340 | 341 | -- | Delays the given var by one sample using the argument as the first 342 | -- sample. 343 | -- 344 | -- >>> testVarOver (delay 0 id) [1,2,3] 345 | -- 0 346 | -- 1 347 | -- 2 348 | -- 349 | -- This enables the programmer to create vars that depend on 350 | -- themselves for values. For example: 351 | -- 352 | -- >>> let v = delay 0 v + 1 in testVarOver v [1,1,1] 353 | -- 1 354 | -- 2 355 | -- 3 356 | delay :: Monad m => b -> VarT m a b -> VarT m a b 357 | delay b v = VarT $ \a -> return (b, go a v) 358 | where go a v' = VarT $ \a' -> do (b', v'') <- runVarT v' a 359 | return (b', go a' v'') 360 | -------------------------------------------------------------------------------- 361 | -- $running 362 | -- To sample a var simply run it in the desired monad with 363 | -- 'runVarT'. This will produce a sample value and a new var. 364 | -- 365 | -- >>> :{ 366 | -- do let v0 = accumulate (+) 0 367 | -- (b, v1) <- runVarT v0 1 368 | -- print b 369 | -- (c, v2) <- runVarT v1 b 370 | -- print c 371 | -- (d, _) <- runVarT v2 c 372 | -- print d 373 | -- >>> :} 374 | -- 1 375 | -- 2 376 | -- 4 377 | -------------------------------------------------------------------------------- 378 | -- | Iterate a var over a list of input until all input is consumed, 379 | -- then iterate the var using one single input. Returns the resulting 380 | -- output value and the new var. 381 | -- 382 | -- >>> let Identity (outputs, _) = stepMany (accumulate (+) 0) [1,1,1] 1 383 | -- >>> print outputs 384 | -- 4 385 | stepMany :: (Monad m) => VarT m a b -> [a] -> a -> m (b, VarT m a b) 386 | stepMany v [] e = runVarT v e 387 | stepMany v (e:es) x = snd <$> runVarT v e >>= \v1 -> stepMany v1 es x 388 | 389 | -- | Run the var over the input values, gathering the output values in a 390 | -- list. 391 | -- 392 | -- >>> let Identity (outputs, _) = scanVar (accumulate (+) 0) [1,1,1,1] 393 | -- >>> print outputs 394 | -- [1,2,3,4] 395 | scanVar :: Monad m => VarT m a b -> [a] -> m ([b], VarT m a b) 396 | scanVar v = foldM f ([], v) 397 | where f (outs, v') a = do (b, v'') <- runVarT v' a 398 | return (outs ++ [b], v'') 399 | -------------------------------------------------------------------------------- 400 | -- Testing and debugging 401 | -------------------------------------------------------------------------------- 402 | -- | Trace the sample value of a var and pass it along as output. This is 403 | -- very useful for debugging graphs of vars. The (v|vs|vf)trace family of 404 | -- vars use 'Debug.Trace.trace' under the hood, so the value is only traced 405 | -- when evaluated. 406 | -- 407 | -- >>> let v = id >>> vtrace 408 | -- >>> testVarOver v [1,2,3] 409 | -- 1 410 | -- 1 411 | -- 2 412 | -- 2 413 | -- 3 414 | -- 3 415 | vtrace :: (Applicative a, Show b) => VarT a b b 416 | vtrace = vstrace "" 417 | 418 | 419 | -- | Trace the sample value of a var with a prefix and pass the sample along 420 | -- as output. This is very useful for debugging graphs of vars. 421 | -- 422 | -- >>> let v = id >>> vstrace "test: " 423 | -- >>> testVarOver v [1,2,3] 424 | -- test: 1 425 | -- 1 426 | -- test: 2 427 | -- 2 428 | -- test: 3 429 | -- 3 430 | vstrace :: (Applicative a, Show b) => String -> VarT a b b 431 | vstrace s = vftrace ((s ++) . show) 432 | 433 | -- | Trace the sample value using a custom show-like function. This is useful 434 | -- when you would like to debug a var that uses values that don't have show 435 | -- instances. 436 | -- 437 | -- >>> newtype NotShowableInt = NotShowableInt { unNotShowableInt :: Int } 438 | -- >>> let v = id >>> vftrace (("NotShowableInt: " ++) . show . unNotShowableInt) 439 | -- >>> let as = map NotShowableInt [1,1,1] 440 | -- >>> bs <- fst <$> scanVar v as 441 | -- >>> -- We need to do something to evaluate these output values... 442 | -- >>> print $ sum $ map unNotShowableInt bs 443 | -- NotShowableInt: 1 444 | -- NotShowableInt: 1 445 | -- NotShowableInt: 1 446 | -- 3 447 | vftrace :: Applicative a => (b -> String) -> VarT a b b 448 | vftrace f = var $ \b -> trace (f b) b 449 | 450 | -- | Run a var in IO over some input, printing the output each step. This is 451 | -- the function we've been using throughout this documentation. 452 | testVarOver :: (Monad m, MonadIO m, Show b) 453 | => VarT m a b -> [a] -> m () 454 | testVarOver v xs = fst <$> scanVar v xs >>= mapM_ (liftIO . print) 455 | -------------------------------------------------------------------------------- 456 | -- $proofs 457 | -- ==Identity 458 | -- > pure id <*> va = va 459 | -- 460 | -- > -- Definition of pure 461 | -- > VarT (\_ -> pure (id, pure id)) <*> v 462 | -- 463 | -- > -- Definition of <*> 464 | -- > VarT (\x -> do 465 | -- > (f, vf') <- runVarT (VarT (\_ -> pure (id, pure id))) x 466 | -- > (a, va') <- runVarT va x 467 | -- > pure (f a, vf' <*> va')) 468 | -- 469 | -- > -- Newtype 470 | -- > VarT (\x -> do 471 | -- > (f, vf') <- (\_ -> pure (id, pure id)) x 472 | -- > (a, va') <- runVarT va x 473 | -- > pure (f a, vf' <*> va')) 474 | -- 475 | -- > -- Application 476 | -- > VarT (\x -> do 477 | -- > (f, vf') <- pure (id, pure id) 478 | -- > (a, va') <- runVarT va x 479 | -- > pure (f a, vf' <*> va')) 480 | -- 481 | -- > -- pure x >>= f = f x 482 | -- > VarT (\x -> do 483 | -- > (a, va') <- runVarT va x 484 | -- > pure (id a, pure id <*> va')) 485 | -- 486 | -- > -- Definition of id 487 | -- > VarT (\x -> do 488 | -- > (a, va') <- runVarT va x 489 | -- > pure (a, pure id <*> va')) 490 | -- 491 | -- > -- Coinduction 492 | -- > VarT (\x -> do 493 | -- > (a, va') <- runVarT va x 494 | -- > pure (a, va')) 495 | -- 496 | -- > -- f >>= pure = f 497 | -- > VarT (\x -> runVarT va x) 498 | -- 499 | -- > -- Eta reduction 500 | -- > VarT (runVarT va) 501 | -- 502 | -- > -- Newtype 503 | -- > va 504 | -- > 505 | -- 506 | -- ==Composition 507 | -- > pure (.) <*> u <*> v <*> w = u <*> (v <*> w) 508 | -- 509 | -- > -- Definition of pure 510 | -- > VarT (\_ -> pure ((.), pure (.))) <*> u <*> v <*> w 511 | -- 512 | -- > -- Definition of <*> 513 | -- > VarT (\x -> do 514 | -- > (h, t) <- runVarT (VarT (\_ -> pure ((.), pure (.)))) x 515 | -- > (f, u') <- runVarT u x 516 | -- > pure (h f, t <*> u')) <*> v <*> w 517 | -- 518 | -- > -- Newtype 519 | -- > VarT (\x -> do 520 | -- > (h, t) <- (\_ -> pure ((.), pure (.))) x 521 | -- > (f, u') <- runVarT u x 522 | -- > pure (h f, t <*> u')) <*> v <*> w 523 | -- 524 | -- > -- Application 525 | -- > VarT (\x -> do 526 | -- > (h, t) <- pure ((.), pure (.))) 527 | -- > (f, u') <- runVarT u x 528 | -- > pure (h f, t <*> u')) <*> v <*> w 529 | -- 530 | -- > -- pure x >>= f = f x 531 | -- > VarT (\x -> do 532 | -- > (f, u') <- runVarT u x 533 | -- > pure ((.) f, pure (.) <*> u')) <*> v <*> w 534 | -- 535 | -- > -- Definition of <*> 536 | -- > VarT (\x -> do 537 | -- > (h, t) <- 538 | -- > runVarT 539 | -- > (VarT (\y -> do 540 | -- > (f, u') <- runVarT u y 541 | -- > pure ((.) f, pure (.) <*> u'))) x 542 | -- > (g, v') <- runVarT v x 543 | -- > pure (h g, t <*> v')) <*> w 544 | -- 545 | -- > -- Newtype 546 | -- > VarT (\x -> do 547 | -- > (h, t) <- 548 | -- > (\y -> do 549 | -- > (f, u') <- runVarT u y 550 | -- > pure ((.) f, pure (.) <*> u')) x 551 | -- > (g, v') <- runVarT v x 552 | -- > pure (h g, t <*> v')) <*> w 553 | -- 554 | -- > -- Application 555 | -- > VarT (\x -> do 556 | -- > (h, t) <- do 557 | -- > (f, u') <- runVarT u x 558 | -- > pure ((.) f, pure (.) <*> u') 559 | -- > (g, v') <- runVarT v x 560 | -- > pure (h g, t <*> v')) <*> w 561 | -- 562 | -- > -- (f >=> g) >=> h = f >=> (g >=> h) 563 | -- > VarT (\x -> do 564 | -- > (f, u') <- runVarT u x 565 | -- > (h, t) <- pure ((.) f, pure (.) <*> u') 566 | -- > (g, v') <- runVarT v x 567 | -- > pure (h g, t <*> v')) <*> w 568 | -- 569 | -- > -- pure x >>= f = f x 570 | -- > VarT (\x -> do 571 | -- > (f, u') <- runVarT u x 572 | -- > (g, v') <- runVarT v x 573 | -- > pure ((.) f g, pure (.) <*> u' <*> v')) <*> w 574 | -- 575 | -- > -- Definition of <*> 576 | -- > VarT (\x -> do 577 | -- > (h, t) <- 578 | -- > runVarT 579 | -- > (VarT (\y -> do 580 | -- > (f, u') <- runVarT u y 581 | -- > (g, v') <- runVarT v y 582 | -- > pure ((.) f g, pure (.) <*> u' <*> v'))) x 583 | -- > (a, w') <- runVarT w x 584 | -- > pure (h a, t <*> w')) 585 | -- 586 | -- > -- Newtype 587 | -- > VarT (\x -> do 588 | -- > (h, t) <- 589 | -- > (\y -> do 590 | -- > (f, u') <- runVarT u y 591 | -- > (g, v') <- runVarT v y 592 | -- > pure ((.) f g, pure (.) <*> u' <*> v')) x 593 | -- > (a, w') <- runVarT w x 594 | -- > pure (h a, t <*> w')) 595 | -- 596 | -- > -- Application 597 | -- > VarT (\x -> do 598 | -- > (h, t) <- do 599 | -- > (f, u') <- runVarT u x 600 | -- > (g, v') <- runVarT v x 601 | -- > pure ((.) f g, pure (.) <*> u' <*> v')) 602 | -- > (a, w') <- runVarT w x 603 | -- > pure (h a, t <*> w')) 604 | -- 605 | -- > -- (f >=> g) >=> h = f >=> (g >=> h) 606 | -- > VarT (\x -> do 607 | -- > (f, u') <- runVarT u x 608 | -- > (g, v') <- runVarT v x 609 | -- > (h, t) <- pure ((.) f g, pure (.) <*> u' <*> v')) 610 | -- > (a, w') <- runVarT w x 611 | -- > pure (h a, t <*> w')) 612 | -- 613 | -- > -- pure x >>= f = f x 614 | -- > VarT (\x -> do 615 | -- > (f, u') <- runVarT u x 616 | -- > (g, v') <- runVarT v x 617 | -- > (a, w') <- runVarT w x 618 | -- > pure ((.) f g a, pure (.) <*> u' <*> v' <*> w')) 619 | -- 620 | -- > -- Definition of . 621 | -- > VarT (\x -> do 622 | -- > (f, u') <- runVarT u x 623 | -- > (g, v') <- runVarT v x 624 | -- > (a, w') <- runVarT w x 625 | -- > pure (f (g a), pure (.) <*> u' <*> v' <*> w')) 626 | -- 627 | -- > -- Coinduction 628 | -- > VarT (\x -> do 629 | -- > (f, u') <- runVarT u x 630 | -- > (g, v') <- runVarT v x 631 | -- > (a, w') <- runVarT w x 632 | -- > pure (f (g a), u' <*> (v' <*> w'))) 633 | -- 634 | -- > -- pure x >>= f = f 635 | -- > VarT (\x -> do 636 | -- > (f, u') <- runVarT u x 637 | -- > (g, v') <- runVarT v x 638 | -- > (a, w') <- runVarT w x 639 | -- > (b, vw) <- pure (g a, v' <*> w') 640 | -- > pure (f b, u' <*> vw)) 641 | -- 642 | -- > -- (f >=> g) >=> h = f >=> (g >=> h) 643 | -- > VarT (\x -> do 644 | -- > (f, u') <- runVarT u x 645 | -- > (b, vw) <- do 646 | -- > (g, v') <- runVarT v x 647 | -- > (a, w') <- runVarT w x 648 | -- > pure (g a, v' <*> w') 649 | -- > pure (f b, u' <*> vw)) 650 | -- 651 | -- > -- Abstraction 652 | -- > VarT (\x -> do 653 | -- > (f, u') <- runVarT u x 654 | -- > (b, vw) <- 655 | -- > (\y -> do 656 | -- > (g, v') <- runVarT v y 657 | -- > (a, w') <- runVarT w y) 658 | -- > pure (g a, v' <*> w')) x 659 | -- > pure (f b, u' <*> vw)) 660 | -- 661 | -- > -- Newtype 662 | -- > VarT (\x -> do 663 | -- > (f, u') <- runVarT u x 664 | -- > (b, vw) <- 665 | -- > runVarT 666 | -- > (VarT (\y -> do 667 | -- > (g, v') <- runVarT v y 668 | -- > (a, w') <- runVarT w y) 669 | -- > pure (g a, v' <*> w')) x 670 | -- > pure (f b, u' <*> vw)) 671 | -- 672 | -- > -- Definition of <*> 673 | -- > VarT (\x -> do 674 | -- > (f, u') <- runVarT u x 675 | -- > (b, vw) <- runVarT (v <*> w) x 676 | -- > pure (f b, u' <*> vw)) 677 | -- 678 | -- > -- Definition of <*> 679 | -- > u <*> (v <*> w) 680 | -- 681 | -- 682 | -- ==Homomorphism 683 | -- > pure f <*> pure a = pure (f a) 684 | -- 685 | -- > -- Definition of pure 686 | -- > VarT (\_ -> pure (f, pure f)) <*> pure a 687 | -- 688 | -- > -- Definition of pure 689 | -- > VarT (\_ -> pure (f, pure f)) <*> VarT (\_ -> pure (a, pure a)) 690 | -- 691 | -- > -- Definition of <*> 692 | -- > VarT (\x -> do 693 | -- > (f', vf') <- runVarT (VarT (\_ -> pure (f, pure f))) x 694 | -- > (a', va') <- runVarT (VarT (\_ -> pure (a, pure a))) x 695 | -- > pure (f' a', vf' <*> va')) 696 | -- 697 | -- > -- Newtype 698 | -- > VarT (\x -> do 699 | -- > (f', vf') <- (\_ -> pure (f, pure f)) x 700 | -- > (a', va') <- runVarT (VarT (\_ -> pure (a, pure a))) x 701 | -- > pure (f' a', vf' <*> va')) 702 | -- 703 | -- > -- Application 704 | -- > VarT (\x -> do 705 | -- > (f', vf') <- pure (f, pure f) 706 | -- > (a', va') <- runVarT (VarT (\_ -> pure (a, pure a))) x 707 | -- > pure (f' a', vf' <*> va')) 708 | -- 709 | -- > -- pure x >>= f = f x 710 | -- > VarT (\x -> do 711 | -- > (a', va') <- runVarT (VarT (\_ -> pure (a, pure a))) x 712 | -- > pure (f a', pure f <*> va')) 713 | -- 714 | -- > -- Newtype 715 | -- > VarT (\x -> do 716 | -- > (a', va') <- (\_ -> pure (a, pure a)) x 717 | -- > pure (f a', pure f <*> va')) 718 | -- 719 | -- > -- Application 720 | -- > VarT (\x -> do 721 | -- > (a', va') <- pure (a, pure a) 722 | -- > pure (f a', pure f <*> va')) 723 | -- 724 | -- > -- pure x >>= f = f x 725 | -- > VarT (\x -> pure (f a, pure f <*> pure a)) 726 | -- 727 | -- > -- Coinduction 728 | -- > VarT (\x -> pure (f a, pure (f a))) 729 | -- 730 | -- > -- Definition of pure 731 | -- > pure (f a) 732 | -- 733 | -- 734 | -- ==Interchange 735 | -- > u <*> pure y = pure ($ y) <*> u 736 | -- 737 | -- > -- Definition of <*> 738 | -- > VarT (\x -> do 739 | -- > (f, u') <- runVarT u x 740 | -- > (a, y') <- runVarT (pure y) x 741 | -- > pure (f a, u' <*> y')) 742 | -- 743 | -- > -- Definition of pure 744 | -- > VarT (\x -> do 745 | -- > (f, u') <- runVarT u x 746 | -- > (a, y') <- runVarT (VarT (\_ -> pure (y, pure y))) x 747 | -- > pure (f a, u' <*> y')) 748 | -- 749 | -- > -- Newtype 750 | -- > VarT (\x -> do 751 | -- > (f, u') <- runVarT u x 752 | -- > (a, y') <- (\_ -> pure (y, pure y)) x 753 | -- > pure (f a, u' <*> y')) 754 | -- 755 | -- > -- Application 756 | -- > VarT (\x -> do 757 | -- > (f, u') <- runVarT u x 758 | -- > (a, y') <- pure (y, pure y)) 759 | -- > pure (f a, u' <*> y')) 760 | -- 761 | -- > -- pure x >>= f = f 762 | -- > VarT (\x -> do 763 | -- > (f, u') <- runVarT u x 764 | -- > pure (f y, u' <*> pure y)) 765 | -- 766 | -- > -- Coinduction 767 | -- > VarT (\x -> do 768 | -- > (f, u') <- runVarT u x 769 | -- > pure (f y, pure ($ y) <*> u')) 770 | -- 771 | -- > -- Definition of $ 772 | -- > VarT (\x -> do 773 | -- > (f, u') <- runVarT u x 774 | -- > pure (($ y) f, pure ($ y) <*> u') 775 | -- 776 | -- > -- pure x >>= f = f 777 | -- > VarT (\x -> do 778 | -- > (g, y') <- pure (($ y), pure ($ y)) 779 | -- > (f, u') <- runVarT u x 780 | -- > pure (g f, y' <*> u') 781 | -- 782 | -- > -- Abstraction 783 | -- > VarT (\x -> do 784 | -- > (g, y') <- (\_ -> pure (($ y), pure ($ y))) x 785 | -- > (f, u') <- runVarT u x 786 | -- > pure (g f, y' <*> u') 787 | -- 788 | -- > -- Newtype 789 | -- > VarT (\x -> do 790 | -- > (g, y') <- runVarT (VarT (\_ -> pure (($ y), pure ($ y)))) x 791 | -- > (f, u') <- runVarT u x 792 | -- > pure (g f, y' <*> u') 793 | -- 794 | -- > -- Definition of <*> 795 | -- > VarT (\_ -> pure (($ y), pure ($ y))) <*> u 796 | -- 797 | -- > -- Definition of pure 798 | -- > pure ($ y) <*> u 799 | -------------------------------------------------------------------------------- /src/Control/Varying/Event.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | -- | 3 | -- Module: Control.Varying.Event 4 | -- Copyright: (c) 2015 Schell Scivally 5 | -- License: MIT 6 | -- Maintainer: Schell Scivally 7 | -- 8 | -- An event stream is simply a stream of @Maybe a@. This kind of stream is 9 | -- considered to be only defined at those occurances of @Just a@. Events 10 | -- describe things that happen at a specific time, place or any collection of 11 | -- inputs. 12 | -- 13 | -- For example, you can think of the event stream 14 | -- @'VarT' 'IO' 'Double' ('Event' ())@ as an occurrence of @()@ at a specific 15 | -- value of 'Double'. It is possible that this 'Double' is time, or it could be 16 | -- the number of ice cream sandwiches eaten by a particular cat. 17 | -- 18 | -- In `varying` we use event streams to dynamically update the network while it 19 | -- is running. For more info on switching and sequencing streams with events 20 | -- please check out 'Control.Varying.Spline', which lets you chain together 21 | -- sequences of values and events using a familiar do-notation. 22 | 23 | module Control.Varying.Event 24 | ( -- * Event constructors (synonyms of Maybe) 25 | Event 26 | , event 27 | , noevent 28 | -- * Generating events from value streams 29 | , use 30 | , onTrue 31 | , onUnique 32 | , onWhen 33 | -- * Folding and gathering event streams 34 | , foldStream 35 | , startingWith, startWith 36 | -- * Combining multiple event streams 37 | , bothE 38 | , anyE 39 | -- * List-like operations on event streams 40 | , filterE 41 | , takeE 42 | , dropE 43 | -- * Primitive event streams 44 | , once 45 | , always 46 | , never 47 | , before 48 | , after 49 | -- * Switching 50 | , switch 51 | -- * Bubbling 52 | , onlyWhen 53 | , onlyWhenE 54 | ) where 55 | 56 | import Control.Applicative 57 | import Control.Monad 58 | import Control.Varying.Core 59 | import Data.Foldable (foldl') 60 | import Prelude hiding (until) 61 | 62 | type Event = Maybe 63 | 64 | -- | A synonym for the @Maybe@ constructor @Just@. 65 | event :: a -> Event a 66 | event = Just 67 | 68 | -- | A synonym for the @Maybe@ constructor @Nothing@. 69 | noevent :: Event a 70 | noevent = Nothing 71 | -------------------------------------------------------------------------------- 72 | -- Generating events from values 73 | -------------------------------------------------------------------------------- 74 | -- | 75 | -- @ 76 | -- 'use' :: 'Monad' m => b -> 'VarT' m a ('Event' x) -> 'VarT' m a ('Event' b) 77 | -- @ 78 | -- 79 | -- Populates a varying Event with a value. This is meant to be used with 80 | -- the various @on...@ event triggers. For example, 81 | -- @ 82 | -- 'use' 1 'onTrue' 83 | -- @ 84 | -- produces values of @'Event' 1@ when the input value is 'True'. 85 | use :: (Functor f, Functor e) => a -> f (e b) -> f (e a) 86 | use a v = (a <$) <$> v 87 | 88 | -- | Triggers an @'Event' ()@ when the input value is 'True'. 89 | -- 90 | -- @ 91 | -- 'use' b 'onTrue' :: 'Monad' m => 'VarT' m 'Bool' ('Event' b) 92 | -- @ 93 | onTrue :: Monad m => VarT m Bool (Event ()) 94 | onTrue = var $ \b -> if b then Just () else Nothing 95 | 96 | -- | Triggers an @'Event' a@ when the input is distinct from the previous 97 | -- input. 98 | -- 99 | -- @ 100 | -- 'use' b 'onUnique' :: ('Eq' x, 'Monad' m) => 'VarT' m x ('Event' b) 101 | -- @ 102 | onUnique :: (Monad m, Eq a) => VarT m a (Event a) 103 | onUnique = VarT $ \a -> return (Just a, trigger a) 104 | where trigger a' = VarT $ \a'' -> let e = if a' == a'' 105 | then Nothing 106 | else Just a'' 107 | in return (e, trigger a'') 108 | 109 | -- | Triggers an @'Event' a@ when the condition is met. 110 | onWhen :: Applicative m => (a -> Bool) -> VarT m a (Event a) 111 | onWhen f = var $ \a -> if f a then Just a else Nothing 112 | -------------------------------------------------------------------------------- 113 | -- Collecting 114 | -------------------------------------------------------------------------------- 115 | -- | Like a left fold over all the stream's produced values. 116 | foldStream :: Monad m => (a -> t -> a) -> a -> VarT m (Event t) a 117 | foldStream f acc = VarT $ \e -> 118 | case e of 119 | Just a -> let acc' = f acc a 120 | in return (acc', foldStream f acc') 121 | Nothing -> return (acc, foldStream f acc) 122 | 123 | 124 | -- | Produces the given value until the input events produce a value, then 125 | -- produce that value until a new input event produces. This always holds 126 | -- the last produced value, starting with the given value. 127 | -- 128 | -- @ 129 | -- time '>>>' 'Control.Varying.Time.after' 3 '>>>' 'startingWith' 0 130 | -- @ 131 | -- 132 | -- >>> :{ 133 | -- let v = onWhen (== 3) >>> startingWith 0 134 | -- in testVarOver v [0, 1, 2, 3, 4] 135 | -- >>> :} 136 | -- 0 137 | -- 0 138 | -- 0 139 | -- 3 140 | -- 3 141 | startWith, startingWith 142 | :: Monad m 143 | => a 144 | -> VarT m (Event a) a 145 | startWith = foldStream (\_ a -> a) 146 | startingWith = startWith 147 | 148 | -- | Stream through some number of successful 'Event's and then inhibit 149 | -- forever. 150 | takeE :: Monad m 151 | => Int -> VarT m a (Event b) -> VarT m a (Event b) 152 | takeE 0 _ = never 153 | takeE n ve = VarT $ \a -> do 154 | (eb, ve') <- runVarT ve a 155 | case eb of 156 | Nothing -> return (Nothing, takeE n ve') 157 | Just b -> return (Just b, takeE (n-1) ve') 158 | 159 | -- | Inhibit the first n occurences of an 'Event'. 160 | dropE :: Monad m 161 | => Int -> VarT m a (Event b) -> VarT m a (Event b) 162 | dropE 0 ve = ve 163 | dropE n ve = VarT $ \a -> do 164 | (eb, ve') <- runVarT ve a 165 | case eb of 166 | Nothing -> return (Nothing, dropE n ve') 167 | Just _ -> return (Nothing, dropE (n-1) ve') 168 | 169 | -- | Inhibit all 'Event's that don't pass the predicate. 170 | filterE :: Monad m 171 | => (b -> Bool) -> VarT m a (Event b) -> VarT m a (Event b) 172 | filterE p v = (join . (check <$>)) <$> v 173 | where check b = if p b then Just b else Nothing 174 | -------------------------------------------------------------------------------- 175 | -- Using multiple streams 176 | -------------------------------------------------------------------------------- 177 | -- | Combine two 'Event' streams. Produces an event only when both streams proc 178 | -- at the same time. 179 | bothE :: Monad m 180 | => (a -> b -> c) -> VarT m a (Event a) -> VarT m a (Event b) 181 | -> VarT m a (Event c) 182 | bothE f va vb = (\ea eb -> f <$> ea <*> eb) <$> va <*> vb 183 | 184 | -- | Combine two 'Event' streams and produce an 'Event' any time either stream 185 | -- produces. In the case that both streams produce, this produces the 'Event' 186 | -- of the leftmost stream. 187 | anyE :: Monad m => [VarT m a (Event b)] -> VarT m a (Event b) 188 | anyE [] = never 189 | anyE vs = VarT $ \a -> do 190 | outs <- mapM (`runVarT` a) vs 191 | let f (eb, vs1) (eb1, v) = (msum [eb, eb1], vs1 ++ [v]) 192 | return (anyE <$> foldl' f (Nothing, []) outs) 193 | -------------------------------------------------------------------------------- 194 | -- Primitive event streams 195 | -------------------------------------------------------------------------------- 196 | -- | Produce the given event value once and then inhibit forever. 197 | once :: Monad m => b -> VarT m a (Event b) 198 | once b = VarT $ \_ -> return (Just b, never) 199 | 200 | -- | Never produces any 'Event' values. 201 | -- 202 | -- @ 203 | -- 'never' = 'pure' 'Nothing' 204 | -- @ 205 | never :: Monad m => VarT m b (Event c) 206 | never = pure Nothing 207 | 208 | -- | Produces 'Event's with the initial value forever. 209 | -- 210 | -- @ 211 | -- 'always' e = 'pure' ('Event' e) 212 | -- @ 213 | always :: Monad m => b -> VarT m a (Event b) 214 | always = pure . Just 215 | 216 | -- | Emits events before accumulating t of input dt. 217 | -- Note that as soon as we have accumulated >= t we stop emitting events 218 | -- and therefore an event will never be emitted exactly at time == t. 219 | before :: (Monad m, Num t, Ord t) => t -> VarT m t (Event t) 220 | before t = accumulate (+) 0 >>> onWhen (< t) 221 | 222 | -- | Emits events after t input has been accumulated. 223 | -- Note that event emission is not guaranteed to begin exactly at t, 224 | -- since it depends on the input. 225 | after :: (Monad m, Num t, Ord t) => t -> VarT m t (Event t) 226 | after t = accumulate (+) 0 >>> onWhen (>= t) 227 | 228 | -------------------------------------------------------------------------------- 229 | -- Switching 230 | -------------------------------------------------------------------------------- 231 | -- | Higher-order switching. 232 | -- Use an event stream of value streams and produces event values of the latest 233 | -- produced value stream. Switches to a new value stream each time one is 234 | -- produced. The currently used value stream maintains local state until the 235 | -- outer event stream produces a new value stream. 236 | -- 237 | -- In this example we're sequencing the value streams we'd like to use and then 238 | -- switching them when the outer event stream fires. 239 | -- 240 | -- >>> import Control.Varying.Spline 241 | -- >>> :{ 242 | -- let v :: VarT IO () (Event Int) 243 | -- v = switch $ flip outputStream Nothing $ do 244 | -- step $ Just $ 1 >>> accumulate (+) 0 245 | -- step Nothing 246 | -- step Nothing 247 | -- step $ Just 5 248 | -- step Nothing 249 | -- in testVarOver v [(), (), (), (), ()] -- testing over five frames 250 | -- >>> :} 251 | -- Just 1 252 | -- Just 2 253 | -- Just 3 254 | -- Just 5 255 | -- Just 5 256 | switch 257 | :: Monad m 258 | => VarT m a (Event (VarT m a b)) 259 | -> VarT m a (Event b) 260 | switch = switchGo $ pure Nothing 261 | where switchGo vInner v = VarT $ \a -> runVarT v a >>= \case 262 | (Nothing, vOuter) -> do 263 | (mayB, vInner1) <- runVarT vInner a 264 | return (mayB, switchGo vInner1 vOuter) 265 | (Just vInner2, vOuter) -> do 266 | (mayB, vInner3) <- runVarT (Just <$> vInner2) a 267 | return (mayB, switchGo vInner3 vOuter) 268 | 269 | -------------------------------------------------------------------------------- 270 | -- Bubbling 271 | -------------------------------------------------------------------------------- 272 | -- | Produce events of a stream @v@ only when an event stream @h@ produces an 273 | -- event. 274 | -- @v@ and @h@ maintain state while cold. 275 | onlyWhenE :: Monad m 276 | => VarT m a b -- ^ @v@ - The value stream 277 | -> VarT m a (Event c) -- ^ @h@ - The event stream 278 | -> VarT m a (Event b) 279 | onlyWhenE v hot = VarT $ \a -> do 280 | (e, hot') <- runVarT hot a 281 | case e of 282 | Just _ -> do (b, v') <- runVarT v a 283 | return (Just b, onlyWhenE v' hot') 284 | _ -> return (Nothing, onlyWhenE v hot') 285 | 286 | -- | Produce 'Event's of a value stream @v@ only when its input value passes a 287 | -- predicate @f@. 288 | -- @v@ maintains state while cold. 289 | onlyWhen :: Monad m 290 | => VarT m a b -- ^ @v@ - The value stream 291 | -> (a -> Bool) -- ^ @f@ - The predicate to run on @v@'s input values. 292 | -> VarT m a (Event b) 293 | onlyWhen v f = v `onlyWhenE` hot 294 | where hot = var id >>> onWhen f 295 | -------------------------------------------------------------------------------- /src/Control/Varying/Spline.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Control.Varying.Spline 3 | -- Copyright: (c) 2015 Schell Scivally 4 | -- License: MIT 5 | -- Maintainer: Schell Scivally 6 | -- 7 | -- Using splines we can easily create continuous streams from discontinuous 8 | -- streams. A spline is a monadic layer on top of event streams which are only 9 | -- continuous over a certain domain. The idea is that we use a monad to 10 | -- "run a stream switched by events". This means taking two streams - an output 11 | -- stream and an event stream, and combining them into a temporarily producing 12 | -- stream. Once that "stream pair" inhibits, the computation completes and 13 | -- returns a result value. That result value is then used to determine the next 14 | -- spline in the sequence. 15 | {-# LANGUAGE FlexibleContexts #-} 16 | {-# LANGUAGE GADTs #-} 17 | {-# LANGUAGE LambdaCase #-} 18 | module Control.Varying.Spline 19 | ( -- * Spline 20 | Spline 21 | -- * Spline Transformer 22 | , SplineT(..) 23 | -- * Creating streams from splines 24 | , outputStream 25 | -- * Creating splines from streams 26 | , fromEvent 27 | , untilProc 28 | , whileProc 29 | , untilEvent 30 | , untilEvent_ 31 | , _untilEvent 32 | , _untilEvent_ 33 | -- * Other runners 34 | , scanSpline 35 | -- * Combinators 36 | , step 37 | , race 38 | , raceAny 39 | , merge 40 | , capture 41 | , mapOutput 42 | , adjustInput 43 | -- * Hand Proofs of the Monad laws 44 | -- $proofs 45 | ) where 46 | 47 | import Control.Monad 48 | import Control.Monad.IO.Class 49 | import Control.Monad.Trans.Class 50 | import Control.Varying.Core 51 | import Control.Varying.Event 52 | import Data.Functor.Identity 53 | 54 | 55 | -- | 'SplineT' shares all the types of 'VarT' and adds a result value. Its 56 | -- monad, input and output types (@m@, @a@ and @b@, respectively) represent the 57 | -- same parameters in 'VarT'. A spline adds a result type which represents the 58 | -- monadic computation's result value. 59 | -- 60 | -- A spline either concludes in a result or it produces an output value and 61 | -- another spline. This makes it a stream that eventually ends. We can use this 62 | -- to set up our streams in a monadic fashion, where the end result of one spline 63 | -- can be used to determine the next spline to run. Using 'outputStream' we can 64 | -- then fuse these piecewise continuous (but otherwise discontinuous) streams 65 | -- into one continuous stream of type @VarT m a b@. Alternatively you can simply 66 | -- poll the network until it ends using 'runSplineT'. 67 | newtype SplineT a b m c = 68 | SplineT { runSplineT :: a -> m (Either c (b, SplineT a b m c)) } 69 | 70 | -- | A spline is a functor by applying the function to the result of the 71 | -- spline. This does just what you would expect of other Monads such as 'StateT' 72 | -- or 'Maybe'. 73 | -- 74 | -- >>> :{ 75 | -- let s0 = pure "first" `untilEvent` (1 >>> after 2) 76 | -- s = do str <- fmap show s0 77 | -- step str 78 | -- v = outputStream s "" 79 | -- in testVarOver v [(),()] 80 | -- >>> :} 81 | -- "first" 82 | -- "(\"first\",2)" 83 | instance Monad m => Functor (SplineT a b m) where 84 | fmap f (SplineT s) = SplineT $ s >=> \case 85 | Left c -> return $ Left $ f c 86 | Right (b, s1) -> return $ Right (b, fmap f s1) 87 | 88 | -- | A spline responds to bind by running until it concludes in a value, 89 | -- then uses that value to run the next spline. 90 | -- 91 | -- Note - checkout the <$proofs proofs> 92 | instance Monad m => Monad (SplineT a b m) where 93 | return = SplineT . const . return . Left 94 | (SplineT s0) >>= f = SplineT $ g s0 95 | where g s a = do e <- s a 96 | case e of 97 | Left c -> runSplineT (f c) a 98 | Right (b, SplineT s1) -> return $ Right (b, SplineT $ g s1) 99 | 100 | 101 | -- | A spline responds to 'pure' by returning a spline that never produces an 102 | -- output value and immediately returns the argument. It responds to '<*>' by 103 | -- applying the left arguments result value (the function) to the right 104 | -- arguments result value (the argument), sequencing them both in serial. 105 | -- 106 | -- @ 107 | -- pure = return 108 | -- sf <*> sx = do 109 | -- f <- sf 110 | -- x <- sx 111 | -- return $ f x 112 | -- @ 113 | instance Monad m => Applicative (SplineT a b m) where 114 | pure = return 115 | sf <*> sx = do 116 | f <- sf 117 | f <$> sx 118 | 119 | 120 | -- | A spline is a transformer by running the effect and immediately concluding, 121 | -- using the effect's result as the result value. 122 | -- 123 | -- >>> :{ 124 | -- let s = do () <- lift $ print "Hello" 125 | -- step 2 126 | -- v = outputStream s 0 127 | -- in testVarOver v [()] 128 | -- >>> :} 129 | -- "Hello" 130 | -- 2 131 | instance MonadTrans (SplineT a b) where 132 | lift f = SplineT $ const $ Left <$> f 133 | 134 | -- | A spline can do IO if its underlying monad has a MonadIO instance. It 135 | -- takes the result of the IO action as its immediate return value. 136 | instance (Monad m, MonadIO m) => MonadIO (SplineT a b m) where 137 | liftIO = lift . liftIO 138 | 139 | -- | A SplineT monad parameterized with Identity that takes input of type @a@, 140 | -- output of type @b@ and a result value of type @c@. 141 | type Spline a b c = SplineT a b Identity c 142 | 143 | -- | Permute a spline into one continuous stream. Since a spline is not 144 | -- guaranteed to be defined over any domain (specifically on its edges), this 145 | -- function takes a default value to use as the "last known value". 146 | -- 147 | -- >>> :{ 148 | -- let s :: SplineT () String IO () 149 | -- s = do first <- pure "accumulating until 3" `_untilEvent` (1 >>> after 3) 150 | -- secnd <- pure "accumulating until 4" `_untilEvent` (1 >>> after 4) 151 | -- if first + secnd == 7 152 | -- then step "done" 153 | -- else step "something went wrong!" 154 | -- v = outputStream s "" 155 | -- in testVarOver v $ replicate 6 () 156 | -- >>> :} 157 | -- "accumulating until 3" 158 | -- "accumulating until 3" 159 | -- "accumulating until 4" 160 | -- "accumulating until 4" 161 | -- "accumulating until 4" 162 | -- "done" 163 | outputStream :: Monad m 164 | => SplineT a b m c -> b -> VarT m a b 165 | outputStream (SplineT s0) b0 = VarT $ f s0 b0 166 | where f s b a = do e <- s a 167 | case e of 168 | Left _ -> return (b, done b) 169 | Right (b1, SplineT s1) -> return (b1, VarT $ f s1 b1) 170 | 171 | -- | Run the spline over the input values, gathering the output values in a 172 | -- list. 173 | scanSpline :: Monad m 174 | => SplineT a b m c -> b -> [a] -> m [b] 175 | scanSpline s b = fmap fst <$> scanVar (outputStream s b) 176 | 177 | -- | Create a spline from an event stream. 178 | fromEvent :: Monad m => VarT m a (Event b) -> SplineT a (Event b) m b 179 | fromEvent ve = SplineT $ \a -> do 180 | (e, ve1) <- runVarT ve a 181 | return $ case e of 182 | Just b -> Left b 183 | Nothing -> Right (Nothing, fromEvent ve1) 184 | 185 | -- | Create a spline from an event stream. Outputs 'noevent' until the event 186 | -- stream procs, at which point the spline concludes with the event value. 187 | untilProc :: Monad m => VarT m a (Event b) -> SplineT a (Event b) m b 188 | untilProc ve = SplineT $ runVarT ve >=> return . \case 189 | (Just b, _) -> Left b 190 | (Nothing, ve1) -> Right (Nothing, untilProc ve1) 191 | 192 | -- | Create a spline from an event stream. Outputs @b@ until the event stream 193 | -- inhibits, at which point the spline concludes with @()@. 194 | whileProc :: Monad m => VarT m a (Event b) -> SplineT a b m () 195 | whileProc ve = SplineT $ runVarT ve >=> return . \case 196 | (Just b, ve1) -> Right (b, whileProc ve1) 197 | (Nothing, _) -> Left () 198 | 199 | -- | Create a spline from a stream and an event stream. The spline 200 | -- uses the stream's values as its own output values. The spline will run until 201 | -- the event stream produces an event, at that point the last known output 202 | -- value and the event value are tupled and returned as the spline's result. 203 | untilEvent :: Monad m 204 | => VarT m a b -> VarT m a (Event c) -> SplineT a b m (b,c) 205 | untilEvent v ve = SplineT $ f ((,) <$> v <*> ve) 206 | where f vve a = do t <-runVarT vve a 207 | return $ case t of 208 | ((b, Nothing), vve1) -> Right (b, SplineT $ f vve1) 209 | ((b, Just c), _) -> Left (b, c) 210 | 211 | -- | A variant of 'untilEvent' that results in the last known output value. 212 | untilEvent_ :: Monad m 213 | => VarT m a b -> VarT m a (Event c) -> SplineT a b m b 214 | untilEvent_ v ve = fst <$> untilEvent v ve 215 | 216 | -- | A variant of 'untilEvent' that results in the event steam's event value. 217 | _untilEvent :: Monad m 218 | => VarT m a b -> VarT m a (Event c) -> SplineT a b m c 219 | _untilEvent v ve = snd <$> untilEvent v ve 220 | 221 | -- | A variant of 'untilEvent' that discards both the output and event values. 222 | _untilEvent_ :: Monad m 223 | => VarT m a b -> VarT m a (Event c) -> SplineT a b m () 224 | _untilEvent_ v ve = void $ _untilEvent v ve 225 | 226 | -- | Run two splines in parallel, combining their output. Return the result of 227 | -- the spline that concludes first. If they conclude at the same time the result 228 | -- is taken from the left spline. 229 | -- 230 | -- >>> :{ 231 | -- let s1 = pure "route " `_untilEvent` (1 >>> after 2) 232 | -- s2 = pure 666 `_untilEvent` (1 >>> after 3) 233 | -- s = do winner <- race (\l r -> l ++ show r) s1 s2 234 | -- step $ show winner 235 | -- v = outputStream s "" 236 | -- in testVarOver v [(),(),()] 237 | -- >>> :} 238 | -- "route 666" 239 | -- "Left 2" 240 | -- "Left 2" 241 | race :: Monad m 242 | => (a -> b -> c) -> SplineT i a m d -> SplineT i b m e 243 | -> SplineT i c m (Either d e) 244 | race f sa0 sb0 = SplineT (g sa0 sb0) 245 | where g sa sb i = runSplineT sa i >>= \case 246 | Left d -> return $ Left $ Left d 247 | Right (a, sa1) -> runSplineT sb i >>= \case 248 | Left e -> return $ Left $ Right e 249 | Right (b, sb1) -> return $ Right (f a b, SplineT $ g sa1 sb1) 250 | 251 | -- | Run many splines in parallel, combining their output with 'mappend'. 252 | -- Returns the result of the spline that concludes first. If any conclude at the 253 | -- same time the leftmost result will be returned. 254 | -- 255 | -- >>> :{ 256 | -- let ss = [ pure "hey " `_untilEvent` (1 >>> after 5) 257 | -- , pure "there" `_untilEvent` (1 >>> after 3) 258 | -- , pure "!" `_untilEvent` (1 >>> after 2) 259 | -- ] 260 | -- s = do winner <- raceAny ss 261 | -- step $ show winner 262 | -- v = outputStream s "" 263 | -- in testVarOver v [(),()] 264 | -- >>> :} 265 | -- "hey there!" 266 | -- "2" 267 | raceAny :: (Monad m, Monoid b) 268 | => [SplineT a b m c] -> SplineT a b m c 269 | raceAny [] = pure mempty `_untilEvent` never 270 | raceAny ss = SplineT $ f [] (map runSplineT ss) mempty 271 | where f ys [] b _ = return $ Right (b, SplineT $ f [] ys mempty) 272 | f ys (v:vs) b a = v a >>= \case 273 | Left c -> return $ Left c 274 | Right (b1, s) -> f (ys ++ [runSplineT s]) vs (b <> b1) a 275 | 276 | -- | Run two splines in parallel, combining their output. Once both splines 277 | -- have concluded, return the results of each in a tuple. 278 | -- 279 | -- >>> :{ 280 | -- let s1 = pure "hey " `_untilEvent` (1 >>> after 3) 281 | -- s2 = pure "there!" `_untilEvent` (1 >>> after 2) 282 | -- s = do tuple <- merge (++) s1 s2 283 | -- step $ show tuple 284 | -- v = outputStream s "" 285 | -- in testVarOver v [(),(),()] 286 | -- >>> :} 287 | -- "hey there!" 288 | -- "hey " 289 | -- "(3,2)" 290 | merge :: Monad m 291 | => (b -> b -> b) 292 | -> SplineT a b m c -> SplineT a b m d -> SplineT a b m (c, d) 293 | merge apnd s1 s2 = SplineT $ f s1 s2 294 | 295 | where r c d = return $ Left (c, d) 296 | 297 | fr c vb = runSplineT vb >=> \case 298 | Left d -> r c d 299 | Right (b, vb1) -> return $ Right (b, SplineT $ fr c vb1) 300 | 301 | fl d va = runSplineT va >=> \case 302 | Left c -> r c d 303 | Right (b, va1) -> return $ Right (b, SplineT $ fl d va1) 304 | 305 | f va vb a = runSplineT va a >>= \case 306 | Left c -> fr c vb a 307 | Right (b1, va1) -> runSplineT vb a >>= \case 308 | Left d -> return $ Right (b1, SplineT $ fl d va1) 309 | Right (b2, vb1) -> return $ Right (apnd b1 b2, SplineT $ f va1 vb1) 310 | 311 | -- | Capture the spline's last output value and tuple it with the 312 | -- spline's result. This is helpful when you want to sample the last 313 | -- output value in order to determine the next spline to sequence. 314 | -- 315 | -- The tupled value is returned in as a 'Maybe b' since it is not 316 | -- guaranteed that an output value is produced before a Spline concludes. 317 | -- 318 | -- >>> :{ 319 | -- let 320 | -- s :: MonadIO m => SplineT () Int m String 321 | -- s = do 322 | -- (mayX, boomStr) <- 323 | -- capture 324 | -- $ do 325 | -- step 0 326 | -- step 1 327 | -- step 2 328 | -- return "boom" 329 | -- -- x is 2, but 'capture' can't be sure of that 330 | -- maybe 331 | -- (return "Failure") 332 | -- ( (>> return boomStr) 333 | -- . step 334 | -- . (+1) 335 | -- ) 336 | -- mayX 337 | -- in 338 | -- testVarOver (outputStream s 666) [(),(),(),()] 339 | -- >>> :} 340 | -- 0 341 | -- 1 342 | -- 2 343 | -- 3 344 | capture 345 | :: Monad m 346 | => SplineT a b m c 347 | -> SplineT a b m (Maybe b, c) 348 | capture = SplineT . f Nothing 349 | where f mb s = runSplineT s >=> return . \case 350 | Left c -> Left (mb, c) 351 | Right (b, s1) -> Right (b, SplineT $ f (Just b) s1) 352 | 353 | -- | Produce the argument as an output value exactly once. 354 | -- 355 | -- >>> :{ 356 | -- let s = do step "hi" 357 | -- step "there" 358 | -- step "friend" 359 | -- in testVarOver (outputStream s "") [1,2,3,4] 360 | -- >>> :} 361 | -- "hi" 362 | -- "there" 363 | -- "friend" 364 | -- "friend" 365 | step :: Monad m => b -> SplineT a b m () 366 | step b = SplineT $ const $ return $ Right (b, return ()) 367 | 368 | -- | Map the output value of a spline. 369 | -- 370 | -- >>> :{ 371 | -- let s = mapOutput (pure show) $ step 1 >> step 2 >> step 3 372 | -- in testVarOver (outputStream s "") [(),(),()] 373 | -- >>> :} 374 | -- "1" 375 | -- "2" 376 | -- "3" 377 | mapOutput :: Monad m 378 | => VarT m a (b -> t) -> SplineT a b m c -> SplineT a t m c 379 | mapOutput vf0 s0 = SplineT $ g vf0 s0 380 | where g vf s a = do 381 | (f, vf1) <- runVarT vf a 382 | flip fmap (runSplineT s a) $ \case 383 | Left c -> Left c 384 | Right (b, s1) -> Right (f b, SplineT $ g vf1 s1) 385 | 386 | -- | Map the input value of a spline. 387 | adjustInput :: Monad m 388 | => VarT m a (a -> r) -> SplineT r b m c -> SplineT a b m c 389 | adjustInput vf0 s = SplineT $ g vf0 s 390 | where g vf sx a = do 391 | (f, vf1) <- runVarT vf a 392 | flip fmap (runSplineT sx (f a)) $ \case 393 | Left c -> Left c 394 | Right (b, sx1) -> Right (b, SplineT $ g vf1 sx1) 395 | 396 | -------------------------------------------------------------------------------- 397 | -- $proofs 398 | -- ==Left Identity 399 | -- > k =<< return c = k c 400 | -- 401 | -- > -- Definition of =<< 402 | -- > fix (\f s -> 403 | -- > SplineT (\a -> 404 | -- > runSplineT s a >>= \case 405 | -- > Left c -> runSplineT (k c) a 406 | -- > Right s' -> return (Right (fmap f s')))) (return c) 407 | -- 408 | -- > -- Definition of fix 409 | -- > (\s -> 410 | -- > SplineT (\a -> 411 | -- > runSplineT s a >>= \case 412 | -- > Left c -> runSplineT (k c) a 413 | -- > Right s' -> return (Right (fmap (k =<<) s')))) (return c) 414 | -- 415 | -- > -- Application 416 | -- > SplineT (\a -> 417 | -- > runSplineT (return c) a >>= \case 418 | -- > Left c -> runSplineT (k c) a 419 | -- > Right s' -> return (Right (fmap (k =<<) s'))) 420 | -- 421 | -- > -- Definition of return 422 | -- > SplineT (\a -> 423 | -- > runSplineT (SplineT (\_ -> return (Left c))) a >>= \case 424 | -- > Left c -> runSplineT (k c) a 425 | -- > Right s' -> return (Right (fmap (k =<<) s'))) 426 | -- 427 | -- > -- Newtype 428 | -- > SplineT (\a -> 429 | -- > (\_ -> return (Left c)) a >>= \case 430 | -- > Left c -> runSplineT (k c) a 431 | -- > Right s' -> return (Right (fmap (k =<<) s'))) 432 | -- 433 | -- > -- Application 434 | -- > SplineT (\a -> 435 | -- > return (Left c) >>= \case 436 | -- > Left c -> runSplineT (k c) a 437 | -- > Right s' -> return (Right (fmap (k =<<) s'))) 438 | -- 439 | -- > -- return x >>= f = f x 440 | -- > SplineT (\a -> 441 | -- > case (Left c) of 442 | -- > Left c -> runSplineT (k c) a 443 | -- > Right s' -> return (Right (fmap (k =<<) s'))) 444 | -- 445 | -- > -- Case evaluation 446 | -- > SplineT (\a -> runSplineT (k c) a) 447 | -- 448 | -- > -- Eta reduction 449 | -- > SplineT (runSplineT (k c)) 450 | -- 451 | -- > -- Newtype 452 | -- > k c 453 | -- 454 | -- ==Right Identity 455 | -- > return =<< m = m 456 | -- 457 | -- > -- Definition of =<< 458 | -- > fix (\f s -> 459 | -- > SplineT (\a -> 460 | -- > runSplineT s a >>= \case 461 | -- > Left c -> runSplineT (return c) a 462 | -- > Right s' -> return (Right (fmap f s')))) m 463 | -- 464 | -- > -- Definition of fix 465 | -- > (\s -> 466 | -- > SplineT (\a -> 467 | -- > runSplineT s a >>= \case 468 | -- > Left c -> runSplineT (return c) a 469 | -- > Right s' -> return (Right (fmap (return =<<) s')))) m 470 | -- 471 | -- > -- Application 472 | -- > SplineT (\a -> 473 | -- > runSplineT m a >>= \case 474 | -- > Left c -> runSplineT (return c) a 475 | -- > Right s' -> return (Right (fmap (return =<<) s'))) 476 | -- 477 | -- > -- Definition of return 478 | -- > SplineT (\a -> 479 | -- > runSplineT m a >>= \case 480 | -- > Left c -> runSplineT (SplineT (\_ -> return (Left c))) a 481 | -- > Right s' -> return (Right (fmap (return =<<) s'))) 482 | -- 483 | -- > -- Newtype 484 | -- > SplineT (\a -> 485 | -- > runSplineT m a >>= \case 486 | -- > Left c -> (\_ -> return (Left c)) a 487 | -- > Right s' -> return (Right (fmap (return =<<) s'))) 488 | -- 489 | -- > -- Application 490 | -- > SplineT (\a -> 491 | -- > runSplineT m a >>= \case 492 | -- > Left c -> return (Left c) 493 | -- > Right s' -> return (Right (fmap (return =<<) s'))) 494 | -- 495 | -- > -- m >>= return . f = fmap f m 496 | -- > SplineT (\a -> fmap (either id (fmap (return =<<))) (runSplineT m a)) 497 | -- 498 | -- > -- Coinduction 499 | -- > SplineT (\a -> fmap (either id (fmap id)) (runSplineT m a)) 500 | -- 501 | -- > -- fmap id = id 502 | -- > SplineT (\a -> fmap (either id id) (runSplineT m a)) 503 | -- 504 | -- > -- either id id = id 505 | -- > SplineT (\a -> fmap id (runSplineT m a)) 506 | -- 507 | -- > -- fmap id = id 508 | -- > SplineT (\a -> runSplineT m a) 509 | -- 510 | -- > -- Eta reduction 511 | -- > SplineT (runSplineT m) 512 | -- 513 | -- > -- Newtype 514 | -- > m 515 | -- 516 | -- ==Application 517 | -- > (m >>= f) >>= g = m >>= (\x -> f x >>= g) 518 | 519 | -- TODO: Finish the rest of the hand proofs 520 | -------------------------------------------------------------------------------- /src/Control/Varying/Tween.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Control.Varying.Tween 3 | -- Copyright: (c) 2016 Schell Scivally 4 | -- License: MIT 5 | -- Maintainer: Schell Scivally 6 | -- 7 | -- Tweening is a technique of generating intermediate samples of a type 8 | -- __between__ a start and end value. By sampling a running tween 9 | -- each frame we get a smooth animation of a value over time. 10 | -- 11 | -- At first release `varying` is only capable of tweening numerical 12 | -- values of type @(Fractional t, Ord t) => t@ that match the type of 13 | -- time you use. At some point it would be great to be able to tween 14 | -- arbitrary types, and possibly tween one type into another (pipe 15 | -- dreams). 16 | {-# LANGUAGE DeriveGeneric #-} 17 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 18 | {-# LANGUAGE Rank2Types #-} 19 | {-# LANGUAGE ScopedTypeVariables #-} 20 | module Control.Varying.Tween 21 | ( -- * Tweening types 22 | Easing 23 | , TweenT 24 | , Tween 25 | -- * Creating tweens 26 | -- $creation 27 | , tween 28 | , tween_ 29 | , constant 30 | , withTween 31 | , withTween_ 32 | -- * Combining tweens 33 | -- $combining 34 | -- * Interpolation functions 35 | -- $lerping 36 | , linear 37 | , easeInCirc 38 | , easeOutCirc 39 | , easeInExpo 40 | , easeOutExpo 41 | , easeInSine 42 | , easeOutSine 43 | , easeInOutSine 44 | , easeInPow 45 | , easeOutPow 46 | , easeInCubic 47 | , easeOutCubic 48 | , easeInQuad 49 | , easeOutQuad 50 | -- * Running tweens 51 | , tweenStream 52 | , runTweenT 53 | , scanTween 54 | ) where 55 | 56 | import Control.Monad (void) 57 | import Control.Monad.Trans.State (StateT, evalStateT, get, put, 58 | runStateT) 59 | import Control.Monad.Trans.Class (MonadTrans (..)) 60 | import Control.Varying.Core (VarT (..), done) 61 | import Control.Varying.Event (after) 62 | import Control.Varying.Spline (SplineT (..), mapOutput, scanSpline, 63 | untilEvent_) 64 | import Data.Bifunctor (first, second) 65 | import Data.Functor.Identity (Identity) 66 | import GHC.Generics (Generic) 67 | 68 | 69 | -- $setup 70 | -- >>> import Control.Varying.Core 71 | 72 | 73 | -------------------------------------------------------------------------------- 74 | -- | An easing function. The parameters are often named `c`, `t` and `b`, 75 | -- where `c` is the total change in value over the complete duration 76 | -- (endValue - startValue), `t` is the current percentage (0 to 1) of the 77 | -- duration that has elapsed and `b` is the start value. 78 | -- 79 | -- To make things simple only numerical values can be tweened and the type 80 | -- of time deltas must match the tween's value type. This may change in the 81 | -- future :) 82 | type Easing t f = t -> f -> t -> t 83 | 84 | 85 | -------------------------------------------------------------------------------- 86 | -- $lerping 87 | -- These pure functions take a `c` (total change in value, ie end - start), 88 | -- `t` (percent of duration completion) and `b` (start value) and result in 89 | -- an interpolation of a value. To see what these look like please check 90 | -- out http://www.gizma.com/easing/. 91 | -------------------------------------------------------------------------------- 92 | 93 | 94 | -- | Ease in quadratic. 95 | easeInQuad :: (Fractional t, Real f) => Easing t f 96 | easeInQuad c t b = c * realToFrac (t*t) + b 97 | 98 | -- | Ease out quadratic. 99 | easeOutQuad :: (Fractional t, Real f) => Easing t f 100 | easeOutQuad c t b = (-c) * realToFrac (t * (t - 2)) + b 101 | 102 | -- | Ease in cubic. 103 | easeInCubic :: (Fractional t, Real f) => Easing t f 104 | easeInCubic c t b = c * realToFrac (t*t*t) + b 105 | 106 | -- | Ease out cubic. 107 | easeOutCubic :: (Fractional t, Real f) => Easing t f 108 | easeOutCubic c t b = let t' = realToFrac t - 1 in c * (t'*t'*t' + 1) + b 109 | 110 | -- | Ease in by some power. 111 | easeInPow :: (Fractional t, Real f) => Int -> Easing t f 112 | easeInPow power c t b = c * (realToFrac t^power) + b 113 | 114 | -- | Ease out by some power. 115 | easeOutPow :: (Fractional t, Real f) => Int -> Easing t f 116 | easeOutPow power c t b = 117 | let t' = realToFrac t - 1 118 | c' = if power `mod` 2 == 1 then c else -c 119 | i = if power `mod` 2 == 1 then 1 else -1 120 | in c' * ((t'^power) + i) + b 121 | 122 | -- | Ease in sinusoidal. 123 | easeInSine :: (Floating t, Real f) => Easing t f 124 | easeInSine c t b = let cos' = cos (realToFrac t * (pi / 2)) 125 | in -c * cos' + c + b 126 | 127 | -- | Ease out sinusoidal. 128 | easeOutSine :: (Floating t, Real f) => Easing t f 129 | easeOutSine c t b = let cos' = cos (realToFrac t * (pi / 2)) in c * cos' + b 130 | 131 | -- | Ease in and out sinusoidal. 132 | easeInOutSine :: (Floating t, Real f) => Easing t f 133 | easeInOutSine c t b = let cos' = cos (pi * realToFrac t) 134 | in (-c / 2) * (cos' - 1) + b 135 | 136 | -- | Ease in exponential. 137 | easeInExpo :: (Floating t, Real f) => Easing t f 138 | easeInExpo c t b = let e = 10 * (realToFrac t - 1) in c * (2**e) + b 139 | 140 | -- | Ease out exponential. 141 | easeOutExpo :: (Floating t, Real f) => Easing t f 142 | easeOutExpo c t b = let e = -10 * realToFrac t in c * (-(2**e) + 1) + b 143 | 144 | -- | Ease in circular. 145 | easeInCirc :: (Floating t, Real f, Floating f) => Easing t f 146 | easeInCirc c t b = let s = realToFrac $ sqrt (1 - t*t) in -c * (s - 1) + b 147 | 148 | -- | Ease out circular. 149 | easeOutCirc :: (Floating t, Real f) => Easing t f 150 | easeOutCirc c t b = let t' = (realToFrac t - 1) 151 | s = sqrt (1 - t'*t') 152 | in c * s + b 153 | 154 | -- | Ease linear. 155 | linear :: (Floating t, Real f) => Easing t f 156 | linear c t b = c * realToFrac t + b 157 | 158 | -- | A 'TweenT' is a 'SplineT' that holds a duration in local state. This allows 159 | -- 'TweenT's to be sequenced monadically. 160 | -- 161 | -- * 'f' is the input time delta type (the input type) 162 | -- * 't' is the start and end value type (the output type) 163 | -- * 'a' is the result value type 164 | -- 165 | -- You can sequence 'TweenT's with monadic notation to produce more complex ones. 166 | -- This is especially useful for animation: 167 | -- 168 | -- >>> :{ 169 | -- let 170 | -- tweenInOutExpo 171 | -- :: ( Monad m, Floating t, Real t, Real f, Fractional f ) 172 | -- => t 173 | -- -> t 174 | -- -> f 175 | -- -> TweenT f t m t 176 | -- tweenInOutExpo start end dur = do 177 | -- x <- tween easeInExpo start (end/2) (dur/2) 178 | -- tween easeOutExpo x end $ dur/2 179 | -- >>> :} 180 | newtype TweenT f t m a 181 | = TweenT { unTweenT :: SplineT f t (StateT f m) a } 182 | deriving (Generic, Functor, Applicative, Monad) 183 | 184 | 185 | instance MonadTrans (TweenT f t) where 186 | lift = TweenT . lift . lift 187 | 188 | 189 | type Tween f t a = TweenT f t Identity a 190 | 191 | 192 | runTweenT 193 | :: Functor m 194 | => TweenT f t m a 195 | -> f 196 | -- ^ The input time delta this frame 197 | -> f 198 | -- ^ The leftover time delta from last frame 199 | -> m (Either a (t, TweenT f t m a), f) 200 | -- ^ Returns 201 | -- @ 202 | -- a tuple of 203 | -- either 204 | -- the result 205 | -- or a tuple of 206 | -- this step's output value 207 | -- and the tween for the next step 208 | -- and the leftover time delta for the next step 209 | -- @ 210 | runTweenT (TweenT s) dt leftover = 211 | first (second $ second TweenT) 212 | <$> runStateT 213 | (runSplineT s dt) 214 | leftover 215 | 216 | 217 | scanTween 218 | :: (Monad m, Num f) 219 | => TweenT f t m a 220 | -> t 221 | -> [f] 222 | -> m [t] 223 | scanTween (TweenT s) t dts = 224 | evalStateT 225 | (scanSpline s t dts) 226 | 0 227 | 228 | 229 | -- | Converts a tween into a continuous value stream. This is the tween version 230 | -- of 'Control.Varying.Spline.outputStream'. This is the preferred way to run 231 | -- your tweens. 232 | -- 233 | -- >>> :{ 234 | -- let 235 | -- x :: TweenT Float Float IO Float 236 | -- x = tween linear 0 1 1 237 | -- y :: TweenT Float Float IO Float 238 | -- y = tween linear 0 1 2 239 | -- v :: VarT IO Float (Float, Float) 240 | -- v = (,) 241 | -- <$> tweenStream x 0 242 | -- <*> tweenStream y 0 243 | -- in 244 | -- testVarOver v [0.5, 0.5, 0.5, 0.5] 245 | -- >>> :} 246 | -- (0.5,0.25) 247 | -- (1.0,0.5) 248 | -- (1.0,0.75) 249 | -- (1.0,1.0) 250 | tweenStream 251 | :: forall m f t x 252 | . (Functor m, Monad m, Num f) 253 | => TweenT f t m x 254 | -- ^ The tween to convert into a stream 255 | -> t 256 | -- ^ An initial output value 257 | -> VarT m f t 258 | tweenStream s0 t0 = VarT $ go s0 t0 0 259 | where 260 | go :: 261 | TweenT f t m x -- The Tween 262 | -> t -- the last output value 263 | -> f -- the leftover time delta from last fram 264 | -> f -- the input time delta 265 | -> m (t, VarT m f t) 266 | go s t l i = do 267 | (e, l1) <- runTweenT s i l 268 | case e of 269 | Left _ -> return (t, done t) 270 | Right (b, s1) -> return (b, VarT $ go s1 b l1) 271 | 272 | 273 | -------------------------------------------------------------------------------- 274 | -- $creation 275 | -- The most direct route toward tweening values is to use 'tween' 276 | -- along with an interpolation function such as 'easeInExpo'. For example, 277 | -- @tween easeInExpo 0 100 10@, this will create a spline that produces a 278 | -- number interpolated from 0 to 100 over 10 seconds. At the end of the 279 | -- tween the spline will return the result value. 280 | -------------------------------------------------------------------------------- 281 | 282 | -- | Creates a spline that produces a value interpolated between a start and 283 | -- end value using an easing equation ('Easing') over a duration. The 284 | -- resulting spline will take a time delta as input. 285 | -- Keep in mind that `tween` must be fed time deltas, not absolute time or 286 | -- duration. This is mentioned because the author has made that mistake 287 | -- more than once ;) 288 | -- 289 | -- `tween` concludes returning the latest output value. 290 | tween :: (Monad m, Real t, Real f, Fractional f) 291 | => Easing t f -> t -> t -> f -> TweenT f t m t 292 | tween f start end dur = 293 | TweenT 294 | $ SplineT g 295 | where 296 | c = end - start 297 | b = start 298 | g dt = do 299 | leftover <- get 300 | let 301 | t = dt + leftover 302 | if t == dur 303 | then 304 | put 0 >> return (Right (end, return end)) 305 | else 306 | if t > dur 307 | then 308 | put (t - dur - dt) >> return (Left end) 309 | else 310 | put t >> return (Right (f c (t/dur) b, SplineT g)) 311 | 312 | 313 | -- | A version of 'tween' that discards the result. It is simply 314 | -- 315 | -- @ 316 | -- tween f a b c >> return () 317 | -- @ 318 | -- 319 | tween_ :: (Monad m, Real t, Real f, Fractional f) 320 | => Easing t f -> t -> t -> f -> TweenT f t m () 321 | tween_ f a b c = Control.Monad.void (tween f a b c) 322 | 323 | -- | A version of 'tween' that maps its output using the given constant 324 | -- function. 325 | -- 326 | -- @ 327 | -- withTween ease from to dur f = mapOutput (pure f) $ tween ease from to dur 328 | -- @ 329 | withTween :: (Monad m, Real t, Real a, Fractional a) 330 | => Easing t a -> t -> t -> a -> (t -> x) -> TweenT a x m t 331 | withTween ease from to dur f = 332 | TweenT 333 | $ mapOutput (pure f) 334 | $ unTweenT 335 | $ tween ease from to dur 336 | 337 | -- | A version of 'withTween' that discards its result. 338 | withTween_ :: (Monad m, Real t, Real a, Fractional a) 339 | => Easing t a -> t -> t -> a -> (t -> x) -> TweenT a x m () 340 | withTween_ ease from to dur f = Control.Monad.void (withTween ease from to dur f) 341 | 342 | -- | Creates a tween that performs no interpolation over the duration. 343 | constant :: (Monad m, Num t, Ord t) 344 | => a -> t -> TweenT t a m a 345 | constant value duration = 346 | TweenT 347 | $ pure value `untilEvent_` after duration 348 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-14.5 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | # Dependency packages to be pulled from upstream that are not in the resolver. 34 | # These entries can reference officially published versions as well as 35 | # forks / in-progress versions pinned to a git hash. For example: 36 | # 37 | # extra-deps: 38 | # - acme-missiles-0.3 39 | # - git: https://github.com/commercialhaskell/stack.git 40 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 41 | # 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=2.1" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /stack80-ghcjs.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2016-09-08 2 | compiler: ghcjs-0.2.0.820160908_ghc-8.0.1 3 | compiler-check: match-exact 4 | setup-info: 5 | ghcjs: 6 | source: 7 | ghcjs-0.2.0.820160908_ghc-8.0.1: 8 | url: "http://tolysz.org/ghcjs/untested/ghc-8.0-2016-09-08-nightly-2016-09-08-820160908.tar.gz" 9 | sha1: 68ab94c735ba5173603fb24fa7804541600750e1 10 | allow-newer: true 11 | 12 | packages: 13 | - . 14 | 15 | extra-deps: [] 16 | -------------------------------------------------------------------------------- /test/DocTests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.DocTest 4 | 5 | main :: IO () 6 | main = 7 | doctest ["src", "app"] 8 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Main where 4 | 5 | 6 | import Test.Hspec hiding (after, before) 7 | import Control.Varying 8 | import Control.Monad.IO.Class 9 | import Data.Functor.Identity 10 | import Data.Time.Clock 11 | 12 | main :: IO () 13 | main = hspec $ do 14 | describe "before" $ 15 | it "should produce events before a given step" $ do 16 | let varEv :: Var () (Maybe Int) 17 | varEv = 1 >>> before 3 18 | scans = fst $ runIdentity $ scanVar varEv $ replicate 4 () 19 | scans `shouldBe` [Just 1, Just 2, Nothing, Nothing] 20 | 21 | describe "after" $ 22 | it "should produce events after a given step" $ do 23 | let varEv :: Var () (Maybe Int) 24 | varEv = 1 >>> after 3 25 | scans = fst $ runIdentity $ scanVar varEv $ replicate 4 () 26 | scans `shouldBe` [Nothing, Nothing, Just 3, Just 4] 27 | 28 | describe "anyE" $ 29 | it "should produce on any event" $ do 30 | let v1,v2,v3 :: Var () (Maybe Int) 31 | v1 = use 1 ((1 :: Var () Int) >>> before 2) 32 | v2 = use 2 ((1 :: Var () Int) >>> after 3) 33 | v3 = always 3 34 | v = anyE [v1,v2,v3] 35 | scans = fst $ runIdentity $ scanVar v $ replicate 4 () 36 | scans `shouldBe` [Just 1, Just 3, Just 2, Just 2] 37 | describe "tween/tweenWith" $ do 38 | it "should step by the dt passed in" $ do 39 | let mytween :: Tween Double Double () 40 | mytween = tween_ linear 0 4 4 >> tween_ linear 4 0 4 41 | Identity scans = scanTween mytween 0 [0,1,1,1,1,1,1,1,1,1] 42 | scans `shouldBe` [0,1,2,3,4,3,2,1,0,0] 43 | it "should prevent infinite loops" $ do 44 | let mytween :: TweenT Double Double IO () 45 | mytween = tween_ linear 0 4 4 >> tween_ linear 4 0 4 >> mytween 46 | 47 | scans <- scanTween mytween 0 [6,1,1,1] 48 | scans `shouldBe` [2, 1, 0, 1] 49 | 50 | describe "untilEvent" $ do 51 | let Identity scans = scanSpline (3 `untilEvent` ((1 :: Var () Int) 52 | >>> after 10)) 53 | 0 54 | (replicate 10 ()) 55 | it "should produce output from the value stream until event procs" $ 56 | head scans `shouldBe` (3 :: Int) 57 | it "should produce output from the value stream until event procs" $ 58 | last scans `shouldBe` 3 59 | 60 | describe "step" $ do 61 | let s = do step "hey" 62 | step ", " 63 | step "there" 64 | step "." 65 | Identity scans = scanSpline s "" $ replicate 6 () 66 | it "should produce output exactly one time per call" $ 67 | concat scans `shouldBe` "hey, there..." 68 | 69 | describe "untilProc" $ do 70 | let s = do 71 | str <- untilProc $ var f 72 | step $ Just str 73 | step $ Just "done" 74 | f :: Int -> Maybe String 75 | f 0 = Nothing 76 | f 1 = Just "YES" 77 | f x = Just $ show x 78 | Identity scans = scanSpline s Nothing [0,0,0,1,0] 79 | it "should produce Nothing until it procs" $ 80 | scans `shouldBe` [Nothing,Nothing,Nothing,Just "YES",Just "done"] 81 | 82 | describe "lift/liftIO" $ do 83 | let s :: SplineT () String IO () 84 | s = do step "Getting the time..." 85 | utc <- liftIO getCurrentTime 86 | let t = head $ words $ show utc 87 | step t 88 | step "The End" 89 | it "should step once, get the time and then step with a string of the time" 90 | $ do utc <- getCurrentTime 91 | let t = head $ words $ show utc 92 | scans <- liftIO $ scanSpline s "" [(), (), ()] 93 | scans `shouldBe` ["Getting the time...", t, "The End"] 94 | describe "race" $ do 95 | let s1 = do step "s10" 96 | step "s11" 97 | step "s12" 98 | return (1 :: Int) 99 | s2 = do step "s20" 100 | step "s21" 101 | return True 102 | r = do step "start" 103 | eIntBool <- race (\a b -> concat [a,":",b]) s1 s2 104 | case eIntBool of 105 | Left i -> step $ "left won with " ++ show i 106 | Right b -> step $ "right won with " ++ show b 107 | Identity scans = scanSpline r "" $ replicate 4 () 108 | it "should step twice and left should win" $ 109 | unwords scans `shouldBe` "start s10:s20 s11:s21 right won with True" 110 | 111 | describe "raceAny" $ do 112 | let s1 :: Spline () String Int 113 | s1 = do step "t" 114 | step "c" 115 | return 0 116 | s2 = do step "h" 117 | step "a" 118 | return 1 119 | s3 = do step "e" 120 | step "t" 121 | return (2 :: Int) 122 | s = do x <- raceAny [s1,s2,s3] 123 | 124 | step $ show x 125 | Identity scans = scanSpline s "" $ replicate 3 () 126 | it "should output in parallel (mappend) and return the first or leftmost result" $ unwords scans `shouldBe` "the cat 0" 127 | 128 | describe "capture" $ do 129 | let r :: Spline () String () 130 | r = do x <- capture $ do step "a" 131 | step "b" 132 | return (2 :: Int) 133 | case x of 134 | (Just "b", 2) -> step "True" 135 | _ -> step "False" 136 | Identity scans = scanSpline r "" $ replicate 3 () 137 | it "should end with the last value captured" $ 138 | unwords scans `shouldBe` "a b True" 139 | 140 | describe "mapOutput" $ do 141 | let s :: Spline a Char () 142 | s = do step 'a' 143 | step 'b' 144 | step 'c' 145 | let f = pure toEnum 146 | mapOutput f $ do step 100 147 | step 101 148 | step 102 149 | step 'g' 150 | Identity scans = scanSpline s 'x' $ replicate 7 () 151 | it "should map the output" $ 152 | scans `shouldBe` "abcdefg" 153 | 154 | describe "adjustInput" $ do 155 | let s = var id `untilEvent_` never 156 | v :: Var a (Char -> Int) 157 | v = pure fromEnum 158 | s' = adjustInput v s 159 | Identity scans = scanSpline s' 0 "abcd" 160 | it "should" $ scans `shouldBe` [97,98,99,100] 161 | -------------------------------------------------------------------------------- 162 | -- Adherance to typeclass laws 163 | -------------------------------------------------------------------------------- 164 | -- Spline helpers 165 | let inc = 1 >>> accumulate (+) 0 166 | sinc :: Spline a Int (Int, Int) 167 | sinc = inc `untilEvent` (1 >>> after 3) 168 | go a = runIdentity (scanSpline a 0 [0..9]) 169 | equal a b = go a `shouldBe` go b 170 | 171 | -- Var helpers 172 | 173 | describe "spline's functor instance" $ do 174 | let sincf = fmap id sinc 175 | it "fmap id = id" $ equal sinc sincf 176 | let g :: (Int, Int) -> (Int, Int) 177 | g (x,y) = (x + 1, y) 178 | f (x,y) = (x - 1, y) 179 | sdot = fmap (g . f) sinc 180 | sfdot = fmap g $ fmap f sinc 181 | it "fmap (g . f) = fmap g . fmap f" $ equal sdot sfdot 182 | 183 | describe "var's applicative instance" $ do 184 | let f = (+1) 185 | x = 1 186 | it "(homomorphism) pure f <*> pure x = pure (f x)" $ 187 | fst (runIdentity $ scanVar (pure f <*> pure x) [0..5]) 188 | `shouldBe` fst (runIdentity $ scanVar (pure $ f x) [0..5]) 189 | 190 | describe "spline's applicative instance" $ do 191 | let ident = pure id <*> sinc 192 | it "(identity) pure id <*> v = v" $ equal ident sinc 193 | let pfpx :: Spline a Int Int 194 | pfpx = pure (+1) <*> pure 1 195 | pfx = pure (1+1) 196 | it "(homomorphism) pure f <*> pure x = pure (f x)" $ equal pfpx pfx 197 | let u :: Spline a Int (Int -> Int) 198 | u = pure 66 `_untilEvent` use (+1) (1 >>> after (3 :: Int)) 199 | upy = u <*> pure 1 200 | pyu = pure ($ 1) <*> u 201 | it "(interchange) u <*> pure y = pure ($ y) <*> u" $ equal upy pyu 202 | let v :: Spline a Int (Int -> Int) 203 | v = pure 66 `_untilEvent` use (1-) (1 >>> after (4 :: Float)) 204 | w = pure 72 `_untilEvent` use 3 (1 >>> after (1 :: Float)) 205 | pduvw = pure (.) <*> u <*> v <*> w 206 | uvw = u <*> (v <*> w) 207 | it "(compisition) pure (.) <*> u <*> v <*> w = u <*> (v <*> w)" $ 208 | equal pduvw uvw 209 | 210 | describe "spline's monad instance" $ do 211 | let h = sinc 212 | hr = h >>= return 213 | p :: Spline a Int Int 214 | p = pure 1 215 | 216 | it "(right identity w/ const) m >>= return == m" $ equal (p >>= return) p 217 | it "(right identity) m >>= return == m" $ equal h hr 218 | it "(right identity w/ monadic results) m >>= return == m" $ 219 | runIdentity (scanSpline h 0 [0..9 :: Int]) 220 | `shouldBe` runIdentity (scanSpline hr 0 [0..9 :: Int]) 221 | let f :: Int -> Spline a String Bool 222 | f x = do mapM_ (step . show) [0..x] 223 | return True 224 | it "(left identity) return a >>= f == f a" $ 225 | runIdentity (scanSpline (return 3 >>= f) "" [0..9 :: Int]) 226 | `shouldBe` runIdentity (scanSpline (f 3) "" [0..9 :: Int]) 227 | let m :: Spline a String Int 228 | m = do step "hey" 229 | step "dude" 230 | return 2 231 | g :: Bool -> Spline a String () 232 | g True = do step "okay" 233 | step "got it" 234 | g False = do step "dang" 235 | step "missed it" 236 | it "(associativity) (m >>= f) >>= g == m >>= (\\x -> f x >>= g)" $ 237 | runIdentity (scanSpline ((m >>= f) >>= g) "" [0..9 :: Int]) 238 | `shouldBe` runIdentity (scanSpline (m >>= (\x -> f x >>= g)) "" [0..9 :: Int]) 239 | -------------------------------------------------------------------------------- /varying.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.31.2. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 238c3b9ce9b85922d1e595508d4616c90817444c1d7b7e3c85527c9014f90094 8 | 9 | name: varying 10 | version: 0.8.1.0 11 | synopsis: FRP through value streams and monadic splines. 12 | description: Varying is a FRP library aimed at providing a simple way to describe values that change over a domain. It allows monadic, applicative and arrow notation and has convenience functions for tweening. Great for animation. 13 | category: Control, FRP 14 | homepage: https://github.com/schell/varying 15 | bug-reports: https://github.com/schell/varying/issues 16 | author: Schell Scivally 17 | maintainer: schell@takt.com 18 | license: MIT 19 | license-file: LICENSE 20 | build-type: Simple 21 | extra-source-files: 22 | README.md 23 | changelog.md 24 | 25 | source-repository head 26 | type: git 27 | location: https://github.com/schell/varying 28 | 29 | library 30 | exposed-modules: 31 | Control.Varying 32 | Control.Varying.Core 33 | Control.Varying.Event 34 | Control.Varying.Spline 35 | Control.Varying.Tween 36 | other-modules: 37 | Paths_varying 38 | hs-source-dirs: 39 | src 40 | ghc-options: -Wall 41 | build-depends: 42 | base >=4.8 && <5.0 43 | , contravariant >=1.4 44 | , transformers >=0.3 45 | default-language: Haskell2010 46 | 47 | executable varying-example 48 | main-is: Main.hs 49 | other-modules: 50 | Paths_varying 51 | hs-source-dirs: 52 | app 53 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 54 | build-depends: 55 | base >=4.8 && <5.0 56 | , contravariant >=1.4 57 | , time >=1.4 58 | , transformers >=0.3 59 | , varying 60 | default-language: Haskell2010 61 | 62 | test-suite doctests 63 | type: exitcode-stdio-1.0 64 | main-is: DocTests.hs 65 | hs-source-dirs: 66 | test 67 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 68 | build-depends: 69 | base >=4.8 && <5.0 70 | , contravariant >=1.4 71 | , doctest 72 | , transformers >=0.3 73 | , varying 74 | default-language: Haskell2010 75 | 76 | test-suite other 77 | type: exitcode-stdio-1.0 78 | main-is: Main.hs 79 | hs-source-dirs: 80 | test 81 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 82 | build-depends: 83 | QuickCheck 84 | , base >=4.8 && <5.0 85 | , contravariant >=1.4 86 | , hspec 87 | , time >=1.4 88 | , transformers >=0.3 89 | , varying 90 | default-language: Haskell2010 91 | 92 | benchmark varying-bench 93 | type: exitcode-stdio-1.0 94 | main-is: Main.hs 95 | other-modules: 96 | Paths_varying 97 | hs-source-dirs: 98 | bench 99 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 100 | build-depends: 101 | base >=4.8 && <5.0 102 | , contravariant >=1.4 103 | , criterion 104 | , time >=1.4 105 | , transformers 106 | , varying 107 | default-language: Haskell2010 108 | --------------------------------------------------------------------------------