From 9e2ec70969d3bbbe8b90e2dc8b5663f16e87530f Mon Sep 17 00:00:00 2001
From: Mart Lubbers <mart@martlubbers.net>
Date: Mon, 18 Mar 2019 13:39:22 +0100
Subject: [PATCH] scc analysis

---
 check.icl | 70 ++++++++++++++++++++++++++++++++++++++++++-------------
 1 file changed, 54 insertions(+), 16 deletions(-)

diff --git a/check.icl b/check.icl
index a2bc85a..43d2b30 100644
--- 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]
-- 
2.20.1