GArrowPortShape: add detectShape
[coq-hetmet.git] / examples / CircuitExample.hs
1 {-# OPTIONS_GHC -XModalTypes -ddump-types -XNoMonoPatBinds -XMultiParamTypeClasses -XTypeOperators #-}
2 module CircuitExample
3 where
4 import GHC.HetMet.CodeTypes hiding ((-))
5 import GHC.HetMet.GArrow
6 import Control.Category
7 import Prelude hiding ( id, (.) )
8
9 --
10 -- From the Appendix of Hughes' __Programming with Arrows__
11 --
12
13 class GArrowLoop g (**) u => GArrowCircuit g (**) u b where
14   delay :: Bool -> g b b
15
16 -- GArrows which can implment LookUp Tables (LUTs)
17 class GArrow g (**) u => GArrowLUT g (**) u b where
18   lut1 :: ( Bool            -> Bool) -> g  b      b
19   lut2 :: ((Bool,Bool)      -> Bool) -> g (b,b)   b
20   lut3 :: ((Bool,Bool,Bool) -> Bool) -> g (b,b,b) b
21
22 nor = lut2 (not.uncurry (||))
23
24 flipflop = ga_loopl $ ga_second ga_swap            >>>
25                       ga_assoc                     >>>
26                       ga_second ga_unassoc         >>>
27                       ga_second (ga_first ga_swap) >>>
28                       ga_second ga_assoc           >>>
29                       ga_unassoc                   >>>
30                       ga_first  nor                >>>
31                       ga_second nor                >>>
32                       ga_first  (delay False)      >>>
33                       ga_second (delay True)       >>>
34                       ga_copy
35
36 edge = ga_copy                  >>>
37        ga_first (delay False)   >>>
38        lut2 (\(x,y) -> x && (not y))
39
40 -- halfAdd :: Arrow arr => arr (Bool,Bool) (Bool,Bool)
41 -- halfAdd = proc (x,y) -> returnA -< (x&&y, x/=y)
42
43 -- fullAdd :: Arrow arr => arr (Bool,Bool,Bool) (Bool,Bool)
44 -- fullAdd =
45 --    proc (x,y,c) -> do
46 --    (c1,s1) <- halfAdd -< (x,y)
47 --    (c2,s2) <- halfAdd -< (s1,c)
48 --    returnA -< (c1||c2,s2)