scc analysis

diff --git a/check.icl b/check.icl
index a2bc85a..43d2b30 100644 (file)
--- a/check.icl
+++ b/check.icl
@@ -7,7 +7,6 @@ import Control.Monad.State
 import Control.Monad.Trans
 import Data.Either
 import Data.Func
-import Data.Graph
 import Data.List
 import Data.Map => qualified put, union, difference, find, updateAt
 import Data.Maybe
@@ -27,31 +26,70 @@ check fs
                        = pure (makeExpression fs e, undef)
                ([Function _ _ _], _) = Left ["Start cannot have arguments"]
 
+
+:: Node a :== (a, [a])
+:: SCCState a =
+       { index :: Int
+       , stack :: [a]
+       , map   :: Map a (Int, Int, Bool)
+       , sccs  :: [[a]]
+       }
+
+import StdDebug
+import Text.GenPrint
+scc :: [Node a] -> [[a]] | Eq, Ord a
+scc nodes = (foldr scc` {index=0,stack=[],map=newMap,sccs=[]} nodes).sccs
+where
+//     scc` :: (Node a) (SCCState a) -> SCCState a | Eq, Ord a
+       scc` (v, suc) s = maybe (strongconnect s (v, suc)) (\_->s) $ get v s.map
+
+//     strongconnect :: (SCCState a) (Node a)-> SCCState a | Eq, Ord a
+       strongconnect s (v, suc)
+               # s = flip (foldr processSucc) suc
+                       { s
+                       & map   = 'Data.Map'.put v (s.index, s.index, True) s.map
+                       , stack = [v:s.stack]
+                       , index = s.index + 1
+                       }
+               # (Just (iv, lv, lo)) = get v s.map
+               | iv == lv
+                       # (scc, [sl:stack]) = span ((<>) v) s.stack
+                       # scc = scc ++ [sl]
+                       = { s
+                         & sccs = [scc:s.sccs]
+                         , stack= stack
+                         , map  = foldr (\w m->'Data.Map'.put w (appThd3 (\_->False) $ fromJust (get w m)) m) s.map scc
+                         }
+               = s
+       where
+//             processSucc :: a (SCCState a) -> SCCState a | Eq, Ord a
+               processSucc w s = case get w s.map of
+                       Nothing
+                               # s = strongconnect s $ hd [l\\l=:(n, _)<-nodes | n == w]
+                               # (Just (iw, lw, ow)) = get w s.map
+                               # (Just (iv, lv, ov)) = get v s.map
+                               = {s & map='Data.Map'.put v (iv, min lv lw, ov) s.map}
+                       Just (iw, lw, True)
+                               # (Just (iv, lv, ov)) = get v s.map
+                               = {s & map='Data.Map'.put v (iv, min iw lv, ov) s.map}
+                       Just _ = s
+
 makeExpression :: [Function] Expression -> Expression
 makeExpression fs start
-       # (indices, graph) = foldr mkNode (newMap, emptyGraph) fs
-       = foldr mkExpr start $ scc $ foldr (mkEdges indices) graph fs
+       = mkExpr $ scc [(l, vars e [])\\(l, e)<-nicefuns]
 where
-       mkNode :: Function (Map [Char] NodeIndex, Graph Function ()) -> (Map [Char] NodeIndex, Graph Function ())
-       mkNode f=:(Function l _ _) (m, g)
-               # (i, g) = addNode f g
-               = ('Data.Map'.put l i m, g)
-
-       mkEdges :: (Map [Char] NodeIndex) Function (Graph Function ()) -> Graph Function ()
-       mkEdges m (Function l i e) g
-               # ni = fromJust (get l m)
-               = foldr (addEdge ()) g [(ni, v)\\(Just v)<-map (flip get m) $ vars e []]
+       mkExpr :: [[[Char]]] -> Expression
+       mkExpr t = trace_n (printToString t) start
+       nicefuns = [(l, foldr ((o) o Lambda) id i e)\\(Function l i e)<-fs]
 
        vars :: Expression [[Char]] -> [[Char]]
-       vars (Var v) c = [v:c]
+       vars (Var v=:[m:_]) c
+               | m <> '_' = [v:c]
        vars (App l r) c = vars l $ vars r c
        vars (Lambda l e) c = [v\\v<-vars e c | v <> l]
        vars (Let ns e) c = vars e c // TODO
        vars _ c = c
 
-       mkExpr :: (Graph Function ()) Expression -> Expression
-       mkExpr {nodes} e = Let [(l, foldr ((o) o Lambda) id i e)\\{data=(Function l i e)}<-elems nodes] e
-
 instance toString Scheme where
        toString (Forall [] t) = toString t
        toString (Forall as t) = concat ["A.", join " " (map toString as), ": ", toString t]