MuKaren in Clean

mukaren.icl

module mukaren

import StdEnv,StdMaybe,StdClass

:: Tree = Node Tree Tree | Var Int | Val Int
:: State :== ([(Int,Tree)], Int)
:: Mu :== (State -> [State])

instance == Tree
where
  (==) :: !Tree !Tree -> Bool
  (==) (Val a) (Val b) = a == b
  (==) _ _ = False

emptyState = ([] , 0)

mzero = []

unit t = [t : mzero]

extS x v s = [(x,v):s]

find u [] = Nothing
find u [(a, b):xs] = if (u == a) (Just b) (find u xs)


walk t=:(Val _) s = t
walk t=:(Var u) s = case (find u s) of
                         Nothing = t
                         Just a = walk a s
walk t _ = t

match u v (s, c) = let r = unify u v s
                   in case r of
                        Just s = unit (s, c)
                        Nothing    = mzero

unify u v s = let a = walk u s
                  b = walk v s
              in fn a b
                 where fn (Var u) t=:(Var v) = Just (if (u == v) s
                                                (extS u t s))
                       fn u (Var v) = Just (extS v u s)
                       fn (Var u) v = Just (extS u v s)
                       fn (Node ua ud) (Node va vd) = let r = (unify ua va s)
                                                      in case r of
                                                      Just s = unify ud vd s
                                                      Nothing = Nothing
                       fn a b = if (a == b) (Just s) Nothing


callEmptyState g = g emptyState

callFresh f (s , c) = f (Var c) (s , c + 1)

disj :: Mu Mu -> Mu
disj f g = \sc -> mplus (f sc) (g sc)
conj :: Mu Mu -> Mu
conj f g = \sc -> bind (f sc) g

mplus :: [State] [State] -> [State]
mplus [] b = b
mplus [x:xs] b = [x: mplus xs b]

bind :: [State] (State -> [State]) -> [State]
bind [] g = mzero
bind [x:xs] g = mplus (g x) (bind xs g)

run :: Mu -> [State]
run a = a emptyState

const x = Val x
// Example
/*
AAndB = conj (callFresh (\a -> match a (const 7)))
             (callFresh (\b -> (disj (match b (const 5)) (match b (const 6)))))

foo :: Mu
foo = callFresh (\q -> match q (End (Val 7)))
*/
// PPrinter
pp :: [State] -> String
pp [(a,_):[]] = loop a
   where loop [(var , val):[]] = pa var val
         loop [(var , val):xs] = pa var val +++ ", " +++ loop xs
         loop [] = "yes."
         pa var val = "Var" +++ toString var +++ " = "
                       +++ p val
         p (Val x) = toString x
         p (Var x) = "Var" +++ toString x
pp [x:xs] = pp [x:[]] +++ "; " +++ pp xs
pp [] = "No mutch."


Start = pp (run (match (Node (Var 1) (Var 2)) (Node (Var 2) (Var 1)) ))