1 files changed, 243 insertions, 0 deletions
diff --git a/sucl/basic.icl b/sucl/basic.icl
new file mode 100644
index 0000000..f1ffb70
--- /dev/null
+++ b/sucl/basic.icl
@@ -0,0 +1,243 @@
+implementation module basic
+
+/*
+
+Basic definitions
+=================
+
+Description
+-----------
+
+Basic types and functions.
+
+*/
+
+import StdEnv
+
+/*
+
+Implementation
+--------------
+
+*/
+
+:: Optional t = Absent | Present t
+
+
+// Adjust a function for a single argument
+
+adjust :: !arg res (arg->res) !arg -> res | == arg
+adjust a r f x
+    | x==a = r
+           = f x
+
+
+// Claim a list of nodes from a heap
+claim :: ![.param] u:[.cell] -> ([.cell],v:[.cell]), [u<=v]
+
+claim [] heap = ([],heap)
+claim [pnode:pnodes] [snode:heap]
+=   ([snode:snodes],heap`)
+    where (snodes,heap`) = claim pnodes heap
+claim pnodes emptyheap = abort "claim: out of heap" // Just in case. Should be used with an infinite heap.
+
+/* Depthfirst collects results of a function (called process), applied to a
+given  list  of  inputs  and  other  inputs which are generated from the
+results recursively, and so on.  Duplicates are removed. */
+
+depthfirst :: (res->.[elem]) (elem->res) !.[elem] -> .[res] | == elem
+depthfirst generate process xs
+=   snd (collect xs ([],[]))
+    where collect [] seenrest = seenrest
+          collect [x:xs] (seen,rest)
+          | isMember x seen
+          =   collect xs (seen,rest)
+          =   (seen``,[y:rest``])
+              where (seen`,rest``) = collect (generate y) ([x:seen],rest`)
+                    (seen``,rest`) = collect xs           (   seen`,rest)
+                    y = process x
+
+// `Disjoint xs ys' checks whether xs and ys are disjoint.
+
+disjoint :: .[elem] !.[elem] -> Bool | == elem
+disjoint xs ys = not (or (map (flip isMember xs) ys))
+
+eqlen :: ![.elem1] ![.elem2] -> .Bool
+eqlen [x:xs] [y:ys] = eqlen xs ys
+eqlen [] [] = True
+eqlen xs ys = False
+
+// `Foldlm' is a combination of foldl and map.
+foldlm :: ((.collect,.elem) -> (.collect,.elem`)) !(.collect,![.elem]) -> (.collect,[.elem`])
+foldlm f (l,[]) = (l,[])
+foldlm f (l,[m:ms])
+=   (l``,[m`:ms`])
+    where (l`,m`) = f (l,m)
+          (l``,ms`) = foldlm f (l`,ms)
+
+foldlr :: (.elem -> .((.lrinfo,.rlinfo) -> (.lrinfo,.rlinfo))) !(.lrinfo,.rlinfo) ![.elem] -> (.lrinfo,.rlinfo)
+foldlr f (l,r) []
+    = (l,r)
+foldlr f (l,r) [x:xs]
+    = (l``,r``)
+      where (l``,r`) = foldlr f (l`,r) xs
+            (l`,r``) = f x (l,r`)
+
+foldmap :: (x:res -> w:res`) w:res` -> u:(![(arg,x:res)] -> v:(arg -> w:res`)) | == arg, [v u <= w, v <= x]
+foldmap f d
+=   foldr foldmap` (const d)
+    where foldmap` (x,y) g v = if (x==v) (f y) (g v)
+
+foldoptional :: .res .(.t -> .res) !(Optional .t) -> .res
+foldoptional absent present Absent = absent
+foldoptional absent present (Present x) = present x
+
+forget :: val -> .(![.(val,res)] -> .[(val,res)]) | == val
+forget x = filter (neq x o fst)
+neq x y = x <> y
+
+indent :: .String -> .([.String] -> .[String])
+indent first = map2 (+++) [first:repeat (createArray (size first) ' ')]
+
+map2 :: (.a -> .(.b -> .c)) ![.a] [.b] -> [.c]
+map2 f [x:xs] [y:ys] = [f x y:map2 f xs ys]
+map2 f _ _ = []
+
+// `Identifiers' is the list of all identifiers
+identifiers :: [String]
+identifiers =: map toString (tl (kleene ['abcdefghijklmnopqrstuvwxyz']))
+
+// `Intersect xs ys' is the intersection of list `ys' with list `xs'.
+intersect :: ![elem] [elem] -> .[elem] | == elem
+intersect []     _  = []
+intersect [y:ys] xs = elim (cons y o intersect ys) (intersect ys xs) y xs
+
+// Elim removes a given element from a list.
+// There are two continuations, one for failure and one for success.
+elim :: .(v:[elem] -> .res) .res elem u:[elem] -> .res | == elem, [u <= v]
+elim found notfound y []
+=   notfound
+elim found notfound y [x:xs]
+| x==y
+=   found xs
+=   elim (found o cons x) notfound y xs
+
+// Cons prepends an element to a list
+cons :: .elem u:[.elem] -> v:[.elem], [u <= v]
+cons x xs = [x:xs]
+
+// `Join x xss' is the join of the list of lists `xss', separated by `x'.
+join :: a ![.[a]] -> .[a]
+join sep [] = []
+join sep [x:xs] = x++flatten (map (cons sep) xs)
+
+/* `Kleene xs' determines the kleene closure of the list `xs'  of  symbols,
+   i.e.   all strings over that list in standard order.  The implementation
+   is designed for maximum sharing.
+*/
+kleene :: !.[symbol] -> .[[symbol]]
+kleene [] = [[]]
+kleene symbols
+=   flatten (iterate prefix [[]])
+    where prefix strings
+          =   flatten (map appendstrings symbols)
+              where appendstrings symbol = map (cons symbol) strings
+
+lookup :: u:([(arg,w:res)] -> v:(arg -> w:res)) | == arg, [v u <= w]
+lookup = foldmap id (abort "lookup: not found")
+
+pairwith :: .(arg -> .res) arg -> (arg,.res)
+pairwith f x = (x,f x)
+
+plookup :: .(arg -> String) ![(arg,.res)] arg -> .res | == arg
+plookup showa tbl a = foldmap id (abort (showa a+++": not found")) tbl a
+
+power :: !Int (.t -> .t) -> .(.t -> .t)
+power n f
+| n <= 0
+=   id
+=   f o power (n-1) f
+
+printoptional :: .(.t -> String) !(Optional .t) -> String
+printoptional printa  Absent     = ""
+printoptional printa (Present a) = printa a
+
+proc :: .((w:elem -> .(.res -> .res)) -> v:(![w:elem] -> u:(.res -> .res))), [u <= v, u <= w]
+proc = flip o foldr
+
+mapfst :: v:(.a -> .b) -> u:((.a,.c) -> (.b,.c)), [u <= v]
+mapfst f = app2 (f,id)
+
+mapfst3 :: v:(.a -> .b) -> u:((.a,.c,.d) -> (.b,.c,.d)), [u <= v]
+mapfst3 f = app3 (f,id,id)
+
+maphd :: .(.a -> .a) !u:[.a] -> v:[.a], [u <= v]
+maphd f []     = []
+maphd f [x:xs] = [f x:xs]
+
+mapoptional :: .(.a -> .b) !(Optional .a) -> Optional .b
+mapoptional f Absent      = Absent
+mapoptional f (Present x) = Present (f x)
+
+mappair :: .(.a -> .b) .(.c -> .d) !(.a,.c) -> (.b,.d)
+mappair f g (x,y) = (f x,g y)
+
+mapsnd :: v:(.a -> .b) -> u:((.c,.a) -> (.c,.b)), [u <= v]
+mapsnd f = app2 (id,f)
+
+maptl :: .(x:[.a] -> u:[.a]) !w:[.a] -> v:[.a], [u <= v, w <= x]
+maptl f []     = []
+maptl f [x:xs] = [x:f xs]
+
+maptriple :: x:(.a -> .b) w:(.c -> .d) v:(.e -> .f) -> u:((.a,.c,.e) -> (.b,.d,.f)), [u <= v, u <= w, u <= x]
+maptriple f g h = app3 (f,g,h)
+
+partition :: (a -> b) (a -> .c) -> .(!.[a] -> [(b,[.c])]) | == b
+partition f g
+=   h
+    where h [] = []
+          h [x:xs]
+          =   [((r,[g x:ins])):h outs]
+              where ins = [g x\\x<-xs|f x==r]
+                    outs = [x\\x<-xs|f x<>r]
+                    r = f x
+
+relimg :: ![(a,.b)] a -> [.b] | == a
+relimg rel x` = [y\\(x,y)<-rel|x==x`]
+
+remap :: a b [.(a,b)] -> .[(a,b)] | == a
+remap x y xys = [(x,y):forget x xys]
+
+shorter :: ![.a] [.b] -> .Bool
+shorter []     yys    = False
+shorter [x:xs] []     = True
+shorter [x:xs] [y:ys] = shorter xs ys
+
+showbool :: .(!.Bool -> a) | fromBool a
+showbool = fromBool
+
+showoptional :: .(.a -> .String) !(Optional .a) -> String
+showoptional showa Absent      = "Absent"
+showoptional showa (Present a) = "(Present "+++showa a+++")"
+
+showpair :: !.(.a -> .String) !.(.b -> .String) !(.a,.b) -> String
+showpair showa showb (a,b) = "("+++showa a+++","+++showb b+++")"
+
+showstring :: .(!.String -> a) | fromString a
+showstring = fromString
+
+showtriple :: !.(.a -> .String) !.(.b -> .String) !.(.c -> .String) !(.a,.b,.c) -> String
+showtriple showa showb showc (a,b,c) = "("+++showa a+++","+++showb b+++","+++showc c+++")"
+
+split :: a -> .(.[a] -> [.[a]]) | == a
+split sep
+=   uncurry cons o spl
+    where spl [] = ([],[])
+          spl [x:xs]
+          | x==sep
+          =   ([],[ys:yss])
+          =   ([x:ys],yss)
+              where (ys,yss) = spl xs
+
+superset :: .[a] -> .(.[a] -> Bool) | == a
+superset set = isEmpty o (removeMembers set)