1 {-# OPTIONS_GHC -XModalTypes -ddump-types -XNoMonoPatBinds -XMultiParamTypeClasses -XTypeOperators #-}
4 import GHC.HetMet.CodeTypes hiding ((-))
5 import GHC.HetMet.GArrow
6 import Control.Category
7 import Prelude hiding ( id, (.) )
10 -- From the Appendix of Hughes' __Programming with Arrows__
13 class GArrowLoop g (**) u => GArrowCircuit g (**) u b where
14 delay :: Bool -> g b b
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
22 nor = lut2 (not.uncurry (||))
24 flipflop = ga_loopl $ ga_second ga_swap >>>
26 ga_second ga_unassoc >>>
27 ga_second (ga_first ga_swap) >>>
28 ga_second ga_assoc >>>
32 ga_first (delay False) >>>
33 ga_second (delay True) >>>
37 ga_first (delay False) >>>
38 lut2 (\(x,y) -> x && (not y))
40 -- halfAdd :: Arrow arr => arr (Bool,Bool) (Bool,Bool)
41 -- halfAdd = proc (x,y) -> returnA -< (x&&y, x/=y)
43 -- fullAdd :: Arrow arr => arr (Bool,Bool,Bool) (Bool,Bool)
46 -- (c1,s1) <- halfAdd -< (x,y)
47 -- (c2,s2) <- halfAdd -< (s1,c)
48 -- returnA -< (c1||c2,s2)