hunk ./Main.hs 1
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}
hunk ./Main.hs 31
-    writeFile (file ++ ".dot") $ toDot prg
-    system $ "\"C:\\Program Files\\Graphviz2.22\\bin\\dot.exe\" -Tpng " ++ file ++ ".dot -o" ++ file ++ ".png"
+    writeFile (file ++ ".gv") $ toDot prg
+    system $ "\"C:\\Program Files\\Graphviz2.22\\bin\\dot.exe\" -Tpng " ++ file ++ ".gv -o" ++ file ++ ".png"
hunk ./Main.hs 47
-    | Push Ptr [(Ptr, Ptr)]
+    | Push Ptr [(Ptr, Ptr)] -- Invariant: fst of the second component must all point at Var
hunk ./Main.hs 55
+
+(+=) :: (Ptr,Exp) -> [(Ptr,Exp)] -> [(Ptr,Exp)]
+lhs += rhs = [lhs] ++= rhs
+
+-- | Join the bindings so the ones on the left take preference
+(++=) :: [(Ptr,Exp)] -> [(Ptr,Exp)] -> [(Ptr,Exp)]
+lhs ++= rhs = lhs ++ filter (flip notElem (map fst lhs) . fst) rhs
+
+-- | Join two sets of Push nodes, apply the left one first, then the right one
+(+->) :: [(Ptr,Ptr)] -> [(Ptr,Ptr)] -> [(Ptr,Ptr)]
+lhs +-> rhs = [(ask lhs $ ask rhs x, x) | x <- nub $ map snd lhs ++ map snd rhs]
+    where ask s x = fromMaybe x $ rlookup x s
+
+
hunk ./Main.hs 136
-toDot (Prog _ bind x) = unlines $ ["digraph g {","start -> " ++ show x ++ ";"] ++ map f bind ++ ["}"]
+toDot (Prog _ bind x) = unlines $ ["digraph g {","node[fontname=Sans];","start -> " ++ show x ++ ";"] ++ map f bind ++ ["}"]
hunk ./Main.hs 142
-        f (p, Push a bs) = show p ++ "[shape=box label=\"\"];_" ++ show p ++ "[label=\"\"];" ++
+        f (p, Push a bs) = show p ++ "[shape=box label=\"\"];_" ++ show p ++ "[shape=point label=\"\"];" ++
hunk ./Main.hs 183
-    App a b | Lam c d <- lookup_ a bind -> Just $ Prog u ((p,Push d [(c,b)]) : remove p bind) p
-            | Just (Prog u2 bind2 p2) <- step $ Prog u bind a -> Just $ Prog u2 ((p,App p2 b) : remove p bind2) p
-    Case a b | Con c d <- lookup_ a bind, (_,ps,bod):_ <- filter ((==) c . fst3) b -> Nothing
-             | Just (Prog u2 bind2 p2) <- step $ Prog u bind a -> Just $ Prog u2 ((p,Case p2 b) : remove p bind2) p
+    App a b | Lam c d <- lookup_ a bind -> Just $ Prog u ((p,Push d [(c,b)]) += bind) p
+            | Just (Prog u2 bind2 p2) <- step $ Prog u bind a -> Just $ Prog u2 ((p,App p2 b) += bind2) p
+    Case a b | Con c d <- lookup_ a bind, (_,ps,bod):_ <- filter ((==) c . fst3) b, length ps == length d -> Just $ Prog u ((p,Push bod (zip ps d)) += bind) p
+             | Just (Prog u2 bind2 p2) <- step $ Prog u bind a -> Just $ Prog u2 ((p,Case p2 b) += bind2) p
hunk ./Main.hs 215
-simplify x = applyLambda $ emptyPush $ dullPush $ applyLambda $ applyLambda $ applyLambda $ applyLambda $ applyLambda $ emptyPush $ emptyPush x
+simplify x = applyCtor $ applyCtor $ applyLambda $ emptyPush $ dullPush $ applyLambda $ applyLambda $ applyLambda $ applyLambda $ applyLambda $ emptyPush $ emptyPush x
hunk ./Main.hs 229
-applyLambda (Prog u bind start) = Prog u (env ++ removes (map fst env) bind) start
-    where env = [(p,Push d [(c,b)]) | (p,App a b) <- bind, Lam c d <- [lookup_ a bind]]
+applyLambda (Prog u bind start) = Prog u ((env1 ++ env2) ++= bind) start
+    where env1 = [(p,Push d [(c,b)]) | (p,App a b) <- bind, Lam c d <- [lookup_ a bind]]
+          env2 = [(p,Push f (ds +-> [(e,b)])) | (p,App a b) <- bind, Push c ds <- [lookup_ a bind], Lam e f <- [lookup_ c bind]]
+
+
+applyCtor :: Prog -> Prog
+applyCtor (Prog u bind start) = Prog u (env ++= bind) start
+    where env = [(p,Con c (d++[b])) | (p,App a b) <- bind, Con c d <- [lookup_ a bind]]
hunk ./Main.hs 248
-
-remove x ys = filter ((/=) x . fst) ys
-removes xs ys = filter (flip notElem xs . fst) ys
-
hunk ./Main.hs 249
+swap (x,y) = (y,x)
+rlookup x y = lookup x $ map swap y