packages feed

AFSM 0.1.0.0 → 0.1.1.0

raw patch · 4 files changed

+212/−56 lines, 4 files

Files

AFSM.cabal view
@@ -1,76 +1,29 @@--- Initial AFSM.cabal generated by cabal init.  For further documentation, --- see http://haskell.org/cabal/users-guide/---- The name of the package. name:                AFSM---- The package version.  See the Haskell package versioning policy (PVP) --- for standards guiding when and how versions should be incremented.--- http://www.haskell.org/haskellwiki/Package_versioning_policy--- PVP summary:      +-+------- breaking API changes---                   | | +----- non-breaking API additions---                   | | | +--- code changes with no API change-version:             0.1.0.0---- A short (one-line) description of the package.+version:             0.1.1.0 synopsis:            Arrowized functional state machines---- A longer description of the package. description: Arrowized functional state machines.              This module is inspired by Yampa and the paper               /Functional Reactive Programming, Continued*/ written by              Henrik Nilsson, Antony Courtney and John Peterson.        ---- URL for the project homepage or repository.-homepage:            https://github.com/FiveEye/AFSM---- The license under which the package is released.+homepage:            https://github.com/PseudoPower/AFSM license:             MIT---- The file containing the license text. license-file:        LICENSE---- The package author(s).-author:              Hanzhong Xu---- An email address to which users can send suggestions, bug reports, and --- patches.+author:              Hanzhong Xu, Meng Meng maintainer:          hanzh.xu@gmail.com---- A copyright notice. -- copyright:           - category:            FRP- build-type:          Simple---- Extra files to be distributed with the package, such as examples or a --- README.--- extra-source-files:  ---   examples/RPN.hs--- Constraint on the version of Cabal needed to build this package.+extra-source-files:  +  examples/RPN.hs cabal-version:       >=1.10-- library-  -- Modules exported by the library.   exposed-modules:     Control.AFSM-  -  -- Modules included in this library but not exported.   -- other-modules:       -  -  -- LANGUAGE extensions used by modules in this package.   other-extensions:    Arrows, GADTs-  -  -- Other library packages from which modules are imported.   build-depends:       base >=4.7 && <4.8-  -  -- Directories containing source files.+  -- ghc-options:   hs-source-dirs:      src-  -  -- Base language which the package is written in.   default-language:    Haskell2010-   source-repository head   type: git-  location: git@github.com:FiveEye/AFSM.git+  location: git@github.com:PseudoPower/AFSM.git
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2016 Hanzhong Xu+Copyright (c) 2016 Han  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the
+ examples/RPN.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE Arrows #-}
+
+module Main where
+
+import Control.AFSM
+import Data.Maybe
+-- import Data.Map (fromList, (!))
+
+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 
+  deriving (Eq)
+
+instance Show Token where
+  show (Num x) = show x
+  show (Op op) = show op
+  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]
+
+-- 3 + 4 * 2 / (1 - 5) * 2 + 3
+test2 = [Num 3, Op Add, Num 4, Op Mul, Num 2, Op Div, L, Num 1, Op Sub, Num 5, R, Op Mul, Num 2, Op Add, Num 3, End]
+
+
+-- State machines
+
+trans0 :: [Token] -> Token -> ([Token], [Token])
+trans0 xs End = ([End], xs)
+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 = 
+  (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]
+--  >----->| in2post |>------->
+--         \---------/
+--
+in2post :: SM Token [Token]
+in2post = simpleSM [End] trans0
+
+f :: Op -> Int -> Int -> Int
+f Add x y = x + y
+f Sub x y = x - y
+f Mul x y = x * y
+f Div x y = quot x y
+
+trans1 :: [Int] -> Token -> ([Int], Maybe Int)
+trans1 xs End = if (null xs) then (xs, Just 0) else ([], Just $ head xs)
+trans1 xs (Num x) = (x:xs, Nothing)
+trans1 (x:y:xs) (Op o) = ((f o y x):xs, Nothing)
+
+-- the SM evaluating postfix expression
+--
+--   Token /-----------\ Maybe Int
+--  >----->| post2ret' |>--------->
+--         \-----------/
+--
+post2ret' :: SM Token (Maybe Int)
+post2ret' = simpleSM [] trans1
+
+
+--
+--   [Token] /----------\ [Maybe Int]
+--  >------->| post2ret |>----------->
+--           \----------/
+--
+post2ret :: SM [Token] [Maybe Int]
+post2ret = execSM post2ret'
+
+
+
+-- the SM composed of in2post and post2ret
+--
+--         /----------------------------\
+--   Token |          [Token]           | [Maybe Int]
+--  >----->| in2post >-------> post2ret |>----------->
+--         |                            |
+--         \----------------------------/
+--                     in2ret
+--
+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]
+getRet sm xs = snd $ exec sm xs
+
+calc :: [Token] -> [Int]
+calc xs = catMaybes $ concat $ getRet (in2post >>> post2ret) xs
+
+isNum :: Char -> Bool
+isNum x = elem x "0123456789"
+
+-- parseOp x = (fromList $ zip "()+-*/" [L, R, Op Add, Op Sub, Op Mul, Op Div])!x
+parseOp :: Char -> Token
+parseOp '(' = L
+parseOp ')' = R
+parseOp '+' = Op Add
+parseOp '-' = Op Sub
+parseOp '*' = Op Mul
+parseOp '/' = Op Div
+
+parseStr :: String -> [Token]
+parseStr [] = [End]
+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 xs)
+  else if elem x "()+-*/" then
+    (parseOp x):(parseStr xs)
+  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
src/Control/AFSM.hs view
@@ -2,7 +2,7 @@ 
 -----------------------------------------------------------------------------
 -- |
--- Module      :  
+-- Module      :  Control.AFSM
 -- Copyright   :  (c) Hanzhong Xu 2016,
 -- License     :  MIT License
 --
@@ -118,6 +118,55 @@         (sm0', b) = f0 r0 a
         (sm1', c) = f1 r1 a
 
+-- ArrowChoice 
+
+leftSM :: SM a b -> SM (Either a c) (Either b c)
+leftSM sm = SM sm f1
+  where
+    f1 sm' (Right c) = (SM sm' f1, Right c)
+    f1 (SM r0 f0) (Left a) = (SM sm'' f1, Left b)
+      where
+        (sm'', b) = f0 r0 a
+
+rightSM :: SM a b -> SM (Either c a) (Either c b)
+rightSM sm = SM sm f1
+  where
+    f1 sm' (Left c) = (SM sm' f1, Left c)
+    f1 (SM r f) (Right a) = ((SM sm'' f1), Right b)
+      where
+        (sm'', b) = f r a
+        
+sumSM :: SM a b -> SM c d -> SM (Either a c) (Either b d)
+sumSM sm0 sm1 = SM (sm0, sm1) f2
+  where
+    f2 (SM r0 f0, sm1') (Left a)  = let (sm0', b) = f0 r0 a in (SM (sm0', sm1') f2, Left b)
+    f2 (sm0', SM r1 f1) (Right c) = let (sm1', d) = f1 r1 c in (SM (sm0', sm1') f2, Right d)
+
+faninSM :: SM a c -> SM b c -> SM (Either a b) c
+faninSM sm0 sm1 = SM (sm0, sm1) f2
+  where
+    f2 (SM r0 f0, sm1') (Left a)  = let (sm0', c) = f0 r0 a in (SM (sm0', sm1') f2, c)
+    f2 (sm0', SM r1 f1) (Right b) = let (sm1', c) = f1 r1 b in (SM (sm0', sm1') f2, c)
+
+instance ArrowChoice SM where
+  left = leftSM
+  right = rightSM
+  (+++) = sumSM
+  (|||) = faninSM
+
+-- ArrowLoop
+-- SM has build-in loop structure, but adding one more instance is harmless, :)
+
+loopSM :: SM (a, c) (b, c) -> SM a b
+loopSM sm = SM sm f1
+  where
+    f1 (SM r f) a = (SM sm' f1, b)
+      where
+        (sm', (b, c)) = f r (a, c)
+
+instance ArrowLoop SM where
+    loop = loopSM
+        
 -- Evaluation
 
 exec :: SM a b -> [a] -> (SM a b, [b])