AFSM 0.1.1.3 → 0.1.2.0

raw patch · 6 files changed

+199/−111 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• AFSM.cabal +2/−1
• CHANGELOG.md +7/−0
• README.md +35/−11
• examples/RPN.hs +19/−29
• src/Control/AFSM.hs +134/−68
• src/Control/AFSM/Event.hs +2/−2

@@ -1,5 +1,5 @@ name:                AFSM-version:             0.1.1.3+version:             0.1.2.0 synopsis:            Arrowized functional state machines description: Arrowized functional state machines.              This module is inspired by Yampa and the paper @@ -15,6 +15,7 @@ build-type:          Simple extra-source-files:     README.md+  CHANGELOG.md   examples/RPN.hs cabal-version:       >=1.10 library

@@ -0,0 +1,7 @@+## 0.1.2.0
+
+  * switch ```SM :: s -> (SMState s a b) -> SM a b``` to ```SM :: (SMState s a b) -> s -> SM a b```.
+  * the ArrowApp instance
+  * new functions: foldlSM, foldlDelaySM, delaySM, concatSM.
+  * working on Event, several undefined functions about Event.
+  * It's always hard to pick a name! 'Event', 'Evnt', 'Ev' or 'E'? 

@@ -12,40 +12,65 @@  The ```SM a b``` type denotes stateful functions from ```a``` to ```b```. Also, It is an instance of the ```Arrow``` type class. ```-data SM a b+-- | 'SMState' is the type of transition functions+--     s: storage, a: input, b: output+type SMState s a b = (s -> a -> (SM a b, b))++-- | 'SM' is the type representing state machines.+data SM a b where+  SM :: (SMState s a b) -> s -> SM a b -- --    a  /--------\  b --  >--->| SM a b |>---> --       \--------/--(>>>) :: SM a b -> SM b c -> SM a c --+-- (>>>) :: SM a b -> SM b c -> SM a c+-- --    a  /--------\  b  /--------\  c --  >--->| SM a b |>--->| SM b c |>---> --       \--------/     \--------/--(&&&) :: SM a b -> SM a c -> SM a (b, c) --+--+-- first :: SM a b -> SM (a, c) (b, c)+--+--    a  /--------------\  b+--  >--->|>-> SM a b >->|>--->+--       |              |+--  >--->|>------------>|>--->+--    c  \--------------/  c+--+-- (***) :: SM a b -> SM c d -> SM (a, c) (b, d)+--+--    a  /--------------\  b+--  >--->|>-> SM a b >->|>--->+--       |              |+--  >--->|>-> SM c d >->|>--->+--    c  \--------------/  d+--+-- (&&&) :: SM a b -> SM a c -> SM a (b, c)+-- --            /--------\  b --       /--->| SM a b |>---\ --    a  |    \--------/    |  (b,c) --  >--->|                  |>-------> --       |    /--------\  c | --       \--->| SM a c |>---/---            \--------/     +--            \--------/+-- +-- execute SM a b with input [a]. exec :: SM a b -> [a] -> (SM a b, [b]) ```  From a theoretical point of view, this model is a simplified version of FRP, but adding states on functions directly. In another word, it is switching the focus from time to states. -From an engnieering point of view, the other difference from AFRP(Yampa) is that we provide the constructor to use the transition function ```trans :: s -> a -> (SM a b, b)``` to build ```SM a b``` directly. +From an engnieering point of view, the other difference from AFRP(Yampa) is that we provide the constructor to use the transition function ```SMState s a b :: s -> a -> (SM a b, b)``` to build ```SM a b``` directly where ```s``` donates the storage type.  ### Simplifed model  In functional reactive programming(FRP), the key concepts are the signal, ```Signal a :: Time -> a```, and the signal function from signal to signal, ```SF a b :: Signal a -> Signal b```. -The model of FRP is beautiful, but one diffcult thing is that the signal is continuous function, and our computers are discrete systems. +The model of FRP is beautiful, but one diffcult thing is that the signal is continuous function, and our computers are discrete systems.  However, what if we do not care about time, and only focus on the sequence of input. There is reason to believe that computational tasks usually are time-insensitive. For example, the parsing process. So ```[a]``` and ```[Event a]``` are the only things we expected in our system. @@ -63,7 +88,7 @@  ## Examples -### Reverse Polish notation(RPN.hs)+### Reverse Polish notation([RPN.hs](https://github.com/PseudoPower/AFSM/blob/master/examples/RPN.hs))  It is also known as postfix notation, and it is very straightforward example. The input is the infix expression, and the output is the value. First, we build a SM named in2post to convert infix notation to postfix expression. Then we build a SM named post2ret to evaluate the valus. Finally, we use them to compose ```in2ret = in2post >>> post2ret```. @@ -73,7 +98,7 @@   * Event   * More high order functions   * Another DSL to build transition functions?-  + ## References  [Functional Reactive Programming, Continued](http://haskell.cs.yale.edu/wp-content/uploads/2011/02/workshop-02.pdf)@@ -83,4 +108,3 @@ [Haskell/Arrow tutorial](https://en.wikibooks.org/wiki/Haskell/Arrow_tutorial)    * Just realize that both AFRP and our model are very similar with ```Circuit```. Actually, FRP is simulating signal systems, also it's why I prefer to use the name ```signal function``` instead of ```behavior function```. On the other hand, AFRP is AFSM with fix storage type ```DTime```, and the benefit is that it does not require the GADTs extension.-

@@ -12,15 +12,15 @@ 
 data Op = Add | Sub | Mul | Div
   deriving (Eq)
-  
+
 instance Show Op where
   show Add = "+"
   show Sub = "-"
   show Mul = "*"
   show Div = "/"
-  
 
-data Token = Num Int | Op Op | L | R | End 
+
+data Token = Num Int | Op Op | L | R | End
   deriving (Eq)
 
 instance Show Token where
@@ -29,7 +29,7 @@   show L = "("
   show R = ")"
   show End = ""
-  
+
 -- 3 * (2 - 3) + (4 - 2 * 3)
 test1 = [Num 3, Op Mul, L, Num 2, Op Sub, Num 3, R, Op Add, L, Num 4, Op Sub, Num 2, Op Mul, Num 3, R, End]
 
@@ -44,13 +44,13 @@ trans0 xs (Num x) = (xs, [(Num x)])
 trans0 xs L = (L:xs, [])
 trans0 xs R = let (x0, x1) = span (L /= ) xs in (tail $ x1, x0)
-trans0 xs op = 
+trans0 xs op =
   (op:x1, x0)
   where
     f0 = (\x -> x == (Op Mul) || x == (Op Div))
     (x0, x1) = span f0 xs
 
-    
+
 -- the SM converting infix to postfix
 --
 --   Token /---------\ [Token]
@@ -58,8 +58,11 @@ --         \---------/
 --
 in2post :: SM Token [Token]
-in2post = simpleSM [End] trans0
+in2post = simpleSM trans0 [End]
 
+post1 = concat $ getRet in2post test1
+post2 = concat $ getRet in2post test2
+
 f :: Op -> Int -> Int -> Int
 f Add x y = x + y
 f Sub x y = x - y
@@ -78,7 +81,7 @@ --         \-----------/
 --
 post2ret' :: SM Token (Maybe Int)
-post2ret' = simpleSM [] trans1
+post2ret' = simpleSM trans1 []
 
 
 --
@@ -90,8 +93,8 @@ post2ret = execSM post2ret'
 
 
-
--- the SM composed of in2post and post2ret
+-- an example to use Arrow notation
+--   the SM composed of in2post and post2ret
 --
 --         /----------------------------\
 --   Token |          [Token]           | [Maybe Int]
@@ -100,25 +103,12 @@ --         \----------------------------/
 --                     in2ret
 --
+-- in2ret = in2post >>> post2ret
 in2ret :: SM Token [Maybe Int]
 in2ret = proc x -> do
    y <- in2post -< x
    post2ret -< y
 
-{-
-historySM :: SM a [a]
-historySM = simpleSM [] (\xs a -> (a:xs, a:xs))
-
-lst2str:: Show a => SM [a] String
-lst2str = arr (let f = \xs -> if (null xs) then "" else (show (head xs)) ++ f (tail xs) in f)
-
-fooSM :: SM Token String
-fooSM = proc x -> do
-  h <- (historySM >>> lst2str) -< x
-  r <- in2ret -< x
-  returnA -< (h ++ if null r then "" else "=" ++ show (last r) )
--}
-
 -- Parsing and evaluating
 
 getRet :: SM a b -> [a] -> [b]
@@ -141,18 +131,18 @@ 
 parseStr :: String -> [Token]
 parseStr [] = [End]
-parseStr (x:xs) = 
+parseStr (x:xs) =
   if elem x ",\n" then End : (parseStr xs)
   else if x == ' ' then parseStr xs
   else if isNum x then
     let (ys, zs) = span isNum xs in (Num $ read (x:ys)):(parseStr zs)
   else if elem x "()+-*/" then
     (parseOp x):(parseStr xs)
-  else 
+  else
     parseStr xs
-  
+
 main = do
   getContents >>= (mapM_ putStrLn).(map show).(calc.parseStr)
-  
+
 -- input samples
--- 3 * (2 - 3) + (4 - 2 * 3), 3 + 4 * 2 / (1 - 5) * 2 + 3+-- 3 * (2 - 3) + (4 - 2 * 3), 3 + 4 * 2 / (1 - 5) * 2 + 3

@@ -12,35 +12,40 @@ --
 -- Arrowized functional state machines.
 --
---   This module is inspired by Yampa and the paper 
+--   This module is inspired by Yampa and the paper
 --   /Functional Reactive Programming, Continued*/ written by
 --     Henrik Nilsson, Antony Courtney and John Peterson.
 -----------------------------------------------------------------------------
 
 module Control.AFSM (
   module Control.Arrow,
-  
+
   Event(..),
-  
+
   -- * The 'SM' type
   SM,
-  
+
   -- * The 'SMState' type
   SMState,
-  
+
   -- * Constructors
   newSM,
   simpleSM,
-  
+
   -- * Basic State Machines
   constSM,
-  
+  idSM,
+  foldlSM,
+  foldlDelaySM,
+  delaySM,
+
   -- * High order functions
   execSM,
-  
+  concatSM,
+
   -- * Evaluation
   exec
-  
+
 ) where
 
 import Control.Category
@@ -48,53 +53,97 @@ 
 import Control.AFSM.Event
 
-
+-- | 'SMState' is the transition function
+--     s: storage, a: input, b: output
 type SMState s a b = (s -> a -> (SM a b, b))
 
 -- | 'SM' is a type representing a state machine.
-data SM a b where 
-  SM :: s -> (SMState s a b) -> SM a b
-  
+data SM a b where
+  SM :: (SMState s a b) -> s -> SM a b
+
 -- Constructors
 
--- | newSM is the same with SM constructor.
-newSM :: s -> (SMState s a b) -> SM a b
+-- | It is the same with the SM constructor.
+newSM :: (SMState s a b) -> s -> SM a b
 newSM = SM
 
--- | simpleSM is to build a simple SM which have only one SMState.
-simpleSM :: s -> (s -> a -> (s, b)) -> SM a b
-simpleSM s f = SM s f'
+-- | build a simple SM which have only one SMState.
+simpleSM :: (s -> a -> (s, b)) -> s -> SM a b
+simpleSM f s = SM f' s
   where
-    f' = (\s' a' -> let (s'', b) = f s' a' in (SM s'' f', b))
-    
+    f' = (\s' a' -> let (s'', b) = f s' a' in (SM f' s'', b))
+
 -- Basic State Machines
 
--- | constSM build a SM which always return b
+-- | build a SM which always return b
 constSM :: b -> SM a b
-constSM b = SM () f
+constSM b = SM f ()
   where
-    f _ a = ((constSM b), b)
+    f _ _ = ((constSM b), b)
 
--- Category instance    
+-- | the same with foldl
+foldlSM :: (s -> a -> s) -> s -> SM a s
+foldlSM f s = SM f' s
+  where
+    f' s' a' = let s'' = f s' a' in (SM f' s'', s'')
 
+-- | the difference from foldlSM is it output the storage first.
+foldlDelaySM :: (s -> a -> s) -> s -> SM a s
+foldlDelaySM f s = SM f' s
+  where
+    f' s' a' = let s'' = f s' a' in (SM f' s'', s')
+
+-- | delay the input with given value.
+-- delaySM = foldlDelaySM (const id)
+delaySM :: a -> SM a a
+delaySM a = SM f a
+  where
+    f s' a' = ((SM f a'), s')
+
+holdSM :: a -> SM (Event a) a
+holdSM = undefined
+
+filterSM :: (a -> Bool) -> SM a (Event a)
+filterSM = undefined
+
+-- High order functions
+
+-- | converts SM a b -> SM [a] [b], it is very useful to compose SM a [b] and SM b c to SM a [c].
+execSM :: SM a b -> SM [a] [b]
+execSM sm = simpleSM exec sm
+
+concatSM :: SM a [[b]] -> SM a [b]
+concatSM = fmap concat
+
+eventOutSM :: SM a b -> SM a (Event b)
+eventOutSM = fmap Event
+
+eventSM :: SM a b -> SM (Event a) (Event b)
+eventSM = undefined
+
+slowdownSM :: SM a [b] -> SM a (Event b)
+slowdownSM = undefined
+
+-- Category instance
+
 instance Category SM where
   id  = idSM
   (.) = composeSM
-  
+
 idSM :: SM a a
-idSM = SM () (\_ a -> (idSM, a))
-  
+idSM = SM (\_ a -> (idSM, a)) ()
+
 composeSM :: SM b c -> SM a b -> SM a c
-composeSM sm1 sm0 = SM (sm0,sm1) f2
+composeSM sm1 sm0 = SM f2 (sm0,sm1)
   where
-    f2 ((SM s0 f0),(SM s1 f1)) a = (SM (sm0', sm1') f2, c)
+    f2 ((SM f0 s0),(SM f1 s1)) a = (SM f2 (sm0', sm1'), c)
       where
         (sm0', b) = f0 s0 a
         (sm1', c) = f1 s1 b
 
-        
+
 -- Arrow instance
-  
+
 instance Arrow SM where
   arr = arrSM
   first = firstSM
@@ -104,67 +153,67 @@ 
 arrSM :: (a -> b) -> SM a b
 arrSM f =
-  SM () (\_ a ->(arrSM f, f a))
-          
+  SM (\_ a ->(arrSM f, f a)) ()
+
 firstSM :: SM a b -> SM (a, c) (b, c)
-firstSM sm = SM sm f1
+firstSM sm = SM f1 sm
   where
-    f1 (SM s f) (a,c) = ((SM sm' f1), (b, c))
+    f1 (SM f s) (a,c) = ((SM f1 sm'), (b, c))
       where
         (sm', b) = f s a
-        
+
 secondSM :: SM a b -> SM (c, a) (c, b)
-secondSM sm = SM sm f1
+secondSM sm = SM f1 sm
   where
-    f1 (SM s f) (c,a) = ((SM sm' f1), (c, b))
+    f1 (SM f s) (c,a) = ((SM f1 sm'), (c, b))
       where
         (sm', b) = f s a
 
 productSM :: SM a b -> SM c d -> SM (a, c) (b, d)
-productSM sm0 sm1 = SM (sm0, sm1) f2
+productSM sm0 sm1 = SM f2 (sm0, sm1)
   where
-    f2 ((SM s0 f0),(SM s1 f1)) (a, c) = (SM (sm0', sm1') f2, (b, d))
+    f2 ((SM f0 s0),(SM f1 s1)) (a, c) = (SM f2 (sm0', sm1'), (b, d))
       where
         (sm0', b) = f0 s0 a
         (sm1', d) = f1 s1 c
 
 fanoutSM :: SM a b -> SM a c -> SM a (b, c)
-fanoutSM sm0 sm1 = SM (sm0, sm1) f2
+fanoutSM sm0 sm1 = SM f2 (sm0, sm1)
   where
-    f2 ((SM s0 f0),(SM s1 f1)) a = (SM (sm0', sm1') f2, (b, c))
+    f2 ((SM f0 s0),(SM f1 s1)) a = (SM f2 (sm0', sm1'), (b, c))
       where
         (sm0', b) = f0 s0 a
         (sm1', c) = f1 s1 a
 
--- ArrowChoice 
+-- ArrowChoice
 
 leftSM :: SM a b -> SM (Either a c) (Either b c)
-leftSM sm = SM sm f1
+leftSM sm = SM f1 sm
   where
-    f1 sm' (Right c) = (SM sm' f1, Right c)
-    f1 (SM s0 f0) (Left a) = (SM sm'' f1, Left b)
+    f1 sm' (Right c) = (SM f1 sm', Right c)
+    f1 (SM f0 s0) (Left a) = (SM f1 sm'', Left b)
       where
         (sm'', b) = f0 s0 a
 
 rightSM :: SM a b -> SM (Either c a) (Either c b)
-rightSM sm = SM sm f1
+rightSM sm = SM f1 sm
   where
-    f1 sm' (Left c) = (SM sm' f1, Left c)
-    f1 (SM s f) (Right a) = ((SM sm'' f1), Right b)
+    f1 sm' (Left c) = (SM f1 sm', Left c)
+    f1 (SM f s) (Right a) = ((SM f1 sm''), Right b)
       where
         (sm'', b) = f s a
-        
+
 sumSM :: SM a b -> SM c d -> SM (Either a c) (Either b d)
-sumSM sm0 sm1 = SM (sm0, sm1) f2
+sumSM sm0 sm1 = SM f2 (sm0, sm1)
   where
-    f2 (SM s0 f0, sm1') (Left a)  = let (sm0', b) = f0 s0 a in (SM (sm0', sm1') f2, Left b)
-    f2 (sm0', SM s1 f1) (Right c) = let (sm1', d) = f1 s1 c in (SM (sm0', sm1') f2, Right d)
+    f2 (SM f0 s0, sm1') (Left a)  = let (sm0', b) = f0 s0 a in (SM f2 (sm0', sm1'), Left b)
+    f2 (sm0', SM f1 s1) (Right c) = let (sm1', d) = f1 s1 c in (SM f2 (sm0', sm1'), Right d)
 
 faninSM :: SM a c -> SM b c -> SM (Either a b) c
-faninSM sm0 sm1 = SM (sm0, sm1) f2
+faninSM sm0 sm1 = SM f2 (sm0, sm1)
   where
-    f2 (SM s0 f0, sm1') (Left a)  = let (sm0', c) = f0 s0 a in (SM (sm0', sm1') f2, c)
-    f2 (sm0', SM s1 f1) (Right b) = let (sm1', c) = f1 s1 b in (SM (sm0', sm1') f2, c)
+    f2 (SM f0 s0, sm1') (Left a)  = let (sm0', c) = f0 s0 a in (SM f2 (sm0', sm1'), c)
+    f2 (sm0', SM f1 s1) (Right b) = let (sm1', c) = f1 s1 b in (SM f2 (sm0', sm1'), c)
 
 instance ArrowChoice SM where
   left = leftSM
@@ -172,31 +221,48 @@   (+++) = sumSM
   (|||) = faninSM
 
+
+-- ArrowApply
+
+appSM :: SM (SM a b, a) b
+appSM = SM f1 ()
+  where
+    f1 () ((SM f s), a) = (SM f1 (), snd $ f s a)
+
+instance ArrowApply SM where
+  app = appSM
+
 -- ArrowLoop
--- SM has build-in loop structure, but adding one more instance is harmless, :)
+-- SM has build-in loop structure, ArrowLoop helps sharing storage between SMs, and adding one more instance is harmless, :)
 
 loopSM :: SM (a, c) (b, c) -> SM a b
-loopSM sm = SM sm f1
+loopSM sm = SM f1 sm
   where
-    f1 (SM s f) a = (SM sm' f1, b)
+    f1 (SM f s) a = (SM f1 sm', b)
       where
         (sm', (b, c)) = f s (a, c)
 
 instance ArrowLoop SM where
     loop = loopSM
-        
+
+-- Functor
+-- fmapSM f sm = sm >>> arr f
+fmapSM :: (b -> c) -> SM a b -> SM a c
+fmapSM f sm = SM f1 sm
+  where
+    f1 (SM f0 s0) a = (SM f1 sm', f b)
+      where
+        (sm', b) = f0 s0 a
+
+instance Functor (SM a) where
+  fmap = fmapSM
+
 -- Evaluation
 
 -- | execute SM a b with input [a].
 exec :: SM a b -> [a] -> (SM a b, [b])
 exec sm [] = (sm, [])
-exec (SM s f) (x:xs) = (sm'', b:bs)
-  where 
+exec (SM f s) (x:xs) = (sm'', b:bs)
+  where
     (sm', b) = f s x
     (sm'', bs) = (exec sm' xs)
-    
--- High order functions
- 
--- | execSM converts SM a b -> SM [a] [b], it is very useful to compose SM a [b] and SM b c to SM a [c].
-execSM :: SM a b -> SM [a] [b]
-execSM sm = simpleSM sm exec

@@ -17,5 +17,5 @@ 
 
 
-
-data Event a = E a | NoE | ErrE String | ExitE deriving (Show, Eq, Ord)+-- | 'Event' type, there are 4 different events: event a, no event, error event string and exit event.
+data Event a = Event a | NoEvent | ErrEvent String | ExitEvent deriving (Show, Eq, Ord)