home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / gofer230.zip / Progs / Gofer / Demos / Ccexamples / democomb.gs < prev    next >
Text File  |  1994-06-23  |  8KB  |  263 lines
  1. -- A demonstration of the use of a composition of monads to implement an
  2. -- `imperative' version of the fibonacci numbers program.
  3. --
  4. -- Original code by Luc Dupocheel, with small changes to allow the code to
  5. -- be used with the standard Gofer 2.28 cc.prelude.
  6. -- 
  7.  
  8. -- begin --------------------------------------------------------------------
  9.  
  10. infix  1 :=:, =:
  11. infixr 0 :&:, &
  12.  
  13. -- expressions --------------------------------------------------------------
  14.  
  15. type Value = Int
  16. type Name  = String
  17.  
  18. data Expression = Con Int | Var String | Expression :+: Expression
  19.  
  20. -- evaluating expressions ---------------------------------------------------
  21.  
  22. type Rom = [(Name,Value)]
  23.  
  24. expr1 :: Expression -> Read Rom Value
  25. expr1 (Con v) = result v
  26. expr1 (Var n) = lookup n
  27. expr1 (e:+:f) = [ x+y | x <- expr1 e, y <- expr1 f ]
  28.  
  29. -- evaluating expressions reused --------------------------------------------
  30.  
  31. type Ram = Int
  32.  
  33. expr2 :: Expression -> Composition (Read Rom) (State Ram) Value
  34. expr2 (Con v) =      plug (expr1 (Con v))
  35. expr2 (Var n) = join [ plug (doS (+1) v) | v <- plug (expr1 (Var n))]
  36. expr2 (e:+:f) =      [ x+y | x <- expr2 e, y <- expr2 f ]
  37.  
  38.  
  39. -- programs ------------------------------------------------------------------
  40.  
  41. data Program = Name :=: Expression | Out Expression | Program :&: Program | Forever Program
  42.  
  43. -- interpreting programs -----------------------------------------------------
  44.  
  45. type Memory = Rom
  46. type Output = [Value]
  47.  
  48. (=:) :: Name -> Value -> Memory -> Memory
  49. n =: v = ((n,v) :)
  50.  
  51. out :: Value -> Output -> Output 
  52. out v = (v :)
  53.  
  54. (&) :: () -> () -> ()
  55. () & () = ()
  56.  
  57. prg1 :: Program -> Cont (Memory -> Output) ()
  58. prg1 (n:=:e)     = join [ plug (doS (x=:v) ()) | x <- result n,
  59.                                                  v <- plug (expr1 e)]
  60. prg1 (Out e)     = join [ doC (out v) | v <- plug (expr1 e) ]
  61. prg1 (p:&:q)     =      [ u&v | u <- prg1 p , v <- prg1 q] 
  62. prg1 (Forever p) =      [ v&w | v <- prg1 p, w <- prg1 (Forever p)]
  63.   
  64. -- expressions : an example
  65.  
  66. rom :: Rom
  67. rom = [("n",3),("m",4)]
  68.  
  69. expression :: Expression
  70. expression = ((Con 1 :+: Var "n") :+: ((Var "m" :+: Con 2) :+: Var "n"))
  71.  
  72. showV :: Value -> String -> String
  73. showV v = showString "value : " . shows v . showChar '\n'
  74.  
  75. instance Text (Read Rom Value) where 
  76.     showsPrec p (Rd f) = let v = f rom in showV v . showChar '\n' 
  77.  
  78. ex1 = show (expr1 expression)
  79.  
  80. -- expressions with state : an example
  81.  
  82. ram0 :: Ram
  83. ram0 = 0
  84.  
  85. showR :: Ram -> String -> String
  86. showR r = showString "ram   : " . shows r . showChar '\n'
  87.  
  88. instance Text (Composition (Read Rom) (State Ram) Value) where 
  89.     showsPrec p (Comp f) = let (v,r) = tS (dR f rom) ram0
  90.                                in  showV v . showR r . showChar '\n'
  91.                                
  92. ex2 = show (expr2 expression)
  93.  
  94. -- programs an example --------------------------------------------------------
  95.  
  96. mem0 :: Memory
  97. mem0 = []
  98.  
  99. cont0 :: () -> Memory -> Output
  100. cont0 () mem = []
  101.  
  102. instance Text (Cont (Memory -> Output) ()) where
  103.     showsPrec p (Cnt f) = fold showV (f cont0 mem0) . showChar '\n'
  104.  
  105. output :: Name -> Program
  106. output = Out . Var
  107.  
  108. program :: Program
  109. program = "x" :=: Con 1                :&: 
  110.           "y" :=: Con 1                :&: 
  111.           output "x"                   :&:
  112.           output "y"                   :&: 
  113.           Forever (
  114.           "z" :=: Var "x" :+: Var "y"  :&:
  115.           "x" :=: Var "y"              :&:
  116.           "y" :=: Var "z"              :&: 
  117.           output "z"      
  118.           )
  119.  
  120. main :: Dialogue
  121. main = appendChan stdout fibs exit done 
  122.        where fibs = show (prg1 program)
  123.  
  124.  
  125. -- Monad morphisms, algebras and composition: --------------------------------
  126.  
  127. class (Monad m, Monad n) => MonadMorphism m n where
  128.     plug :: m a -> n a
  129.  
  130. class Monad m => Algebra m a where
  131.     bindA      :: m x -> (x -> a) -> a
  132.     applyA     :: (x -> a) -> m x -> a
  133.     (##)       :: (x -> m y) -> (y -> a) -> x -> a
  134.     joinA      :: m a -> a
  135.  
  136.     applyA      = flip bindA
  137.     g ## f      = (`bindA` f) . g
  138.     joinA       = (`bindA` id)
  139.     x `bindA` f = joinA (map f x) 
  140.  
  141. instance Monad m => Algebra m (m x) where
  142.     bindA = bind
  143.  
  144. class (Monad m, Monad n) => ComposableMonads m n where
  145.     prod  :: n (m (n x)) -> m (n x)
  146.     swap  :: n (m x) -> m (n x)
  147.  
  148.     prod   = map join . swap
  149.     swap   = prod . map (map result)
  150.  
  151. bindC :: ComposableMonads m n => n x -> (x -> m (n y)) -> m (n y)
  152. x `bindC` f = prod (map f x)
  153.  
  154. applyC :: ComposableMonads m n => (x -> m (n y)) -> n x -> m (n y)
  155. applyC = flip bindC
  156.  
  157. applyC' :: ComposableMonads m n => (n x -> m y) -> n (m x) -> m y
  158. applyC' f = apply f . swap
  159.  
  160. (**) :: ComposableMonads m n => (x -> n y) -> (y -> m (n z)) -> x -> m (n z)
  161. g ** f = (`bindC` f) . g
  162.  
  163. mapC :: ComposableMonads m n => (x -> m y) -> n x -> m (n y)
  164. mapC f  = swap . map f
  165.  
  166. -- I prefer to use 'data' instead of 'type' for Composition
  167. -- This avoids the need for restricted type synonyms 
  168. -- but it complicates things a bit (pmoC is needed ...)
  169.  
  170. data Composition m n a = Comp (m (n a))
  171.  
  172. pmoC (Comp x) = x
  173.  
  174. instance (Functor f, Functor g) => Functor (Composition f g) where
  175.     map f = Comp . (map . map) f . pmoC
  176.  
  177. instance ComposableMonads m n => Monad (Composition m n) where
  178.     result = Comp . (result . result)
  179.     join   = Comp . join . map (prod . map pmoC) . pmoC
  180.  
  181. -- this would give an overlap
  182.  
  183. --instance MonadMorphism n (Composition m n) where
  184. --    plug = Comp . result 
  185.  
  186. --instance MonadMorphism m (Composition m n) where
  187. --    plug = Comp . map result
  188.  
  189. instance (Monad (Composition m l), Monad (Composition r s),
  190.           MonadMorphism m r, MonadMorphism l s) =>
  191.          MonadMorphism (Composition m l) (Composition r s) where 
  192.     plug = Comp . map plug . plug . pmoC
  193.  
  194. mfold f = foldr (@@) result . map f
  195. fold  f = foldr (.) id      . map f
  196.  
  197. -- The read monad: -----------------------------------------------------------
  198.  
  199. data Read r x = Rd (r -> x)
  200. dR (Rd f) = f
  201.  
  202. instance Functor (Read r) where
  203.     map f (Rd g) = Rd (\r -> let x = g r in f x)
  204.  
  205. instance Monad (Read r) where
  206.     result x        = Rd (\r -> x)
  207.     (Rd g) `bind` f = Rd (\r -> let x = g r in dR (f x) r)      
  208.  
  209. lookup :: Eq b => b -> Read [(b,a)] a
  210. lookup x = Rd f where f ((y,v):bs) | x == y    = v
  211.                                    | otherwise = f bs
  212.  
  213. -- The state monad: ----------------------------------------------------------
  214.  
  215. data State s x = St (s -> (x,s))
  216. tS (St f) = f
  217.  
  218. instance Functor (State s) where
  219.     map f (St g) = St (\s -> let (x,t) = g s in (f x,t))
  220.  
  221. instance Monad (State s) where
  222.     result x        = St (\s -> (x,s))
  223.     (St g) `bind` f = St (\s -> let (x,t) = g s in tS (f x) t) 
  224.  
  225. doS       :: (s -> s) -> x -> State s x 
  226. doS f x    = St g where g s = (x, f s)  
  227.  
  228. -- The continuation monad: ---------------------------------------------------
  229.  
  230. data Cont a x = Cnt ((x -> a) -> a)
  231. tnC (Cnt f) = f
  232.  
  233. instance Functor (Cont a) where
  234.     map f (Cnt g) = Cnt (\c -> g (c . f))
  235.  
  236. instance Monad (Cont a) where
  237.     result x         = Cnt (\c -> c x)
  238.     (Cnt g) `bind` f = Cnt (\c -> g (\x -> tnC (f x) c))
  239.  
  240. doC :: (a -> a) -> Cont (s -> a) ()
  241. doC f = Cnt (\c s -> f (c () s))
  242.  
  243. instance MonadMorphism (State s) (Cont (s -> a)) where
  244.     plug (St g) = Cnt (\c s -> let (x,t) = g s in c x t)
  245.  
  246. instance MonadMorphism (Read r) (Cont (r -> a)) where
  247.     plug (Rd g) = Cnt (\c r -> let x = g r in c x r)
  248.  
  249. -- The read-state monad: -----------------------------------------------------
  250.  
  251. instance ComposableMonads (Read r) (State s) where
  252.     swap mf = Rd (\x -> [ dR m x | m <- mf ]) 
  253.  
  254. -- needed explicitly because of overlap in general case
  255.  
  256. instance MonadMorphism (State s) (Composition (Read r) (State s)) where
  257.     plug = Comp . result 
  258.  
  259. instance MonadMorphism (Read r) (Composition (Read r) (State s)) where
  260.     plug = Comp . map result
  261.  
  262. -- end -----------------------------------------------------------------------
  263.