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)