home *** CD-ROM | disk | FTP | other *** search
/ The Datafile PD-CD 2 / DATAFILE_PDCD2.iso / utilities / _gofer / !Gofer / archives / Demos / Lamvar / lvexamples < prev    next >
Encoding:
Text File  |  1993-02-12  |  7.0 KB  |  245 lines
  1. --
  2. -- Examples for use with LambdaVr
  3. --
  4.  
  5. -- Simple functional version: -------------------------------------------------
  6.  
  7. data Tree a = Leaf a | Tree a :^: Tree a
  8.  
  9. label     :: Tree a -> Tree (a,Int)
  10. label tree = fst (lab tree 0)
  11.  where lab (Leaf n)  c  =  (Leaf (n,c), c+1)
  12.        lab (l :^: r) c  =  (l' :^: r', c'')
  13.                            where (l',c')  = lab l c
  14.                                  (r',c'') = lab r c'
  15.  
  16. -- Lambda var version: --------------------------------------------------------
  17.  
  18. counter = var (\cnt -> 0 =: cnt $$
  19.                        result (cnt        ? \c ->
  20.                                c+1 =: cnt $$
  21.                                result c))
  22.  
  23. label0 tree = pure (counter $= lab tree)
  24.  
  25. lab (Leaf n)  ctr = ctr                   $= \c ->
  26.                     result (Leaf (n,c))
  27. lab (l :^: r) ctr = lab l ctr             $= \l' ->
  28.                     lab r ctr             $= \r' ->
  29.                     result (l' :^: r')
  30.  
  31. {- Here is an example where pure is not safe:
  32.  
  33. label0 tree = pure (lab tree)
  34.  where ctr           = pure counter
  35.        lab (Leaf n)  = ctr                   $= \c ->
  36.                        result (Leaf (n,c))
  37.        lab (l :^: r) = lab l                 $= \l' ->
  38.                        lab r                 $= \r' ->
  39.                        result (l' :^: r')
  40.  
  41.  gives    label0 aTree = (Leaf (1,0) :^: Leaf (2,1)) :^:
  42.                          (Leaf (3,2) :^: Leaf (4,3))
  43.  
  44. whereas:
  45.  
  46. label0 tree = pure (lab tree)
  47.  where lab (Leaf n)  = pure counter          $= \c ->
  48.                        result (Leaf (n,c))
  49.        lab (l :^: r) = lab l                 $= \l' ->
  50.                        lab r                 $= \r' ->
  51.                        result (l' :^: r')
  52.  
  53.  gives    label0 aTree = (Leaf (1,0) :^: Leaf (2,0)) :^:
  54.                          (Leaf (3,0) :^: Leaf (4,0))
  55. -}
  56.  
  57. -- State monad version: -------------------------------------------------------
  58.  
  59. data State s a = ST (s -> (a,s))
  60.  
  61. instance Functor (State s) where
  62.     map f (ST st) = ST (\s -> let (x,s') = st s in (f x, s'))
  63.  
  64. instance Monad (State s) where
  65.     result x      = ST (\s -> (x,s))
  66.     ST m `bind` f = ST (\s -> let (x,s') = m s
  67.                                   ST f'  = f x
  68.                               in  f' s')
  69.  
  70. startingWith         :: State s a -> s -> a
  71. ST m `startingWith` v = fst (m v)
  72.  
  73. incr :: State Int Int
  74. incr  = ST (\s -> (s,s+1))
  75.  
  76. label1     :: Tree a -> Tree (a,Int)
  77. label1 tree = lab tree `startingWith` 0
  78.  where lab (Leaf n)  = incr                  `bind` \c ->
  79.                        result (Leaf (n,c))
  80.        lab (l :^: r) = lab l                 `bind` \l' ->
  81.                        lab r                 `bind` \r' ->
  82.                        result (l' :^: r')
  83.  
  84. label2     :: Tree a -> Tree (a,Int)
  85. label2 tree = lab tree `startingWith` 0
  86.  where lab (Leaf n)  = [ Leaf (n,c) | c <- incr ]
  87.        lab (l :^: r) = [  l :^: r   | l <- lab l, r <- lab r ]
  88.  
  89.  
  90. -- sample data: ---------------------------------------------------------------
  91.  
  92. aTree = balance [1..4]
  93.  
  94. balance ns | len == 1   =  Leaf (head ns)
  95.            | otherwise  =  balance (take h ns) :^: balance (drop h ns)
  96.              where len = length ns
  97.                    h   = len `div` 2
  98.  
  99. balance' ns = bal (length ns) ns
  100.  where bal l ns | l == 1    = Leaf (head ns)
  101.                 | otherwise = let h = l `div` 2
  102.                               in  bal h (take h ns) :^: bal (l-h) (drop h ns)
  103.  
  104. -------------------------------------------------------------------------------
  105. -- A swap function:
  106.  
  107. swap    :: Var a -> Var a -> Proc ()
  108. swap v w = v ? \x ->
  109.            w ? \y ->
  110.            x =: w $$
  111.            y =: v
  112.  
  113. valOf v = v ? result 
  114.  
  115. -- usage: swap elements of arrays a and b in the range between 1 and n
  116. --
  117. --seq [swap (a!i) (b!i) | i <- [1..n]]
  118.  
  119.  
  120. increment v = v ? \val -> val+1 =: v
  121.  
  122. anotherTest = var (\v -> 0 =: v      $$
  123.                          increment v $$
  124.                          increment v $$
  125.                          increment v $$
  126.                          increment v $$
  127.                          v           ?
  128.                          result)
  129.  
  130. swapTest = var (\v ->
  131.            var (\w ->
  132.            "I'm v" =: v $$
  133.            "I'm w" =: w $$
  134.            swap v w     $$
  135.            v            ? \vValue ->
  136.            w            ? \wValue ->
  137.            result (vValue,wValue)))
  138.  
  139.  
  140. swapTest2 = var           (\v ->
  141.             var           (\w -> 
  142.             0  =: v       $$
  143.             10 =: w       $$
  144.             v             ? \vValue ->
  145.             vValue+1 =: v $$
  146.             swap v w      $$
  147.             v             ? \vValue ->
  148.             w             ? \wValue ->
  149.             result (vValue,wValue)))
  150.             
  151. -- A queue implementation
  152.  
  153. -- First, its interface:
  154.  
  155. type Queue a = ( a -> Proc (),  -- put
  156.                  Proc a,        -- get
  157.                  Proc Bool      -- isempty
  158.                )
  159.  
  160. -- Procedures to take apart the method tuple:
  161.  
  162. put (p, g, i) = p
  163. get (p, g, i) = g
  164. isempty (p, g, i) = i
  165.  
  166. -- Now, the implementation in terms of a linked list:
  167.  
  168. data Link a = Link a (Var (Link a))
  169.  
  170. mkqueue :: Proc (Queue Int)
  171. mkqueue = 
  172.   var (\v ->
  173.   var (\front -> v =: front $$
  174.   var (\rear  -> v =: rear  $$
  175.    result
  176.     ( \x ->                             -- put x
  177.       rear ? \r -> 
  178.       var (\r' ->
  179.       Link x r' =: r $$
  180.       r' =: rear)
  181.     ,
  182.       front ? \f ->                     -- get
  183.       f ? \ (Link x f') ->
  184.       f' =: front $$
  185.       result x
  186.     ,
  187.       front ? \f ->                     -- isempty
  188.       rear ? \r ->
  189.       result (f == r)
  190.     )
  191.    )))
  192.  
  193. -- Usage:
  194.  
  195. qTest = pure (mkqueue        $= \q     ->
  196.               put q 1        $$
  197.               get q          $= \first ->
  198.               isempty q      $= \empty ->
  199.               result (if first == 1 && empty then "so should it be"
  200.                                              else "something's wrong"))
  201.  
  202. -- An alternative way to write the same thing:
  203.  
  204. mkqueue1 :: Proc (Queue Int)
  205. mkqueue1  = 
  206.   newvar     $= \v     ->
  207.   newvar     $= \front ->
  208.   v =: front $$
  209.   newvar     $= \rear  ->
  210.   v =: rear  $$
  211.   let
  212.       put x   = rear?             \r ->
  213.                 newvar         $= \r' ->
  214.                 Link x r' =: r $$
  215.                 r' =: rear
  216.  
  217.       get     = front?            \f ->
  218.                 f?                \(Link x f') ->
  219.                 f' =: front    $$
  220.                 result x
  221.  
  222.       isempty = front          ?  \f ->
  223.                 rear           ?  \r ->
  224.                 result (f==r)
  225.   in
  226.       result (put, get, isempty)
  227.  
  228. -- Usage:
  229.  
  230. qTest1 = pure (mkqueue1       $= \q     ->
  231.                put q 1        $$
  232.                get q          $= \first ->
  233.                isempty q      $= \empty ->
  234.                result (if first == 1 && empty then "so should it be"
  235.                                               else "something's wrong"))
  236.  
  237. qTest2 = mkqueue1       $= \q     ->
  238.          put q 1        $$
  239.          get q          $= \first ->
  240.          isempty q      $= \empty ->
  241.          result (if first == 1 && empty then "so should it be"
  242.                                         else "something's wrong")
  243.  
  244. -------------------------------------------------------------------------------
  245.