home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / gofer230.zip / Progs / Gofer / Demos / Ccexamples / ccexamples.gs < prev    next >
Text File  |  1994-06-23  |  16KB  |  494 lines
  1. -- ccexamples.gs                        Mark P. Jones, 1992
  2. --
  3. -- This file contains a range of examples using the system of constructor
  4. -- classes implemented in Gofer 2.28.  You will need to start Gofer running
  5. -- with the cc.prelude to use this file.
  6. --
  7.  
  8. -- Constructor class examples: ----------------------------------------------
  9.  
  10. class Functor2 f where
  11.      map2 :: (a -> b) -> (c -> d) -> (f a c -> f b d)
  12.  
  13. -- The identity monad (well nearly): ----------------------------------------
  14.  
  15. data Id a = Id a
  16.  
  17. instance Functor Id where map f (Id x)  = Id (f x)
  18. instance Monad   Id where result        = Id
  19.               join (Id x)   = x
  20.               Id x `bind` f = f x
  21.  
  22. -- The `Maybe' datatype: ----------------------------------------------------
  23.  
  24. data Maybe a = Just a | Nothing
  25.  
  26. instance Functor Maybe where
  27.     map f (Just x) = Just (f x)
  28.     map f Nothing  = Nothing
  29.  
  30. instance Monad Maybe where
  31.     result x         = Just x
  32.     Just x  `bind` f = f x
  33.     Nothing `bind` f = Nothing
  34.  
  35. instance Monad0 Maybe where
  36.     zero = Nothing
  37.  
  38. instance MonadPlus Maybe where
  39.     Nothing ++ y = y
  40.     x       ++ y = x
  41.  
  42. trap              :: Maybe a -> a -> a
  43. Just x  `trap` def = x
  44. Nothing `trap` def = def
  45.  
  46. listToMaybe      :: [a] -> Maybe a        -- a monad homomorphism
  47. listToMaybe        = concat . map result
  48.  
  49. -- Error monads --------------------------------------------------------------
  50.  
  51. class Monad m => ErrorMonad m where    -- a class of monads for describing
  52.     fail :: String -> m a        -- computations that might go wrong
  53.  
  54. data Error a = Done a | Err String    -- a variation on the maybe type
  55.  
  56. instance Functor Error where        -- which is a Functor,
  57.     map f (Done x) = Done (f x)
  58.     map f (Err s)  = Err s
  59.  
  60. instance Monad Error where        -- a Monad,
  61.     result           = Done
  62.     Done x  `bind` f = f x
  63.     Err msg `bind` f = Err msg
  64.  
  65. instance ErrorMonad Error where        -- and an ErrorMonad ...
  66.     fail = Err
  67.  
  68. -- Parser monad: ------------------------------------------------------------
  69.  
  70. type Parser token value = [token] -> [(value,[token])]
  71.  in mapP, resultP, joinP, bindP, zeroP, orP, sat, tok, toks, spaces, parse
  72.  
  73. mapP        :: (a -> b) -> Parser t a -> Parser t b
  74. mapP f p     = \s -> [ (f x, s') | (x,s') <- p s ]
  75.  
  76. resultP     :: a -> Parser t a
  77. resultP v    = \s -> [(v,s)]
  78.  
  79. joinP       :: Parser t (Parser t a) -> Parser t a
  80. joinP pp     = \s -> [ (x,s'') | (p,s') <- pp s, (x,s'') <- p s' ]
  81.  
  82. bindP       :: Parser t a -> (a -> Parser t b) -> Parser t b
  83. p `bindP` f  = \s -> [ (a',s'') | (a,s') <- p s, (a',s'') <- f a s' ]
  84.  
  85. zeroP       :: Parser t a
  86. zeroP        = \s -> []
  87.  
  88. orP         :: Parser t a -> Parser t a -> Parser t a
  89. p `orP` q    = \s -> p s ++ q s
  90.  
  91. sat         :: (t -> Bool) -> Parser t t
  92. sat p []     = []
  93. sat p (h:ts) = [ (h,ts) | p h ]
  94.  
  95. tok        :: Eq t => t -> Parser t t
  96. tok t        = sat (t==)
  97.  
  98. toks        :: Eq [t] => [t] -> Parser t ()
  99. toks w       = \ts -> [ ((),drop n ts) | w == take n ts ]
  100.            where n = length w
  101.  
  102. spaces        :: Parser Char a -> Parser Char a
  103. spaces p     = p . dropWhile isSpace
  104.  
  105. parse       :: Parser t a -> [t] -> Maybe a
  106. parse p ts   = listToMaybe [ x | (x,[]) <- p ts ]
  107.  
  108. instance Functor   (Parser t) where map    = mapP
  109. instance Monad     (Parser t) where result = resultP
  110.                     bind   = bindP
  111.                     join   = joinP
  112. instance Monad0    (Parser t) where zero   = zeroP
  113. instance MonadPlus (Parser t) where (++)   = orP
  114.  
  115. -- Continuation monad: ------------------------------------------------------
  116.  
  117. type Cont r a = (a -> r) -> r
  118.   in mapC, resultC, joinC, bindC, callcc
  119.  
  120. mapC       :: (a -> b) -> Cont r a -> Cont r b
  121. mapC f m    = \k -> m (k . f)
  122.  
  123. resultC    :: a -> Cont r a
  124. resultC x   = \k -> k x
  125.  
  126. joinC      :: Cont r (Cont r a) -> Cont r a
  127. joinC m     = \k -> m (\x -> x k)
  128.  
  129. bindC      :: Cont r a -> (a -> Cont r b) -> Cont r b
  130. m `bindC` f = \k -> m (\y -> (f y) k)
  131.  
  132. callcc     :: ((a -> Cont r b) -> Cont r a) -> Cont r a
  133. callcc g    = \k -> g (\x k' -> k x) k
  134.  
  135. instance Functor (Cont r) where map    = mapC
  136.  
  137. instance Monad   (Cont r) where result = resultC
  138.                 bind   = bindC
  139.                 join   = joinC
  140.  
  141. -- State monads: ------------------------------------------------------------
  142.  
  143. class Monad (m s) => StateMonad m s where
  144.     update :: (s -> s) -> m s s        -- the principal characteristic of a
  145.     set    :: s -> m s s        -- state based compuation is that you
  146.     fetch  :: m s s            -- can update the state!
  147.     set new = update (\old -> new)
  148.     fetch   = update id
  149.  
  150. incr :: StateMonad m Int => m Int Int
  151. incr  = update (1+)
  152.  
  153. random  :: StateMonad m Int => Int -> m Int Int
  154. random n = update min_stand_test `bind` \m ->
  155.            result (m `mod` n)
  156.  
  157. min_stand_test  :: Int -> Int       -- see demos/minsrand.gs for explanation
  158. min_stand_test n = if test > 0 then test else test + 2147483647
  159.            where test = 16807 * lo - 2836 * hi
  160.                  hi   = n `div` 127773
  161.                  lo   = n `rem` 127773
  162.  
  163. data State s a = ST (s -> (a,s))    -- The standard example: state
  164.                     -- transformers (not used in the rest
  165.                     -- of this program).
  166. instance Functor (State s) where
  167.     map f (ST st) = ST (\s -> let (x,s') = st s in (f x, s'))
  168.  
  169. instance Monad (State s) where
  170.     result x      = ST (\s -> (x,s))
  171.     ST m `bind` f = ST (\s -> let (x,s') = m s
  172.                                   ST f'  = f x
  173.                               in  f' s')
  174.  
  175. instance StateMonad State s where
  176.     update f = ST (\s -> (s, f s))
  177.  
  178. ST m `startingWith` s0 = result where (result,_) = m s0
  179.  
  180. data STM m s a = STM (s -> m (a,s))    -- a more sophisticated example,
  181.                     -- where the state monad is
  182.                     -- parameterised by a second,
  183.                     -- arbitrary monad.
  184.  
  185. instance Monad m => Functor (STM m s) where
  186.     map f (STM xs) = STM (\s -> [ (f x, s') | ~(x,s') <- xs s ])
  187.  
  188. instance Monad m => Monad (STM m s) where
  189.     result x        = STM (\s -> result (x,s))
  190.     join (STM xss)  = STM (\s -> [ (x,s'') | ~(STM xs, s') <- xss s,
  191.                                              ~(x,s'') <- xs s' ])
  192.     STM xs `bind` f = STM (\s -> xs s `bind` (\(x,s') ->
  193.                                  let STM f' = f x
  194.                                  in  f' s'))
  195.  
  196. instance ErrorMonad m => ErrorMonad (STM m s) where
  197.     fail msg = STM (\s -> fail msg)
  198.  
  199. instance StateMonad (STM m) s where
  200.     update f = STM (\s -> result (s, f s))
  201.  
  202. protect          :: Monad m => m a -> STM m s a
  203. protect m         = STM (\s -> [ (x,s) | x<-m ])
  204.  
  205. execute          :: Monad m => s -> STM m s a -> m a
  206. execute s (STM f) = [ x | ~(x,s') <- f s ]
  207.  
  208. -- Reader monad: ------------------------------------------------------------
  209. -- I imagine there must be some deep philosophical reason why the following
  210. -- functions turn out to be very well-known combinators?
  211. -----------------------------------------------------------------------------
  212.  
  213. type Reader r a = r -> a
  214.   in mapR, resultR, bindR, joinR, read, readOnly
  215.  
  216. mapR       :: (a -> b) -> (Reader r a -> Reader r b)
  217. mapR f m    = f . m                        -- B
  218.  
  219. resultR    :: a -> Reader r a
  220. resultR x   = \r -> x                        -- K
  221.  
  222. joinR      :: Reader r (Reader r a) -> Reader r a
  223. joinR mm    = \r -> mm r r                    -- W?
  224.  
  225. bindR      :: Reader r a -> (a -> Reader r b) -> Reader r b
  226. x `bindR` f = \r -> f (x r) r                    -- S
  227.  
  228. read       :: Reader r r
  229. read r      = r
  230.  
  231. readOnly   :: Reader s a -> State s a
  232. readOnly m  = ST (\s -> (m s, s))
  233.  
  234. instance Functor (Reader r) where map    = mapR
  235.  
  236. instance Monad   (Reader r) where result = resultR
  237.                   bind   = bindR
  238.                   join   = joinR
  239.  
  240. -- Output monad: ------------------------------------------------------------
  241.  
  242. type Output a = (a, ShowS)
  243.   in mapO, resultO, bindO, joinO, write
  244.  
  245. mapO          :: (a -> b) -> Output a -> Output b
  246. mapO f (x, ss)       = (f x, ss)
  247.  
  248. resultO          :: a -> Output a
  249. resultO x       = (x, id)
  250.  
  251. bindO          :: Output a -> (a -> Output b) -> Output b
  252. (a, ss) `bindO` f  = let (b, ss') = f a in (b, ss . ss')
  253.  
  254. joinO             :: Output (Output a) -> Output a
  255. joinO ((m,ss'),ss) = (m, ss . ss')
  256.  
  257. write             :: String -> Output ()
  258. write msg          = ((), (++) msg)
  259.  
  260. instance Functor Output where map    = mapO
  261.  
  262. instance Monad   Output where result = resultO
  263.                   bind   = bindO
  264.                   join   = joinO
  265.  
  266. -- Association lists ---------------------------------------------------------
  267.  
  268. type Assoc v t = [(v,t)] in mapAssoc, noAssoc, extend, lookup
  269.  
  270. instance Functor (Assoc v) where map = mapAssoc
  271.  
  272. mapAssoc      :: (a -> b) -> (Assoc v a -> Assoc v b)
  273. mapAssoc f vts = [ (v, f t) | (v,t) <- vts ]
  274.  
  275. noAssoc       :: Assoc v t
  276. noAssoc        = []
  277.  
  278. extend        :: v -> t -> Assoc v t -> Assoc v t
  279. extend v t a   = [(v,t)] ++ a
  280.  
  281. lookup        :: (Eq v, ErrorMonad m) => v -> Assoc v t -> m t
  282. lookup v       = foldr find (fail "Undefined value")
  283.                  where find (w,t) alt | w==v      = result t
  284.                                       | otherwise = alt
  285.  
  286. -- Types: -------------------------------------------------------------------
  287.  
  288. data Type v = TVar v            -- Type variable
  289.             | Fun (Type v) (Type v)    -- Function type
  290.  
  291. instance Text v => Text (Type v) where
  292.     showsPrec p (TVar v)          = shows v
  293.     showsPrec p (Fun (TVar v) r)  = shows v . showString " -> " . shows r
  294.     showsPrec p (Fun l r)         = showChar '(' . shows l . showChar ')'
  295.                                     . showString " -> "
  296.                                     . shows r
  297.  
  298. instance Functor Type where  map f (TVar v)   = TVar (f v)
  299.                              map f (Fun d r)  = Fun (map f d) (map f r)
  300. instance Monad   Type where  result v         = TVar v
  301.                              TVar v  `bind` f = f v
  302.                              Fun d r `bind` f = Fun (d `bind` f) (r `bind` f)
  303.  
  304. vars           :: Type v -> [v]
  305. vars (TVar v)   = [v]
  306. vars (Fun d r)  = vars d ++ vars r
  307.  
  308. -- Substitutions: -----------------------------------------------------------
  309.  
  310. type Subst m v = v -> m v
  311.  
  312. nullSubst  :: Monad m => Subst m v
  313. nullSubst   = result
  314.  
  315. (>>)       :: (Eq v, Monad m) => v -> m v -> Subst m v
  316. (v >> t) w  = if v==w then t else result w
  317.  
  318. varBind v t = if (v `elem` vars t) then fail "unification fails"
  319.                    else result (v>>t)
  320.  
  321. unify (TVar v)  (TVar w)
  322.               | v==w      = result nullSubst
  323.               | otherwise = result (v>>TVar w)
  324. unify (TVar v)  t         = varBind v t
  325. unify t         (TVar v)  = varBind v t
  326. unify (Fun d r) (Fun e s) = [ s2 @@ s1 | s1 <- unify d e,
  327.                      s2 <- unify (apply s1 r)
  328.                              (apply s1 s) ]
  329.  
  330. -- Terms: --------------------------------------------------------------------
  331.  
  332. data Term v = Var v                   -- variable
  333.             | Ap  (Term v) (Term v)   -- application
  334.             | Lam v (Term v)          -- lambda abstraction
  335.  
  336. examples = [ lamx x,                -- identity
  337.              k,                    -- k
  338.              s,                    -- s
  339.              lamx (lamy (lamz (Ap x (Ap y z)))),-- b
  340.              lamx (Ap x x),            -- \x. x x
  341.          Ap (Ap s k) k,            -- s k k
  342.              Ap (Ap s (Ap k s)) k,        -- s (k s) k
  343.              x                    -- unbound x
  344.            ]
  345.            where s    = lamx (lamy (lamz (Ap (Ap x z) (Ap y z))))
  346.                  k    = lamx (lamy x)
  347.                  x    = Var "x"
  348.                  y    = Var "y"
  349.                  z    = Var "z"
  350.                  lamx = Lam "x"
  351.                  lamy = Lam "y"
  352.                  lamz = Lam "z"
  353.  
  354. -- Type inference: -----------------------------------------------------------
  355.  
  356. type Infer a = STM Error Int a
  357. type Expr    = Term String
  358. type Assume  = Assoc String (Type Int)
  359.  
  360. infer            :: Assume -> Expr -> Infer (Subst Type Int, Type Int)
  361. infer a (Var v)   = lookup v a                           `bind` \t      ->
  362.                     result (nullSubst,t)
  363. infer a (Lam v e) = newVar                               `bind` \b      ->
  364.                     infer (extend v (TVar b) a) e        `bind` \(s,t)  ->
  365.                     result (s, s b `Fun` t)
  366. infer a (Ap l r)  = infer a l                            `bind` \(s,lt) ->
  367.                     infer (map (apply s) a) r            `bind` \(t,rt) ->
  368.                     newVar                               `bind` \b      ->
  369.                     unify (apply t lt) (rt `Fun` TVar b) `bind` \u      ->
  370.                     result (u @@ t @@ s, u b)
  371.  
  372. newVar :: Infer Int
  373. newVar  = incr
  374.  
  375. try    = layn (map (show' . typeOf) examples)
  376.  
  377. typeOf = map (show.snd) . execute 0 . infer noAssoc
  378.  
  379. -- Now for something rather different: Trees: -------------------------------
  380.  
  381. class Functor t => TreeCon t where     -- tree constructors
  382.     branches :: t a -> [t a]
  383.  
  384. -- standard calculations involving trees
  385.  
  386. depth :: TreeCon t => t a -> Int
  387. depth  = (1+) . foldl max 0 . map depth . branches
  388.  
  389. dfs   :: TreeCon t => t a -> [t a]
  390. dfs t  = t : concat (map dfs (branches t))
  391.  
  392. bfs   :: TreeCon t => t a -> [t a]
  393. bfs    = concat . lev
  394.  where lev t = [t] : foldr cat [] (map lev (branches t))
  395.        cat   = longzw (++)
  396.  
  397. longzw f (x:xs) (y:ys) = f x y : longzw f xs ys
  398. longzw f []     ys     = ys
  399. longzw f xs     []     = xs
  400.  
  401. paths t | null br   = [ [t] ]
  402.         | otherwise = [ t:p | b<-br, p<-paths b ]
  403.           where br = branches t
  404.  
  405. -- now here are a variety of trees, all of which are instances of
  406. -- the TreeCon class above:
  407.  
  408. data Tree a  =  Leaf a  |  Tree a :^: Tree a
  409.  
  410. instance Functor Tree where        -- `context free relabeling'
  411.     map f (Leaf a)  = Leaf (f a)
  412.     map f (l :^: r) = map f l :^: map f r
  413.  
  414. instance Monad Tree where        -- `substitution'
  415.     result             = Leaf
  416.     Leaf x    `bind` f = f x
  417.     (l :^: r) `bind` f = (l `bind` f) :^: (r `bind` f)
  418.  
  419. instance TreeCon Tree where        -- the tree structure
  420.     branches (Leaf n)  = []
  421.     branches (l :^: r) = [l,r]
  422.  
  423. data LabTree l a  =  Tip a  |  LFork l (LabTree l a) (LabTree l a)
  424.  
  425. instance Functor (LabTree l) where
  426.     map f (Tip x)       = Tip (f x)
  427.     map f (LFork x l r) = LFork x (map f l) (map f r)
  428.  
  429. instance Monad (LabTree l) where
  430.     result               = Tip
  431.     Tip x       `bind` f = f x
  432.     LFork x l r `bind` f = LFork x (l `bind` f) (r `bind` f)
  433.  
  434. instance TreeCon (LabTree l) where
  435.    branches (Tip x)       = []
  436.    branches (LFork x l r) = [l,r]
  437.  
  438. data STree a  =  Empty  | Split a (STree a) (STree a)
  439.  
  440. instance Functor STree where
  441.     map f Empty         = Empty
  442.     map f (Split x l r) = Split (f x) (map f l) (map f r)
  443.  
  444. instance TreeCon STree where
  445.     branches Empty         = []
  446.     branches (Split x l r) = [l,r]
  447.  
  448. data GenTree a =  Node a [GenTree a]
  449.  
  450. instance Functor GenTree where
  451.     map f (Node x gts) = Node (f x) (map (map f) gts)
  452.  
  453. instance TreeCon GenTree where
  454.     branches (Node x gts) = gts
  455.  
  456. -- The tree labeling program: -----------------------------------------------
  457.  
  458. label     :: Tree a -> Tree (a,Int)        -- error prone explicit
  459. label tree = fst (lab tree 0)            -- counters
  460.  where lab (Leaf n)  c  =  (Leaf (n,c), c+1)
  461.        lab (l :^: r) c  =  (l' :^: r', c'')
  462.                            where (l',c')  = lab l c
  463.                                  (r',c'') = lab r c'
  464.  
  465. label1     :: Tree a -> Tree (a,Int)        -- monad version
  466. label1 tree = lab tree `startingWith` 0
  467.  where lab (Leaf n)  = incr                  `bind` \c ->
  468.                        result (Leaf (n,c))
  469.        lab (l :^: r) = lab l                 `bind` \l' ->
  470.                        lab r                 `bind` \r' ->
  471.                        result (l' :^: r')
  472.  
  473. label2     :: Tree a -> Tree (a,Int)        -- using monad comprehensions
  474. label2 tree = lab tree `startingWith` 0
  475.  where lab (Leaf n)  = [ Leaf (n,c) | c <- incr ]
  476.        lab (l :^: r) = [  l :^: r   | l <- lab l, r <- lab r ]
  477.  
  478. -- A `while loop' for an arbitrary monad: -----------------------------------
  479.  
  480. while    :: Monad m => m Bool -> m b -> m ()
  481. while c s = c  `bind` \b ->
  482.             if b then s         `bind` \x ->
  483.                       while c s
  484.                  else result ()
  485.  
  486. skip :: Monad m => m ()
  487. skip  = result ()
  488.  
  489. loop  = while isDot skip
  490.  
  491. isDot = [ True | x <- sat ('.'==) ]
  492.  
  493. -- End of program -----------------------------------------------------------
  494.