From: Mart Lubbers <mart@martlubbers.net>
Date: Mon, 18 Mar 2019 13:20:20 +0000 (+0100)
Subject: separate
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=6a9b8df8dae656339ab97fa0a13032b6919e55f5;p=minfp.git

separate
---

diff --git a/check.icl b/check.icl
index 43d2b30..2bef9ed 100644
--- a/check.icl
+++ b/check.icl
@@ -13,7 +13,10 @@ import Data.Maybe
 import Data.Tuple
 import Text
 
-import ast
+import ast, scc
+
+import Text.GenPrint
+import StdDebug
 
 check :: [Function] -> Either [String] (Expression, Scheme)
 check fs
@@ -26,54 +29,6 @@ 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
 	= mkExpr $ scc [(l, vars e [])\\(l, e)<-nicefuns]
diff --git a/scc.dcl b/scc.dcl
new file mode 100644
index 0000000..aa59b37
--- /dev/null
+++ b/scc.dcl
@@ -0,0 +1,6 @@
+definition module scc
+
+from StdOverloaded import class <, class ==
+from StdClass import class Ord, class Eq
+
+scc :: [(a, [a])] -> [[a]] | Eq, Ord a
diff --git a/scc.icl b/scc.icl
new file mode 100644
index 0000000..7803f8b
--- /dev/null
+++ b/scc.icl
@@ -0,0 +1,40 @@
+implementation module scc
+
+import StdEnv, StdMaybe
+import Data.Map => qualified updateAt
+
+:: St a = {nextindex :: Int, stack :: [a], map :: Map a Annot, sccs :: [[a]]}
+:: Annot = {index :: Int, lowlink :: Int, onstack :: Bool}
+
+scc :: [(a, [a])] -> [[a]] | Eq, Ord a
+scc nodes = (foldr strongconnect {nextindex=0,stack=[],map=newMap,sccs=[]} nodes).sccs
+where
+//	strongconnect :: (a, [a]) (St a) -> St a | Eq, Ord a
+	strongconnect (v, suc) s
+		| isJust (get v s.map) = s
+		# s = foldr processSucc
+			{ s & map   = put v {index=s.nextindex, lowlink=s.nextindex, onstack=True} s.map
+			, stack     = [v:s.stack]
+			, nextindex = s.nextindex + 1
+			} suc
+		# (Just a) = get v s.map
+		| a.index == a.lowlink
+			# (scc, [sl:stack]) = span ((<>) v) s.stack
+			# scc = scc ++ [sl]
+			= { s & sccs = [scc:s.sccs]
+			  , stack= stack
+			  , map  = foldr (alter \(Just s)->Just {s & onstack=False}) s.map scc
+			  }
+		= s
+	where
+//		processSucc :: a (St a) -> St a | Eq, Ord a
+		processSucc w s = case get w s.map of
+			Nothing
+				# s = strongconnect (hd [l\\l=:(n, _)<-nodes | n == w]) s
+				# (Just aw) = get w s.map
+				# (Just av) = get v s.map
+				= {s & map=put v {av & lowlink=min av.lowlink aw.lowlink} s.map}
+			Just aw=:{onstack=True}
+				# (Just av) = get v s.map
+				= {s & map=put v {av & lowlink=min aw.index av.lowlink} s.map}
+			Just _ = s