AFSM 0.1.2.0 → 0.1.3.0

raw patch · 14 files changed

+1328/−300 lines, 14 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• AFSM.cabal +10/−2
• CHANGELOG.md +11/−2
• README.md +121/−50
• examples/HelloWorld.hs +125/−0
• examples/RPN.hs +24/−12
• examples/Toys.hs +83/−0
• src/Control/AFSM.hs +54/−227
• src/Control/AFSM/Core.hs +294/−0
• src/Control/AFSM/CoreType.hs +79/−0
• src/Control/AFSM/Event.hs +49/−7
• src/Control/AFSM/SMFunctor.hs +112/−0
• src/Control/AFSM/SMH.hs +190/−0
• src/Control/AFSM/TF.hs +131/−0
• src/Control/AFSM/Util.hs +45/−0

@@ -1,5 +1,5 @@ name:                AFSM-version:             0.1.2.0+version:             0.1.3.0 synopsis:            Arrowized functional state machines description: Arrowized functional state machines.              This module is inspired by Yampa and the paper @@ -16,14 +16,22 @@ extra-source-files:     README.md   CHANGELOG.md+  examples/HelloWorld.hs   examples/RPN.hs+  examples/Toys.hs cabal-version:       >=1.10 library   exposed-modules:     Control.AFSM+    Control.AFSM.Core+    Control.AFSM.CoreType     Control.AFSM.Event+    Control.AFSM.SMFunctor+    Control.AFSM.SMH+    Control.AFSM.TF+    Control.AFSM.Util   -- other-modules:       -  other-extensions:    Arrows, GADTs+  other-extensions:    Arrows, FlexibleInstances   build-depends:       base >= 4.7 && < 5   ghc-options:         -Wall   hs-source-dirs:      src

@@ -1,7 +1,16 @@+## 0.1.3.0
+  * remove GADTs extension, `SM a b` becomes `SM s a b`.
+  * change `type SMState s a b = (s -> a -> (SM s a b, b))` to `newtype TF s a b = TF (s -> a -> (SM s a b, b))`. The reason is that TF is a SM without initial storage, and it is the instance of several class type.
+  * change `data SM s a b = SM (SMState s a b) s` to `data SM s a b = SM (TF s a b) s`.
+  * `SM s a b` is no longer an instance of Arrow, but `SM () a b` is still an instance of Arrow. `type SMH a b = SM () a b`.
+  * the `SMFunctor` class, and `smfmap` helps you to use `SM s a b` as a normal function. 
+  * more examples.
+
 ## 0.1.2.0
 
-  * switch ```SM :: s -> (SMState s a b) -> SM a b``` to ```SM :: (SMState s a b) -> s -> SM a b```.
+  * 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'? +  * It's always hard to pick a name! 'Event', 'Evnt', 'Ev' or 'E'? 
+ 

@@ -1,110 +1,181 @@ # Arrowized functional state machines +Because this readme file becomes so long, I moved other models to [models.md](docs/models.md), and I am able to detail each of them without worrying about the length of the article, :)++## Update notes++Now, the GADTs extension has been removed, and a lot of things should been cleared up. For now, I just keep them right there.++`SM a b` has became to `SM s a b`, so it is not an instance of the Arrow class anymore. Instead, we are able to keep the information about each machine's storage. Also, we provide the same Arrow functions, such as `<<<<`, `>>>>`, `****` and `&&&&`.++`type SMH a b = SM () a b` is still an Arrow instance, and `hideStorage :: SM s a b -> SM () a b` can help you transform `SM s a b` to `SM () a b`, if you want to use the Arrow notation. The cost is that the information about storage is gone.++`type SMState s a b = (s -> a -> (SM a b, b))` becomes `data TF = TF (s -> a -> (SM a b, b))`. The reason about this changing is that `type SMState` is just defining an alias of an existing type, So it is not possible to define a instance for `SMState`. We observed that  `(s -> a -> (SM a b, b))` is similiar with `ST monad`, and its behavior is also similiar with `ST monad`. I think it is a good chance to do something around.++Although our original idea is removing `Time` concept and adding `Storage` concept, now it is much closer with `Circuit` model or `State` model than `AFRP`. More precisely, it is a mixture of `Circuit` and `State`.+ ## Introduction  The intuitive way to understand the state machine is that it have four parts, state, storage, input and output. Each state has its own transition function which takes the storage and the input, updates the storage and the state, and gives the output.  The abstract way is thinking the state machine as the stateful function. -Now, let us put these two ways together. Our plan is using the stateful function as the interface(making it to be an instance of the ```Arrow``` type class), but users can build state machines in an intuitive way.+Now, let us put these two ways together. Our plan is using the stateful function as the interface, but users can build state machines in an intuitive way.  ## Basic Concepts -The ```SM a b``` type denotes stateful functions from ```a``` to ```b```. Also, It is an instance of the ```Arrow``` type class.+The `SM a b` type denotes stateful functions from `a` to `b`. Also, It is an instance of the `Arrow` type class. ```--- | 'SMState' is the type of transition functions+-- | 'TF' is a type representing a transition function. --     s: storage, a: input, b: output-type SMState s a b = (s -> a -> (SM a b, b))+--   Also, it represents the state in SM.+--   Let's explain more about 'TF'. When a state gets an input a,+--   it should do three things base on the storage and input:+--     find the next state(TF), update storage and output b.+--   That's why it looks like this:+--     (storage -> a -> (SM newTF newStorage, b))+type TF 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+  SM :: (TF s a b) -> s -> SM s a b -----    a  /--------\  b---  >--->| SM a b |>--->---       \--------/+--    a  /----------\  b+--  >--->| SM s a b |>--->+--       \----------/ ----- (>>>) :: SM a b -> SM b c -> SM a c+-- Here is a slight difference from Arrow class, +--   so `SM s a b` is not an instance of Arrow class, +--   but you can do everything the same as an Arrow instance.+-- And `SM () a b` is still an instance of Arrow, +--   and `hideStorage :: SM s a b -> SM () a b` can help you to achieve easily.+-- It is a trade-off between keeping track the storage and having the instance of Arrow. -----    a  /--------\  b  /--------\  c---  >--->| SM a b |>--->| SM b c |>--->---       \--------/     \--------/+-- (>>>>) :: SM s a b -> SM t b c -> SM (s,t) a c --+--    a  /----------\  b  /----------\  c+--  >--->| SM s a b |>--->| SM t b c |>--->+--       \----------/     \----------/ ----- first :: SM a b -> SM (a, c) (b, c) -----    a  /--------------\  b---  >--->|>-> SM a b >->|>--->---       |              |---  >--->|>------------>|>--->---    c  \--------------/  c+-- firstSM :: SM s a b -> SM s (a, c) (b, c) ----- (***) :: SM a b -> SM c d -> SM (a, c) (b, d)+--    a  /----------------\  b+--  >--->|>-> SM s a b >->|>--->+--       |                |+--  >--->|>-------------->|>--->+--    c  \----------------/  c -----    a  /--------------\  b---  >--->|>-> SM a b >->|>--->---       |              |---  >--->|>-> SM c d >->|>--->---    c  \--------------/  d ----- (&&&) :: SM a b -> SM a c -> SM a (b, c)+-- (****) :: SM s a b -> SM t c d -> SM (s,t) (a, c) (b, d) -----            /--------\  b---       /--->| SM a b |>---\---    a  |    \--------/    |  (b,c)---  >--->|                  |>------->---       |    /--------\  c |---       \--->| SM a c |>---/---            \--------/+--    a  /----------------\  b+--  >--->|>-> SM s a b >->|>--->+--       |                |+--  >--->|>-> SM t c d >->|>--->+--    c  \----------------/  d --+--+-- (&&&&) :: SM s a b -> SM t a c -> SM (s,t) a (b, c)+--+--            /----------\  b+--       /--->| SM s a b |>---\+--    a  |    \----------/    |  (b,c)+--  >--->|                    |>------->+--       |    /----------\  c |+--       \--->| SM t a c |>---/+--            \----------/+-- --- execute SM a b with input [a].-exec :: SM a b -> [a] -> (SM a b, [b])+-- execute SM s a b with inputs, +--   you can think `SM s a b` is a stateful function `f :: a -> b` with storage `s`. +--   `step` is the apply function. `exec` is the mapping function. +-- We also introduce our own Functor class, `SMFunctor`. +--   And `smexec :: SMFunctor f => SM s a b -> f a -> (SM s a b, f b)`.++step :: SM s a b -> a -> (SM s a b, b)++exec :: SM s a b -> [a] -> (SM s a b, [b])++smfmap :: SM s a b -> [a] -> [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 ```SMState s a b :: s -> a -> (SM a b, b)``` to build ```SM a b``` directly where ```s``` donates the storage type.+From an engnieering point of view, the other difference from AFRP(Yampa) is that we provide the constructor to use the transition function `TF s a b :: s -> a -> (SM s a b, b)` to build `SM s 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```.+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 difficult 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.+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. -For discrete system, simplifying the input type is kind of generalizing ```[(Time,a)]``` to ```[a]```. This simplifed model is still able to process the time sequences by using ```[(Time, a)]``` as the input. In conclusion, we doesn't consider time as an essential part of the input, but if the input involves time, users can add time back as a part of the input.+For discrete system, simplifying the input type is kind of generalizing `[(Time,a)]` to `[a]`. This simplified model is still able to process the time sequences by using `[(Time, a)]` as the input. In conclusion, we doesn't consider time as an essential part of the input, but if the input involves time, users can add time back as a part of the input.  ### Stateful function(Storage) -Usually, the state can be abstracted to the summary of input history. With the ArrowLoop instance, we can create stateful functions in FPR. For example, if we want to get a function ```SF a b``` with state ```c```. We first write a function ```SF (a, c) (b, c)```, then use ```loop :: SF (a, c) (b, c) -> SF a b``` to get the stateful function ```SF a b```.+Usually, the state can be abstracted to the summary of input history. With the ArrowLoop instance, we can create stateful functions in FPR. For example, if we want to get a function `SF a b` with state `c`. We first write a function `SF (a, c) (b, c)`, then use `loop :: SF (a, c) (b, c) -> SF a b` to get the stateful function `SF a b`. -But I prefer to think the pure function as the stateful function with state ```()```, because the stateful function gives us a more natural way to represent the control flow. Also, it give us the ability to switch the function itself based on different inputs.+But I prefer to think the pure function as the stateful function with state `()`, because the stateful function gives us a more natural way to represent the control flow. Also, it give us the ability to switch the function itself based on different inputs.  ## Implementation -The key idea is using the GADTs extension to hide the state(storage) type. If we do not use the GADTs extension, then ```SM a b``` will become ```SM s a b``` where ```s``` denotes the state(storage) type.+The key idea is using the GADTs extension to hide the state(storage) type. If we do not use the GADTs extension, then `SM a b` will become `SM s a b` where `s` denotes the state(storage) type.  +However, after hiding the storage type, it is the same with `Circuit a b`. The funny thing is that we come from AFRP, and end up with Circuit.++We are planning to remove GADTs extension, then `SM a b` becomes `SM s a b`. The benefit is that we can extract the storage from a SM, and the limitation is that we cannot put itself as the storage or do something may cause infinite type. Also, when we put several SMs together, the type of storage will be in a mess. It's the reason we use GADTs to hide the type of storage before, but now we still have a way to hide the storage if you never want to extract it, `hideStorage :: SM s a b -> SM () a b`.+ ## Examples +### HelloWorld([HelloWorld.hs](https://github.com/PseudoPower/AFSM/blob/master/examples/HelloWorld.hs))++It shows basic components of AFSM. And an example about operating stacks.++### Toys([Toys.hs](https://github.com/PseudoPower/AFSM/blob/master/examples/Toys.hs))++***A collection of toys***++The Fibonacci sequence++The random number sequence++The prime number sequence+ ### 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```.+To run this example, just type `make RPN` or `ghci examples/RPN.hs -isrc/`. The makefile will be maintained for all examples. Then you can run `main` function and type some infix expressions, such as  `3 * (2 - 3) + (4 - 2 * 3), 3 + 4 * 2 / (1 - 5) * 2 + 3`. +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`. ++ ## To-Do-  * Basic state machines-  * Event-  * More high order functions-  * Another DSL to build transition functions?+  * Basic state machines (continuous adding some new SMs.)+  * Event (It is similar with the Maybe data type, but in our control, and after defining Event, we can do some interesting things.)+  * TF (compose some TFs to one TF, it means several SM shares the same storage.)+  * More high order functions (distinguish which functions are essential.)+  * Another DSL to build transition functions? (It is not necessary now.)  ## References- [Functional Reactive Programming, Continued](http://haskell.cs.yale.edu/wp-content/uploads/2011/02/workshop-02.pdf)+  * the paper about AFRP. Actually, AFRP is simulating signal systems, also it's why I prefer to use the name `signal function` instead of `behavior function`.+  * `Signal a :: Time -> a`, and `SF a b :: Signal a -> Signal b`.  [Yampa - Haskell Wiki](https://wiki.haskell.org/Yampa)+  * the implementation of AFRP+  * `type Transition a b = (SF a b, b)`, and `data SF a b = SF (DTime -> a -> Transition a b)`. -[Haskell/Arrow tutorial](https://en.wikibooks.org/wiki/Haskell/Arrow_tutorial)+[Control.Monad.ST](https://hackage.haskell.org/package/base-4.8.2.0/docs/Control-Monad-ST.html)+  * State Monad+  * `data ST s a = State { runState :: s -> (a, s) }`. -  * 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.+[Arrows and computation](http://ipaper.googlecode.com/git-history/243b02cb56424d9e3931361122c5aa1c4bdcbbbd/Arrow/arrows-fop.pdf)+  * the model in this chapter is named state transformers, I just call it `State` model.  The `Auto` model in this chapter is the same with `Circuit`.+  * `type State s a b = (s, a) -> (s, b)`.++[Haskell/Arrow tutorial](https://en.wikibooks.org/wiki/Haskell/Arrow_tutorial)+  * the Arrow tutorial with `Circuit` model.+  * `newtype Circuit a b = Circuit (a -> (Circuit a b, b))`.

@@ -0,0 +1,125 @@+-----------------------------------------------------------------------------+-- Copyright   :  (c) Hanzhong Xu, Meng Meng 2016,+-- License     :  MIT License+--+-- Maintainer  :  hanzh.xu@gmail.com+-- Stability   :  experimental+-- Portability :  portable+-----------------------------------------------------------------------------+-- HelloWorld+-----------------------------------------------------------------------------++{-# LANGUAGE PartialTypeSignatures #-}++module HelloWorld where++import Control.AFSM+import Control.AFSM.SMH++import Data.Maybe++-- | x_i donates the ith element of the input, y_i donates the ith element of the output.++-- $setup+-- >>> let test0 = [1,2,3,4]::[Int]+++-- basic machines+++-- | the sum of the history, y_n = \sum_{i=1}^n x_i+-- >>> smfmap sumSM test0+-- [1,3,6,10]+sumSM :: SM Int Int Int+sumSM  = simpleSM (\s a -> (s+a, s+a)) 0 ++-- | y_n = x_n + 1+-- >>> smfmap plusOneSM test0+-- [2,3,4,5]+plusOneSM :: SM () Int Int+plusOneSM  = simpleSM (\() a -> ((), a + 1)) ()++-- | y_n = x_n * 2+-- >>> smfmap timesTwoSM test0+-- [2,4,6,8]+timesTwoSM :: SM () Int Int+timesTwoSM  = arrSM (\a -> a * 2)++-- combination machine++-- | y_n = \sum_{i=1}^n x_i * 2+-- >>> smfmap ttSM test0+-- [2,6,12,20]+ttSM = timesTwoSM >>>> sumSM ++-- | y_n = (x_n + 1, x_n * 2)+-- >>> smfmap ptSM test0+-- [(2,2),(3,4),(4,6),(5,8)]+ptSM = plusOneSM &&&& timesTwoSM+++-- |+-- >>> smfmap mergeOutSM [(2,2),(3,4),(4,6),(5,8)]+-- [4,7,10,13]+--+-- | y_n = (x_n + 1) + (x_n * 2)+-- >>> smfmap ((plusOneSM &&&& timesTwoSM) >>>> mergeOutSM) test0+-- [4,7,10,13]+mergeOutSM :: SM () (Int, Int) Int+mergeOutSM = arrSM (\(a,b)->a+b)+++-- example 3+data StackOP = Push Int+             | Pop+             | Max+             deriving Show+             ++pushStk [] a = ([a], a)+pushStk s  a = (a:s, a)++popStk [] = ([], 0)+popStk (x:xs)  = (xs, x)++maxStk [] =  ([], 0) +maxStk s  = (s, maxList s)  +             +maxList :: [Int] -> Int+maxList [] = 0+maxList (x:xs) = max x (maxList xs) ++initial = []+             +{-+pushStk ([],[]) a = (([a],[a]), a)+pushStk ((x:xs), (y:ys))  a = if a >= y then ((a:x:xs, a:y:ys), a) else ((a:x:xs, y:ys), a)++popStk ([],[]) = (([],[]), 0)+popStk ((x:xs), (y:ys)) = if x == y then ((xs, ys), x) else ((xs, y:ys), x)++maxStk ([], [])  =  (([], []), 0) +maxStk ((x:xs), (y:ys)) = (((x:xs), (y:ys)), y)  ++initial = ([],[])+-}++sf s (Push a) =  pushStk s a+sf s Pop = popStk s+sf s Max =  maxStk s++-- | The stroage type is changing during switching the implementation.+--   There are three ways to handle this issue,+--     1. Remove the type signature of maxSM+--     2. Use hideStorage to hide the storage type+--     3. Use the PartialTypeSignatures extension, leave a hole in the type signature.+--   Personaly, I prefer to use the third one, +--     because the input type and output type are decidable.+-- >>> smfmap maxSM [Push 5, Push 3, Push 2, Max, Push 7, Max, Pop, Max]+-- [5,3,2,5,7,7,7,5]  +maxSM :: SM _ StackOP Int+maxSM = simpleSM sf initial ++-- maxSM :: SM () StackOP Int+-- maxSM = hideStorage $ simpleSM sf initial            +

@@ -1,15 +1,23 @@-{-# LANGUAGE Arrows #-}
-
 -----------------------------------------------------------------------------
+-- Copyright   :  (c) Hanzhong Xu, Meng Meng 2016,
+-- License     :  MIT License
+--
+-- Maintainer  :  hanzh.xu@gmail.com
+-- Stability   :  experimental
+-- Portability :  portable
+-----------------------------------------------------------------------------
 -- A simple calculator
 -----------------------------------------------------------------------------
 
+-- {-# LANGUAGE Arrows #-}
+
 module Main where
 
 import Control.AFSM
 import Data.Maybe
 -- import Data.Map (fromList, (!))
 
+
 data Op = Add | Sub | Mul | Div
   deriving (Eq)
 
@@ -57,7 +65,7 @@ --  >----->| in2post |>------->
 --         \---------/
 --
-in2post :: SM Token [Token]
+in2post :: SM [Token] Token [Token]
 in2post = simpleSM trans0 [End]
 
 post1 = concat $ getRet in2post test1
@@ -80,7 +88,7 @@ --  >----->| post2ret' |>--------->
 --         \-----------/
 --
-post2ret' :: SM Token (Maybe Int)
+post2ret' :: SM [Int] Token (Maybe Int)
 post2ret' = simpleSM trans1 []
 
 
@@ -89,7 +97,7 @@ --  >------->| post2ret |>----------->
 --           \----------/
 --
-post2ret :: SM [Token] [Maybe Int]
+post2ret :: SM [Int] [Token] [Maybe Int]
 post2ret = execSM post2ret'
 
 
@@ -103,19 +111,23 @@ --         \----------------------------/
 --                     in2ret
 --
--- in2ret = in2post >>> post2ret
-in2ret :: SM Token [Maybe Int]
-in2ret = proc x -> do
-   y <- in2post -< x
-   post2ret -< y
+in2ret :: SM ([Token], [Int]) Token [Maybe Int]
+in2ret = in2post >>>> post2ret
+{-
+hg = hideStorage
 
+in2ret :: SMH Token [Maybe Int]
+in2ret = hg $ proc x -> do
+   y <- (hg in2post) -< x
+   (hg post2ret) -< y
+-}
 -- Parsing and evaluating
 
-getRet :: SM a b -> [a] -> [b]
+getRet :: SM s a b -> [a] -> [b]
 getRet sm xs = snd $ exec sm xs
 
 calc :: [Token] -> [Int]
-calc xs = catMaybes $ concat $ getRet (in2post >>> post2ret) xs
+calc xs = catMaybes $ concat $ getRet in2ret xs
 
 isNum :: Char -> Bool
 isNum x = elem x "0123456789"

@@ -0,0 +1,83 @@+-----------------------------------------------------------------------------+-- Copyright   :  (c) Hanzhong Xu, Meng Meng 2016,+-- License     :  MIT License+--+-- Maintainer  :  hanzh.xu@gmail.com+-- Stability   :  experimental+-- Portability :  portable+-----------------------------------------------------------------------------+-- A collection of toys+-----------------------------------------------------------------------------++module Toys where++-- import System.Random+import Data.Tuple++import Data.Sequence (Seq, empty, (|>), ViewL(..), viewl)++import Control.AFSM+import Control.AFSM.Event++----------+-- Fibs --+----------++-- the nice code from experts.+fibs = 0 : 1 : zipWith (+) fibs (tail fibs)++-- make beginners' life easier.+--   the SM stores f_n and f_{n+1},+--   for each time we update the storage to (f_{n+1}, f_n + f_{n+1}),+--   and outputs f_n.+fibsSM :: SM (Int, Int) () Int+fibsSM = simpleSM (\(a, b) () -> ((b, a+b), a)) (0, 1)++ourfibs = simpleSrc fibsSM++-------------------+-- Random Source --+-------------------+{-+randSM :: StdGen -> SM StdGen () Int+randSM = simpleSM (\g () -> swap $ next g)++randSrc :: Int -> [Int]+randSrc = simpleSrc.randSM.mkStdGen++randSamples = take 5 $ randSrc 111+-}+-------------------+-- Prime Numbers --+-------------------++ltest :: [Int] -> Int -> Bool+ltest [] _ = True+ltest (x:xs) a = if mod a x == 0 then False else if x * x > a then True else ltest xs a++-- [2,3,5,...]+-- origin_primes = filter (ltest origin_primes) [2..]+-- The problem is the first prime number should be given by hand.+origin_primes = 2:(filter (ltest origin_primes) [3..])++seqtest :: (ViewL Int) -> Int -> Bool+seqtest EmptyL _ = True+seqtest (x :< sq) a = if mod a x == 0 then False else if x * x > a then True else seqtest (viewl sq) a+++-- The storage maintains a list of prime numbers it has known so far.+-- Here we use Seq as the storage, it is similar with list, but has more efficient append operation.+-- When a new number comes, the SM test the number with the list, if it pass the test, then add it into the list, else drop it.+primeSM :: SM (Seq Int) Int (Event Int)+primeSM = simpleSM f empty+  where+    f sq a =+      if seqtest (viewl sq) a then+        (sq |> a, Event a)+      else+        (sq, NoEvent)++-- [2,3,5,...]+primes = extractEvents $ smfmap (primeSM) [2..]++--

@@ -1,5 +1,3 @@-{-# LANGUAGE GADTs #-}
-
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.AFSM
@@ -18,251 +16,80 @@ -----------------------------------------------------------------------------
 
 module Control.AFSM (
-  module Control.Arrow,
+  -- module Control.Category,
+  -- module Control.Arrow,
 
   Event(..),
 
-  -- * The 'SM' type
-  SM,
-
-  -- * The 'SMState' type
-  SMState,
+  SMFunctor(..),
+  
+  -- * The 'TF' type
+  TF(..),
+  
+  transSM2TF,
 
-  -- * Constructors
+  -- * The 'SM' type
+  SM(..),
+  
+  -- * SM Constructors
   newSM,
   simpleSM,
-
-  -- * Basic State Machines
-  constSM,
-  idSM,
-  foldlSM,
-  foldlDelaySM,
-  delaySM,
-
-  -- * High order functions
-  execSM,
-  concatSM,
-
-  -- * Evaluation
-  exec
-
-) where
-
-import Control.Category
-import Control.Arrow
-
-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 :: (SMState s a b) -> s -> SM a b
-
--- Constructors
-
--- | It is the same with the SM constructor.
-newSM :: (SMState s a b) -> s -> SM a b
-newSM = SM
-
--- | 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 f' s'', b))
-
--- Basic State Machines
-
--- | build a SM which always return b
-constSM :: b -> SM a b
-constSM b = SM f ()
-  where
-    f _ _ = ((constSM b), b)
-
--- | 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
+  
+  tf, st,
 
-concatSM :: SM a [[b]] -> SM a [b]
-concatSM = fmap concat
+  -- * The 'SMH' type - SM with hidden storage
+  SMH(..),
 
-eventOutSM :: SM a b -> SM a (Event b)
-eventOutSM = fmap Event
+  newSMH,
+  simpleSMH,
 
-eventSM :: SM a b -> SM (Event a) (Event b)
-eventSM = undefined
+  hideStorage,
 
-slowdownSM :: SM a [b] -> SM a (Event b)
-slowdownSM = undefined
+  -- * Source Constructors
+  buildSrc,
+  simpleSrc,
 
--- Category instance
+  -- * Basic State Machines
+  constSM,
+  idSM,
 
-instance Category SM where
-  id  = idSM
-  (.) = composeSM
+  delaySM,
 
-idSM :: SM a a
-idSM = SM (\_ a -> (idSM, a)) ()
+  arrSM,
 
-composeSM :: SM b c -> SM a b -> SM a c
-composeSM sm1 sm0 = SM f2 (sm0,sm1)
-  where
-    f2 ((SM f0 s0),(SM f1 s1)) a = (SM f2 (sm0', sm1'), c)
-      where
-        (sm0', b) = f0 s0 a
-        (sm1', c) = f1 s1 b
+  foldlSM,
+  foldlDelaySM,
 
 
--- Arrow instance
-
-instance Arrow SM where
-  arr = arrSM
-  first = firstSM
-  second = secondSM
-  (***) = productSM
-  (&&&) = fanoutSM
-
-arrSM :: (a -> b) -> SM a b
-arrSM f =
-  SM (\_ a ->(arrSM f, f a)) ()
-
-firstSM :: SM a b -> SM (a, c) (b, c)
-firstSM sm = SM f1 sm
-  where
-    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 f1 sm
-  where
-    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 f2 (sm0, sm1)
-  where
-    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 f2 (sm0, sm1)
-  where
-    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
-
-leftSM :: SM a b -> SM (Either a c) (Either b c)
-leftSM sm = SM f1 sm
-  where
-    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
+  -- * Basic SM functions
+  composeSM, (>>>>), (<<<<), (^>>>), (>>>^), (^<<<), (<<<^),
 
-rightSM :: SM a b -> SM (Either c a) (Either c b)
-rightSM sm = SM f1 sm
-  where
-    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
+  firstSM, secondSM, (****), (&&&&),
+  
+  leftSM, rightSM, (++++), (||||),
+  
+  loopSM,
+  
 
-sumSM :: SM a b -> SM c d -> SM (Either a c) (Either b d)
-sumSM sm0 sm1 = SM f2 (sm0, sm1)
-  where
-    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)
+  absorb,
+  merge,
 
-faninSM :: SM a c -> SM b c -> SM (Either a b) c
-faninSM sm0 sm1 = SM f2 (sm0, sm1)
-  where
-    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)
+  -- * High order Machines
+  execSM,
+  concatSM,
 
-instance ArrowChoice SM where
-  left = leftSM
-  right = rightSM
-  (+++) = sumSM
-  (|||) = faninSM
+  -- * Evaluation
+  step,
+  exec
 
 
--- 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, 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 f1 sm
-  where
-    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
+) where
 
--- | execute SM a b with input [a].
-exec :: SM a b -> [a] -> (SM a b, [b])
-exec sm [] = (sm, [])
-exec (SM f s) (x:xs) = (sm'', b:bs)
-  where
-    (sm', b) = f s x
-    (sm'', bs) = (exec sm' xs)
+import Control.Arrow
+import Control.AFSM.CoreType
+import Control.AFSM.Util
+import Control.AFSM.Core
+import Control.AFSM.Event
+import Control.AFSM.TF
+import Control.AFSM.SMFunctor
+import Control.AFSM.SMH

@@ -0,0 +1,294 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.AFSM.Core+-- Copyright   :  (c) Hanzhong Xu, Meng Meng 2016,+-- License     :  MIT License+--+-- Maintainer  :  hanzh.xu@gmail.com+-- Stability   :  experimental+-- Portability :  portable+-----------------------------------------------------------------------------++module Control.AFSM.Core where++import Control.Category+import Control.Arrow+import Control.Monad++import Control.AFSM.CoreType+import Control.AFSM.Util++infixr 3 ****+infixr 3 &&&&+infixr 2 +++++infixr 2 ||||+infixr 1 >>>>, <<<<+infixr 1 ^>>>, >>>^+infixr 1 ^<<<, <<<^+++-- | Source+--   There are two kinds of source. +--   First one is using the output of `SM s a a` as its input, then it becomes a perpetual motion, :)  +--   Second one is a SM which ignore its input, and output something based on its storage.+--   The second one is easier to understand and use.++-- | build a source, for example:+--   buildSrc $ foldlDelaySM (const (+1)) 0+--     [0..]+--   buildSrc $ foldlDelaySM (+) 1+--     [1, 2, 4, 8, ...]+buildSrc :: SM s a a -> [a]+buildSrc sm = a:(buildSrc sm')+  where+    (sm', a) = step sm a++-- | build a simple source, which ignore the inputs+--     fibsSM :: SM (Int, Int) () Int+--     fibsSM = simpleSM (\(a, b) () -> ((b, a+b), a)) (0, 1)+--     take 10 $ simpleSrc fibsSM+--       [0,1,1,2,3, ...]simpleSrc :: SM s () a -> [a]+simpleSrc sm = a:(simpleSrc sm')+  where+    (sm', a) = step sm ()++-- Basic State Machines+        +-- | build a SM which just output its input+idSM :: SM () a a+idSM = newSM (\_ a -> (idSM, a)) ()++-- | build a SM which always return b+constSM :: b -> SM () a b+constSM b = newSM f ()+  where+    f _ _ = ((constSM b), b)++-- | delay the input with given value.+-- delaySM = foldlDelaySM (const id)+delaySM :: a -> SM a a a+delaySM a = newSM f a+  where+    f s' a' = ((newSM f a'), s')++-- | build a SM from a function+arrSM :: (a -> b) -> SM () a b+arrSM f = newSM (\_ a ->(arrSM f, f a)) ()++-- | the same with foldl+foldlSM :: (s -> a -> s) -> s -> SM s a s+foldlSM f s = newSM f' s+  where+    f' s' a' = (newSM f' s'', s'')+      where+        s'' = f s' a'++-- | the difference from foldlSM is it output the storage first.+foldlDelaySM :: (s -> a -> s) -> s -> SM s a s+foldlDelaySM f s = newSM f' s+  where+    f' s' a' = (newSM f' s'', s')+      where+        s'' = f s' a'++-- holdSM :: a -> SM (Event a) a+-- holdSM = undefined++-- filterSM :: (a -> Bool) -> SM a (Event a)+-- filterSM = undefined+++-- High order functions++-- | absorb a function.+--     absorbR sm f = absorbRSM sm (arrSM f)+--     absorbL f sm = absorbLSM (arrSM f) sm+absorbR :: SM s a b -> (b -> c) -> SM s a c+absorbR (SM (TF f0) s) f1 = newSM (f2 f0) s+  where+    f2 f0 s a = (newSM (f2 f0') s', f1 b)+      where+        (SM (TF f0') s', b) = f0 s a++absorbL :: (a -> b) -> SM s b c -> SM s a c+absorbL f0 (SM (TF f1) s) = newSM (f2 f1) s+  where+    f2 f1 s a = (newSM (f2 f1') s', c)+      where+        (SM (TF f1') s', c) = f1 s (f0 a)++(^>>>) = absorbL+(>>>^) = absorbR+(<<<^) = flip absorbL+(^<<<) = flip absorbR++-- Category instance++-- idSM++-- | compose two SM and merge their storage.+composeSM :: SM s1 b c -> SM s0 a b -> SM (s0, s1) a c+composeSM (SM (TF f1) s1) (SM (TF f0) s0) = newSM (f2 f0 f1) (s0, s1)+  where+    f2 f0 f1 (s0, s1) a = (newSM (f2 f0' f1') (s0', s1'), c)+      where+        (SM (TF f0') s0', b) = f0 s0 a+        (SM (TF f1') s1', c) = f1 s1 b++-- | Right-to-left composition+(<<<<) :: SM s1 b c -> SM s0 a b -> SM (s0, s1) a c+(<<<<) = composeSM++-- | Left-to-right composition+(>>>>) :: SM s0 a b -> SM s1 b c -> SM (s0, s1) a c+f >>>> g = composeSM g f+++-- Arrow instance++-- arrSM+++firstSM :: SM s a b -> SM s (a, c) (b, c)+firstSM (SM (TF f) s) = newSM (f1 f) s+  where+    f1 f s (a, c) = (newSM (f1 f') s', (b, c))+      where+        (SM (TF f') s', b) = f s a++secondSM :: SM s a b -> SM s (c, a) (c, b)+secondSM (SM (TF f) s) = newSM (f1 f) s+  where+    f1 f s (c, a) = (newSM (f1 f') s', (c, b))+      where+        (SM (TF f') s', b) = f s a++productSM :: SM s0 a b -> SM s1 c d -> SM (s0, s1) (a, c) (b, d)+productSM (SM (TF f0) s0) (SM (TF f1) s1) = newSM (f2 f0 f1) (s0, s1)+  where+    f2 f0 f1 (s0, s1) (a, c) = (newSM (f2 f0' f1') (s0', s1'), (b, d))+      where+        (SM (TF f0') s0', b) = f0 s0 a+        (SM (TF f1') s1', d) = f1 s1 c++fanoutSM :: SM s0 a b -> SM s1 a c -> SM (s0, s1) a (b, c)+fanoutSM (SM (TF f0) s0) (SM (TF f1) s1) = newSM (f2 f0 f1) (s0, s1)+  where+    f2 f0 f1 (s0, s1) a = (newSM (f2 f0' f1') (s0', s1'), (b, c))+      where+        (SM (TF f0') s0', b) = f0 s0 a+        (SM (TF f1') s1', c) = f1 s1 a++(****) = productSM++(&&&&) = fanoutSM++{-+firstSM :: SM s a b -> SM s (a, c) (b, c)+firstSM sm = absorb (\(a, c) -> a) (\(a, c) b -> (b, c)) sm++secondSM :: SM s a b -> SM s (c, a) (c, b)+secondSM sm = absorb (\(c, a) -> a) (\(c, a) b -> (c, b)) sm++(****) :: SM s0 a b -> SM s1 c d -> SM (s0, s1) (a, c) (b, d)+(****) sm0 sm1 = merge (\(a, c) -> (a, c)) (\a b d -> (b, d)) sm0 sm1++(&&&&) :: SM s0 a b -> SM s1 a c -> SM (s0, s1) a (b, c)+(&&&&) sm0 sm1 = merge (\a -> (a, a)) (\a b0 b1 -> (b0, b1)) sm0 sm1+-}++-- ArrowChoice instance++leftSM :: SM s a b -> SM s (Either a c) (Either b c)+leftSM (SM (TF f0) s) = newSM (f1 f0) s+  where+    f1 f0 s (Right c) = (newSM (f1 f0) s, Right c)+    f1 f0 s (Left a) = (newSM (f1 f0') s', Left b)+      where+        (SM (TF f0') s', b) = f0 s a++rightSM :: SM s a b -> SM s (Either c a) (Either c b)+rightSM (SM (TF f0) s) = newSM (f1 f0) s+  where+    f1 f0 s (Left c) = (newSM (f1 f0) s, Left c)+    f1 f0 s (Right a) = (newSM (f1 f0') s', Right b)+      where+        (SM (TF f0') s', b) = f0 s a++sumSM :: SM s0 a b -> SM s1 c d -> SM (s0,s1) (Either a c) (Either b d)+sumSM (SM (TF f0) s0) (SM (TF f1) s1) = newSM (f2 f0 f1) (s0, s1)+  where+    f2 f0 f1 (s0, s1) (Left a)  = let (SM (TF f0') s0', b) = f0 s0 a in (newSM (f2 f0' f1) (s0', s1), Left b)+    f2 f0 f1 (s0, s1) (Right c) = let (SM (TF f1') s1', d) = f1 s1 c in (newSM (f2 f0 f1') (s0, s1'), Right d)++faninSM :: SM s0 a c -> SM s1 b c -> SM (s0, s1) (Either a b) c+faninSM (SM (TF f0) s0) (SM (TF f1) s1) = newSM (f2 f0 f1) (s0, s1)+  where+    f2 f0 f1 (s0, s1) (Left a)  = let (SM (TF f0') s0', c) = f0 s0 a in (newSM (f2 f0' f1) (s0', s1), c)+    f2 f0 f1 (s0, s1) (Right b) = let (SM (TF f1') s1', c) = f1 s1 b in (newSM (f2 f0 f1') (s0, s1'), c)++    +(++++) = sumSM++(||||) = faninSM++-- ArrowLoop++loopSM :: SM s (a, c) (b, c) -> SM s a b+loopSM (SM (TF f0) s) = newSM (f1 f0) s+  where+    f1 f0 s a = (newSM (f1 f0') s', b)+      where+        (SM (TF f0') s', (b, c)) = f0 s (a, c)+++++-- | 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 s a b -> SM s [a] [b]+execSM (SM (TF f) s) = newSM (f1 f) s+  where+    f1 f s xs = (newSM (f1 f') s', bs)+      where+        (SM (TF f') s', bs) = exec (newSM f s) xs+++joinSM :: Monad m => SM s a (m (m b)) -> SM s a (m b)+joinSM sm = absorbR sm join++concatSM :: SM s a [[b]] -> SM s a [b]+concatSM = joinSM++-- 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+++-- Evaluation++-- | run SM a b with a.+step :: SM s a b -> a -> (SM s a b, b)+step (SM (TF f) s) a = f s a++-- | execute SM a b with input [a].+--   Also, it is the map function for SM, perhaps, We should define our own Functor class, the SMFunctor!+exec :: SM s a b -> [a] -> (SM s a b, [b])+exec sm [] = (sm, [])+exec (SM (TF f) s) (x:xs) = (sm'', b:bs)+  where+    (sm', b) = f s x+    (sm'', bs) = (exec sm' xs)++-- Functor++instance Functor (SM s a) where+  fmap = fmapSM++-- | fmapSM f sm = sm >>> arr f+fmapSM :: (b -> c) -> SM s a b -> SM s a c+fmapSM f sm = absorbR sm f

@@ -0,0 +1,79 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.AFSM.CoreType+-- Copyright   :  (c) Hanzhong Xu, Meng Meng 2016,+-- License     :  MIT License+--+-- Maintainer  :  hanzh.xu@gmail.com+-- Stability   :  experimental+-- Portability :  portable+-----------------------------------------------------------------------------++-- {-# LANGUAGE ExistentialQuantification #-}++module Control.AFSM.CoreType where++-- | 'TF' is a type representing a transition function.+--     s: storage, a: input, b: output+--   Let's explain more about 'TF'. When a state gets an input a,+--   it should do three things base on the storage and input:+--     find the next state, update storage and output b.+--   That's why it looks like this:+--     (storage -> a -> (SM newState newStorage, b))+--     type TF storage input output = (storage -> input -> (SM storage input output, output))+--   Also, it is an instance of Arrow, it represents a machine without initial storage.+--     composing two TF represents that two SM shares the same storage+newtype TF s a b = TF (s -> a -> (SM s a b, b))++-- | STF is the type of simple transition function.+type STF s a b = (s -> a -> (s, b))++-- | 'SM' is a type representing a state machine.+--     (TF s a b): initial state(transition function), s: initial storage+--     SM storage input output = SM (TF storage input output) storage+data SM s a b = SM (TF s a b) s++tf :: SM s a b -> (s -> a -> (SM s a b, b))+{-# INLINE tf #-}+tf (SM (TF f) _) = f++st :: SM s a b -> s+{-# INLINE st #-}+st (SM _ s) = s++-- Constructors++-- | It is the same with the SM constructor.+newSM :: (s -> a -> (SM s a b, b)) -> s -> SM s a b+{-# INLINE newSM #-}+newSM tf s = SM (TF tf) s++-- | build a simple SM which have only one TF.+simpleSM :: (s -> a -> (s, b)) -> s -> SM s a b+{-# INLINE simpleSM #-}+simpleSM f s = newSM f' s+  where+    f' s' a' = (newSM f' s'', b)+      where+        (s'', b) = f s' a'++{-+-- | build a SM which can choose STF based on the input+simplChcSM :: (s -> a -> STF s a b) -> s -> SM s a b+simplChcSM cf s = simpleSM f s+  where+    f s a = (s', b)+      where+        (s', b) = (cf s a) s a+-}++instance (Show s) => Show (SM s a b) where+  show (SM f s) = show s++-- | 'SMH' is the type of the state machine with hidden or no storage.+--   It is the same type with+--     Circuit a b = Circuit (a -> Circuit a b, b)+type SMH a b = SM () a b++-- | '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)

@@ -1,9 +1,6 @@-{-# LANGUAGE GADTs #-}
-
-
 -----------------------------------------------------------------------------
 -- |
--- Module      :  Control.AFSM
+-- Module      :  Control.AFSM.Event
 -- Copyright   :  (c) Hanzhong Xu, Meng Meng 2016,
 -- License     :  MIT License
 --
@@ -12,10 +9,55 @@ -- Portability :  portable
 -----------------------------------------------------------------------------
 
-module Control.AFSM.Event where
-
+module Control.AFSM.Event (
+  extractEvents
+)where
 
+import Control.Applicative
+import Control.Monad
 
+import Control.AFSM.CoreType
+import Control.AFSM.SMFunctor
 
 -- | '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)+-- data Event a = Event a | NoEvent | ErrEvent String | ExitEvent deriving (Show, Eq, Ord)
+
+-- | extract [a] from [Event a]
+extractEvents :: [Event a] -> [a]
+extractEvents [] = []
+extractEvents (x:xs) = case x of
+  Event a -> a:ys
+  NoEvent -> ys
+  ErrEvent s -> []
+  ExitEvent -> []
+  where
+    ys = (extractEvents xs)
+    
+instance Functor Event where
+  fmap f (Event a) = Event (f a)
+  fmap _ NoEvent = NoEvent
+  fmap _ (ErrEvent s) = (ErrEvent s)
+  fmap _  ExitEvent = ExitEvent
+  
+instance Applicative Event where
+  pure a = Event a
+  (<*>) (Event f) m = fmap f m
+  (<*>) (ErrEvent s0) (ErrEvent s1) = ErrEvent $ s0 ++ "," ++ s1
+  (<*>) (ErrEvent s0) _ = ErrEvent s0
+  (<*>) ExitEvent _ = ExitEvent
+  (<*>) NoEvent _ = NoEvent
+
+instance Monad Event where
+  return = pure
+  (>>=) (Event a) f = f a
+  (>>=) NoEvent _ = NoEvent
+  (>>=) (ErrEvent s) _ = (ErrEvent s)
+  (>>=) ExitEvent _ = ExitEvent
+  
+
+instance SMFunctor Event where
+  smexec sm NoEvent = (sm, NoEvent)
+  smexec sm (ErrEvent s) = (sm, ErrEvent s)
+  smexec sm ExitEvent = (sm, ExitEvent)
+  smexec (SM (TF f) s) (Event a) = (sm', Event b)
+    where (sm', b) = f s a

@@ -0,0 +1,112 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.AFSM.SMFunctor+-- Copyright   :  (c) Hanzhong Xu, Meng Meng 2016,+-- License     :  MIT License+--+-- Maintainer  :  hanzh.xu@gmail.com+-- Stability   :  experimental+-- Portability :  portable+-----------------------------------------------------------------------------++-- {-# LANGUAGE InstanceSigs #-}++module Control.AFSM.SMFunctor where++-- import Prelude hiding ((.))+-- import Data.Functor.+import Data.Functor.Compose+import Control.Monad++import Control.AFSM.CoreType+import Control.AFSM.Util+-- import Control.AFSM.Core++class SMFunctor f where+  smexec :: SM s a b -> f a -> (SM s a b, f b)+  smfmap :: SM s a b -> f a -> f b+  smfmap sm a = snd $ smexec sm a ++instance SMFunctor [] where+  smexec sm [] = (sm, [])+  smexec (SM (TF f) s) (x:xs) = (sm'', b:bs)+    where+      (sm', b) = f s x+      (sm'', bs) = (smexec sm' xs)++instance SMFunctor Maybe where+  smexec sm Nothing = (sm, Nothing)+  smexec (SM (TF f) s) (Just a) = (sm', Just b)+    where (sm', b) = f s a++-- instance SMFunctor Identity where+--   smexec sm a = (sm', Identity b)+--     where (sm', b) = step sm (runIdentity a)++instance SMFunctor ((->) r) where+  smexec sm@(SM (TF f) s) ra = (sm, rb)+    where+      rb r = snd $ f s (ra r)+     +-- instance SMFunctor (SM s r) where+--   smexec sm ra = (sm, absorbRSM ra sm)+  +instance SMFunctor (Either a) where+  smexec sm (Left a) = (sm, Left a)+  smexec (SM (TF f) s) (Right b) = (sm', Right c)+    where (sm', c) = f s b+    +instance SMFunctor ((,) a) where+  smexec (SM (TF f) s) (a, b) = (sm', (a, c))+    where (sm', c) = f s b+    +   +smexecSM :: SMFunctor f => SM s a b -> SM s (f a) (f b)+smexecSM (SM (TF f0) s0') = newSM (f1 f0) s0'+  where+    f1 f0 s0 fa = (newSM (f1 f0') s0', fb)+      where +      ((SM (TF f0') s0'), fb) = smexec (newSM f0 s0) fa+    +-- Advanced functions++smexecSMA :: SMFunctor f => SM s a b -> SM (SM s a b) (f a) (f b)+smexecSMA sm = newSM f sm+  where+    f sm fa = (newSM f sm', fb)+      where +      (sm', fb) = smexec sm fa  ++-- newtype Compose f g a = Compose { getCompose :: f (g a) }++instance (SMFunctor f, SMFunctor g) => SMFunctor (Compose f g) where+  smexec sm fga = (st sm'', Compose fgb)+    where+      sm' = smexecSMA sm+      (sm'', fgb) = smexec sm' $ getCompose fga+      +  +      +-- SMMonad++bindSM :: (Monad m, SMFunctor m) => m a -> SM s a (m b) -> (SM s a (m b), m b)+bindSM ma sm = (sm', join mmb)+  where+    (sm', mmb) = smexec sm ma++(>>>=) :: (Monad m, SMFunctor m) => m a -> SM s a (m b) -> m b+(>>>=) ma sm = join $ smfmap sm ma++{-++-- require WrappedMonad.++class SMMonad m where+  (>>>=) :: m a -> SM s a (m b) -> (SM s a (m b), m b)++instance (Monad m, SMFunctor m) => SMMonad m where+  (>>>=) ma sm = (sm', join mmb)+    where+      (sm', mmb) = smfmap sm ma+      +-}

@@ -0,0 +1,190 @@+{-# LANGUAGE FlexibleInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.AFSM.SMH+-- Copyright   :  (c) Hanzhong Xu, Meng Meng 2016,+-- License     :  MIT License+--+-- Maintainer  :  hanzh.xu@gmail.com+-- Stability   :  experimental+-- Portability :  portable+-----------------------------------------------------------------------------++module Control.AFSM.SMH (+  +  newSMH,+  simpleSMH,+  +  hideStorage+  +) where++import Control.Category+import Control.Arrow++import Control.AFSM.CoreType+import Control.AFSM.Core++-- | the same constructor with newSM+newSMH :: (() -> a -> (SMH a b, b)) -> SMH a b+newSMH f = newSM f ()++-- | the same constructor with simpleSM+simpleSMH :: (s -> a -> (s, b)) -> s -> SMH a b+simpleSMH f s = newSMH (f' s)+  where+    f' s' () a' = (newSMH (f' s''), b)+      where+        (s'', b) = f s' a' ++-- | hide the Storage type in the transition function.+hideStorage :: SM s a b -> SMH a b+hideStorage (SM (TF f) s) = newSMH (f1 f s)+  where +    f1 f s () a = (newSMH (f1 f' s'), b)+      where+        (SM (TF f') s', b) = f s a++-- | absorb the right SM and hide its storage.+absorbRSM :: SM s0 a b -> SM s1 b c -> SM s0 a c+absorbRSM (SM (TF f0) s0) (SM (TF f1) s1) = newSM (f2 f0 f1 s1) s0+  where+    f2 f0 f1 s1 s0 a = (newSM (f2 f0' f1' s1') s0', c)+      where+        (SM (TF f0') s0', b) = f0 s0 a+        (SM (TF f1') s1', c) = f1 s1 b++-- | absorb the left SM and hide its storage.+absorbLSM :: SM s0 a b -> SM s1 b c -> SM s1 a c+absorbLSM (SM (TF f0) s0) (SM (TF f1) s1) = newSM (f2 f0 f1 s0) s1+  where+    f2 f0 f1 s0 s1 a = (newSM (f2 f0' f1' s0') s1', c)+      where+        (SM (TF f0') s0', b) = f0 s0 a+        (SM (TF f1') s1', c) = f1 s1 b+    +-- Category instance++instance Category (SM ()) where+  id  = idSMH+  (.) = composeSMH++idSMH :: SMH a a+idSMH = newSMH (\_ a -> (idSMH, a))++composeSMH :: SMH b c -> SMH a b -> SMH a c+composeSMH (SM (TF f1) _) (SM (TF f0) _) = newSMH (f2 f0 f1)+  where+    f2 f0 f1 _ a = (newSMH (f2 f0' f1'), c)+      where+        (SM (TF f0') _, b) = f0 () a+        (SM (TF f1') _, c) = f1 () b++        +-- Arrow instance++instance Arrow (SM ()) where+  arr = arrSMH+  first = firstSMH+  second = secondSMH+  (***) = productSMH+  (&&&) = fanoutSMH++arrSMH :: (a -> b) -> SMH a b+arrSMH f = newSMH (\_ a ->(arrSMH f, f a))++firstSMH :: SMH a b -> SMH (a, c) (b, c)+firstSMH (SM (TF f) _) = newSMH (f1 f)+  where+    f1 f _ (a, c) = (newSMH (f1 f'), (b, c))+      where+        (SM (TF f') _, b) = f () a+++secondSMH :: SMH a b -> SMH (c, a) (c, b)+secondSMH (SM (TF f) _) = newSMH (f1 f)+  where+    f1 f _ (c, a) = (newSMH (f1 f'), (c, b))+      where+        (SM (TF f') _, b) = f () a++productSMH :: SMH a b -> SMH c d -> SMH (a, c) (b, d)+productSMH (SM (TF f0) _) (SM (TF f1) _) = newSMH (f2 f0 f1)+  where+    f2 f0 f1 _ (a, c) = (newSMH (f2 f0' f1'), (b, d))+      where+        (SM (TF f0') _, b) = f0 () a+        (SM (TF f1') _, d) = f1 () c++fanoutSMH :: SMH a b -> SMH a c -> SMH a (b, c)+fanoutSMH (SM (TF f0) _) (SM (TF f1) _) = newSMH (f2 f0 f1)+  where+    f2 f0 f1 _ a = (newSMH (f2 f0' f1'), (b, c))+      where+        (SM (TF f0') _, b) = f0 () a+        (SM (TF f1') _, c) = f1 () a++++-- ArrowChoice++instance ArrowChoice (SM ()) where+  left = leftSMH+  right = rightSMH+  (+++) = sumSMH+  (|||) = faninSMH++leftSMH :: SMH a b -> SMH (Either a c) (Either b c)+leftSMH (SM (TF f0) _) = newSMH (f1 f0)+  where+    f1 f0 _ (Right c) = (newSMH (f1 f0), Right c)+    f1 f0 _ (Left a) = (newSMH (f1 f0'), Left b)+      where+        (SM (TF f0') _, b) = f0 () a++rightSMH :: SMH a b -> SMH (Either c a) (Either c b)+rightSMH (SM (TF f0) _) = newSMH (f1 f0)+  where+    f1 f0 _ (Left c) = (newSMH (f1 f0), Left c)+    f1 f0 _ (Right a) = (newSMH (f1 f0'), Right b)+      where+        (SM (TF f0') _, b) = f0 () a++sumSMH :: SMH a b -> SMH c d -> SMH (Either a c) (Either b d)+sumSMH (SM (TF f0) _) (SM (TF f1) _) = newSMH (f2 f0 f1)+  where+    f2 f0 f1 _ (Left a)  = let (SM (TF f0') _, b) = f0 () a in (newSMH (f2 f0' f1), Left b)+    f2 f0 f1 _ (Right c) = let (SM (TF f1') _, d) = f1 () c in (newSMH (f2 f0 f1'), Right d)++faninSMH :: SMH a c -> SMH b c -> SMH (Either a b) c+faninSMH (SM (TF f0) _) (SM (TF f1) _) = newSMH (f2 f0 f1)+  where+    f2 f0 f1 _ (Left a)  = let (SM (TF f0') _, c) = f0 () a in (newSMH (f2 f0' f1), c)+    f2 f0 f1 _ (Right b) = let (SM (TF f1') _, c) = f1 () b in (newSMH (f2 f0 f1'), c)+++-- ArrowApply++instance ArrowApply (SM ()) where+  app = appSM++appSM :: SMH (SMH a b, a) b+appSM = newSMH f+  where+    f _ (SM (TF f0) _, a) = (newSMH f, snd $ f0 () a)+++-- ArrowLoop++instance ArrowLoop (SM ()) where+    loop = loopSMH+++-- SM has build-in loop structure, but the ArrowLoop instance helps us sharing storage between SMs, and adding one more instance is harmless, :)+loopSMH :: SMH (a, c) (b, c) -> SMH a b+loopSMH (SM (TF f0) _) = newSMH (f1 f0)+  where+    f1 f0 _ a = (newSMH (f1 f0'), b)+      where+        (SM (TF f0') _, (b, c)) = f0 () (a, c)

@@ -0,0 +1,131 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.AFSM.TF+-- Copyright   :  (c) Hanzhong Xu, Meng Meng 2016,+-- License     :  MIT License+--+-- Maintainer  :  hanzh.xu@gmail.com+-- Stability   :  experimental+-- Portability :  portable+-----------------------------------------------------------------------------++module Control.AFSM.TF where++import Control.Category+import Control.Arrow++import Control.AFSM.CoreType+import Control.AFSM.Core++-- newtype TF s a b = TF (s -> a -> (SM s a b, b)++-- | transform `SM t (s, a) (s, b)` to `TF s a b`+transSM2TF :: SM t (s, a) (s, b) -> TF s a b+transSM2TF (SM (TF f) t) = TF (f1 f t)+  where+    f1 f t s a = (newSM (f1 f' t') s', b)+      where+        (SM (TF f') t', (s', b)) = f t (s, a)++-- Category instance++instance Category (TF s) where+  id = idTF+  (.) = composeTF+  +  +idTF :: TF s a a+idTF = TF f+  where+    f s a = (newSM f s, a)+    +composeTF :: TF s b c -> TF s a b -> TF s a c+composeTF (TF f1) (TF f0) = TF $ f2 f0 f1+  where+    f2 f0 f1 s a = (newSM (f2 (tf sm0) (tf sm1)) (st sm1), c)+      where+        (sm0, b) = f0 s a+        (sm1, c) = f1 (st sm0) b+        ++-- Arrow instance++instance Arrow (TF s) where+  arr = arrTF+  first = firstTF+  +arrTF :: (a -> b) -> TF s a b+arrTF f = TF f1+  where+    f1 s a = (newSM f1 s, f a)++firstTF :: TF s a b -> TF s (a, c) (b, c)+firstTF (TF f) = TF $ f1 f+  where+    f1 f s (a, c) = (newSM (f1 (tf sm)) (st sm), (b, c))+      where+        (sm, b) = f s a++        +-- ArrowChoice++instance ArrowChoice (TF s) where+  left = leftTF+  right = rightTF+  (+++) = sumTF+  (|||) = faninTF+  +leftTF :: TF s a b -> TF s (Either a c) (Either b c)+leftTF (TF f0) = TF (f1 f0)+  where+    f1 f0 s (Right c) = (newSM (f1 f0) s, Right c)+    f1 f0 s (Left a) = (newSM (f1 f0') s', Left b)+      where+        (SM (TF f0') s', b) = f0 s a+        +rightTF :: TF s a b -> TF s (Either c a) (Either c b)+rightTF (TF f0) = TF (f1 f0)+  where+    f1 f0 s (Left c) = (newSM (f1 f0) s, Left c)+    f1 f0 s (Right a) = (newSM (f1 f0') s', Right b)+      where+        (SM (TF f0') s', b) = f0 s a++sumTF :: TF s a b -> TF s c d -> TF s (Either a c) (Either b d)+sumTF (TF f0) (TF f1) = TF (f2 f0 f1)+  where+    f2 f0 f1 s (Left a)  = let (SM (TF f0') s', b) = f0 s a in (newSM (f2 f0' f1) s', Left b)+    f2 f0 f1 s (Right c) = let (SM (TF f1') s', d) = f1 s c in (newSM (f2 f0 f1') s', Right d)++faninTF :: TF s a c -> TF s b c -> TF s (Either a b) c+faninTF (TF f0) (TF f1) = TF (f2 f0 f1)+  where+    f2 f0 f1 s (Left a)  = let (SM (TF f0') s', c) = f0 s a in (newSM (f2 f0' f1) s', c)+    f2 f0 f1 s (Right b) = let (SM (TF f1') s', c) = f1 s b in (newSM (f2 f0 f1') s', c)+    +-- ArrowApply++instance ArrowApply (TF s) where+  app = appTF++appTF :: TF s (TF s a b, a) b+appTF = TF f+  where+    f s (TF f0, a) = (newSM f s', b)+      where+        (SM (TF f0') s', b) = f0 s a+++-- ArrowLoop++instance ArrowLoop (TF s) where+    loop = loopTF+    +loopTF :: TF s (a, c) (b, c) -> TF s a b+loopTF (TF f0) = TF (f1 f0)+  where+    f1 f0 s a = (newSM (f1 f0') s, b)+      where+        (SM (TF f0') s', (b, c)) = f0 s (a, c)++

@@ -0,0 +1,45 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.AFSM.Util+-- Copyright   :  (c) Hanzhong Xu, Meng Meng 2016,+-- License     :  MIT License+--+-- Maintainer  :  hanzh.xu@gmail.com+-- Stability   :  experimental+-- Portability :  portable+-----------------------------------------------------------------------------++module Control.AFSM.Util where++import Control.AFSM.CoreType ++f1template :: (a1 -> a0) -> (a1 -> b0 -> b1)+           -> (s -> a0 -> (SM s a0 b0, b0)) +           -> s -> a1 -> (SM s a1 b1, b1)+f1template from to f0 s a1 =  (newSM (f1template from to f0') s', (to a1 b0))+  where+    a0 = from a1+    (sm0, b0) = f0 s a0+    f0' = tf sm0+    s' = st sm0++f2template :: (a2 -> (a0, a1)) -> (a2 -> b0 -> b1 -> b2) +           -> (s0 -> a0 -> (SM s0 a0 b0, b0)) -> (s1 -> a1 -> (SM s1 a1 b1, b1)) +           -> (s0,s1) -> a2 -> (SM (s0,s1) a2 b2, b2)+f2template from to f0 f1 (s0, s1) a2 = (newSM (f2template from to f0' f1') (s0', s1'), (to a2 b0 b1))+  where+    (a0, a1) = from a2+    (sm0, b0) = f0 s0 a0+    (sm1, b1) = f1 s1 a1+    f0' = tf sm0+    s0' = st sm0+    f1' = tf sm1+    s1' = st sm1+++absorb :: (a1 -> a0) -> (a1 -> b0 -> b1) -> SM s a0 b0 -> SM s a1 b1+absorb from to sm0 = newSM (f1template from to (tf sm0)) (st sm0)++merge :: (a2 -> (a0, a1)) -> (a2 -> b0 -> b1 -> b2)+      -> SM s0 a0 b0 -> SM s1 a1 b1 -> SM (s0,s1) a2 b2+merge from to sm0 sm1 = newSM (f2template from to (tf sm0) (tf sm1)) (st sm0, st sm1)