import Data.Tuple
import Text
-import ast
+import ast, scc
+
+import Text.GenPrint
+import StdDebug
check :: [Function] -> Either [String] (Expression, Scheme)
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]
--- /dev/null
+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