--- /dev/null
+{-# OPTIONS_GHC -XModalTypes -ddump-types -XNoMonoPatBinds -XMultiParamTypeClasses -XTypeOperators #-}
+module CircuitExample
+where
+import GHC.HetMet.CodeTypes hiding ((-))
+import GHC.HetMet.GArrow
+import Control.Category
+import Prelude hiding ( id, (.) )
+
+--
+-- From the Appendix of Hughes' __Programming with Arrows__
+--
+
+class GArrowLoop g (**) u => GArrowCircuit g (**) u b where
+ delay :: Bool -> g b b
+
+-- GArrows which can implment LookUp Tables (LUTs)
+class GArrow g (**) u => GArrowLUT g (**) u b where
+ lut1 :: ( Bool -> Bool) -> g b b
+ lut2 :: ((Bool,Bool) -> Bool) -> g (b,b) b
+ lut3 :: ((Bool,Bool,Bool) -> Bool) -> g (b,b,b) b
+
+nor = lut2 (not.uncurry (||))
+
+flipflop = ga_loopl $ ga_second ga_swap >>>
+ ga_assoc >>>
+ ga_second ga_unassoc >>>
+ ga_second (ga_first ga_swap) >>>
+ ga_second ga_assoc >>>
+ ga_unassoc >>>
+ ga_first nor >>>
+ ga_second nor >>>
+ ga_first (delay False) >>>
+ ga_second (delay True) >>>
+ ga_copy
+
+edge = ga_copy >>>
+ ga_first (delay False) >>>
+ lut2 (\(x,y) -> x && (not y))
+
+-- halfAdd :: Arrow arr => arr (Bool,Bool) (Bool,Bool)
+-- halfAdd = proc (x,y) -> returnA -< (x&&y, x/=y)
+
+-- fullAdd :: Arrow arr => arr (Bool,Bool,Bool) (Bool,Bool)
+-- fullAdd =
+-- proc (x,y,c) -> do
+-- (c1,s1) <- halfAdd -< (x,y)
+-- (c2,s2) <- halfAdd -< (s1,c)
+-- returnA -< (c1||c2,s2)