diff --git a/stdlib/Collection.expr b/stdlib/Collection.expr new file mode 100644 index 000000000..2eb212d29 --- /dev/null +++ b/stdlib/Collection.expr @@ -0,0 +1,110 @@ +-- MNode (key, list of values, balance factor, left subtree, right subtree) +-- balance factor = height (left subtree) - height (right subtree) + +public fun insert (m, k, v) { + fun rot (left, node) { + if left + then case node of + MNode (k, v, _, l, MNode (rk, rv, _, ll, rr)) -> + MNode (rk, rv, 0, MNode (k, v, 0, l, ll), rr) + esac + else case node of + MNode (k, v, _, MNode (lk, lv, _, ll, rr), r) -> + MNode (lk, lv, 0, ll, MNode (k, v, 0, rr, r)) + esac + fi + } + + fun factor (x) {x [2]} + + fun inner (m, k, v) { + case m of + {} -> [true, MNode (k, {v}, 0, {}, {})] + | MNode (kk, vv, bf, l, r) -> + local c = compare (k, kk); + if c == 0 + then [false, MNode (kk, v : vv, bf, l, r)] + else if c < 0 + then + case inner (l, k, v) of + [true, ll] -> if bf < 0 + then [false, MNode (kk, vv, bf + 1, ll, r)] + elif bf == 1 + then if ll.factor > 0 + then [false, rot (false, MNode (kk, vv, bf, ll, r))] + else [false, rot (false, MNode (kk, vv, bf, rot (true, ll), r))] + fi + else [true, MNode (kk, vv, bf + 1, ll, r)] + fi + | [false, ll] -> [false, MNode (kk, vv, bf, ll, r)] + esac + else + case inner (r, k, v) of + [true, rr] -> if bf > 0 + then [false, MNode (kk, vv, bf - 1, l, rr)] + elif bf == -1 + then if rr.factor < 0 + then [false, rot (true, MNode (kk, vv, bf, l, rr))] + else [false, rot (true, MNode (kk, vv, bf, l, rot (false, rr)))] + fi + else [true, MNode (kk, vv, bf - 1, l, rr)] + fi + | [false, rr] -> [false, MNode (kk, vv, bf, l, rr)] + esac + fi + fi + esac + } + + (m.inner (k, v)).snd +} + +public fun find (m, k) { + case m of + {} -> None + | MNode (kk, vv, _, l, r) -> + local c = compare (k, kk); + if c == 0 + then case vv of v : _ -> Some (v) | _ -> None esac + else find (if c < 0 then l else r fi, k) + fi + esac +} + +public fun remove (m, k) { + case m of + {} -> m + | MNode (kk, vv, bf, l, r) -> + local c = compare (k, kk); + if c == 0 + then case vv of {} -> m | _ : vt -> MNode (kk, vt, l, r) esac + else if c < 0 + then MNode (kk, vv, bf, remove (l, k), r) + else MNode (kk, vv, bf, l, remove (r, k)) + fi + fi + esac +} + +fun validate (t) { + fun inner (t, verify) { + case t of + {} -> 0 + | MNode (k, _, bf, l, r) -> + if verify (k) + then + local lh = validate (l, fun (x) {(*return*) x < k}), + rh = validate (r, fun (x) {(*return*) x > k}); + + if bf == lh - rh + then 1 + if lh > rh then lh else rh fi + else failure ("Balance violation on key %s\n", k.string) + fi + else failure ("Order violation on key %s\n", k.string) + fi + esac + } + + inner (t, fun (x) {true}) +} + diff --git a/stdlib/Matcher.expr b/stdlib/Matcher.expr index fe48885e8..77d9749ba 100644 --- a/stdlib/Matcher.expr +++ b/stdlib/Matcher.expr @@ -8,7 +8,7 @@ -- (e.g. "identifier", "string constant", etc.), used for error -- reporting fun createRegexp (r, name) { - return [regexp (r), name] + [regexp (r), name] } -- Create an immutable matcher. @@ -21,12 +21,12 @@ fun createRegexp (r, name) { fun matcherCreate (buf, pos, line, col) { -- Shows a matcher in a readable form fun show () { - return sprintf ("buf : %-40s\npos : %d\nline: %d\ncol : %d\n", buf, pos, line, col) + sprintf ("buf : %-40s\npos : %d\nline: %d\ncol : %d\n", buf, pos, line, col) } -- Calculates the number of remaining unmatched characters in the buffer fun rest () { - return buf.length - pos + buf.length - pos } -- Moves the position pointer on given number of characters. @@ -41,66 +41,59 @@ fun matcherCreate (buf, pos, line, col) { esac od; - return matcherCreate (buf, pos + n, l, c) + matcherCreate (buf, pos + n, l, c) } fun matchString (s) { - return - if s.length > rest () - then Fail (sprintf ("""%s"" expected at %d:%d", s, line, col)) - elif matchSubString (buf, s, pos) then Succ (shift (s.length), s) - else Fail (sprintf ("""%s"" expected at %d:%d", s, line, col)) - fi + if s.length > rest () + then Fail (sprintf ("""%s"" expected at %d:%d", s, line, col)) + elif matchSubString (buf, s, pos) then Succ (shift (s.length), s) + else Fail (sprintf ("""%s"" expected at %d:%d", s, line, col)) + fi } fun matchRegexp (r) { local n; - return - if (n := regexpMatch (r[0], buf, pos)) > 0 - then Succ (shift (n), substring (buf, pos, n)) - else Fail (sprintf ("%s expected at %d:%d", r[1], line, col)) - fi + if (n := regexpMatch (r[0], buf, pos)) > 0 + then Succ (shift (n), substring (buf, pos, n)) + else Fail (sprintf ("%s expected at %d:%d", r[1], line, col)) + fi } fun eof () { - return rest () == 0 + rest () == 0 } - return [ - show, - eof, - matchString, - matchRegexp + [show, + eof, + matchString, + matchRegexp ] } fun show (m) { - return m [0] () + m [0] () } fun endOf (m) { - return m [1] () + m [1] () } fun matchString (m, s) { - return m [2] (s) + m [2] (s) } -- Matches against a regexp fun matchRegexp (m, r) { - return m [3] (r) + m [3] (r) } -- Creates a fresh matcher from a string buffer public fun matcherInit (buf) { - return matcherCreate (buf, 0, 1, 1) + matcherCreate (buf, 0, 1, 1) } ---fun parse (a) { - ---} - local m = matcherInit (" -- asdasdakm ,m.,msd .,m.,asd\n \n\n abc"); local @@ -112,65 +105,50 @@ local chr = createRegexp ("'[^']'", "character literal"); fun token (s) { - return fun (m) {return m.matchString (s)} + fun (m) {m.matchString (s)} } + fun lid (m) { - return m.matchRegexp (lident) + matchRegexp (m, lident) } fun uid (m) { - return m.matchRegexp (uident) + matchRegexp (m, uident) } fun const (m) { - return m.matchRegexp (decimal) + matchRegexp (m, decimal) } infixl "@" before "*" (p, f) { - return fun (m) { - return - case p (m) of - Succ (m, x) -> Succ (m, f (x)) - | err -> err - esac + fun (m) { + case p (m) of + Succ (m, x) -> Succ (m, f (x)) + | err -> err + esac } } infixr "|>" after "!!" (l, r) { - return fun (m) { - return - case l (m) of - Succ (m, s) -> r (s) (m) - | err -> err - esac + fun (m) { + case l (m) of + Succ (m, s) -> r (s) (m) + | err -> err + esac } } infixr "||" after "|>" (l, r) { - return fun (m) { - return - case l (m) of - s@Succ (_, _) -> s - | err -> r (m) - esac + fun (m) { + case l (m) of + s@Succ (_, _) -> s + | err -> r (m) + esac } } -local expr = lid @ fun (s) {return Lid (s)} || - const @ fun (s) {return Dec (s)}, - assn = lid |> fun (id) {return token (":=") |> fun (s) {return expr @ fun (e) {return Assn (id, e)}}}; - -printf ("%s\n", assn (matcherInit ("x:=3")).string) - ---local ident = createRegexp ("[a-z][a-zA-Z_]*", "identifier"); ---local ws = createRegexp ("[ \n\t]+", "whitespace"); - ---local ws = createRegexp ("\\([ \t\n]\\|--[^\n]*\n\\)*", "whitespace"); - ---local str = createRegexp ("""\([^""]\|""""\)*""", "string literal"); ---local lineComment = createRegexp ("--[^\n]*\n", "line comment"); - ---printf ("ws: %s\n", case m.matchRegexp (ws) of Succ (m, s) -> "(" ++ m.show ++ ", " ++ s ++ ")" | Fail (err) -> err.string esac); - +local expr = lid @ fun (s) {Lid (s)} || const @ fun (s) {Dec (s)}, + assn = lid |> fun (id) {token (":=") |> fun (s) {expr @ fun (e) {Assn (id, e)}}}; +printf ("%s\n", case assn (matcherInit ("x:=3")) of Fail (err) -> err | Succ (_, s) -> s.string esac) diff --git a/stdlib/test01.expr b/stdlib/test01.expr new file mode 100644 index 000000000..ae60e256a --- /dev/null +++ b/stdlib/test01.expr @@ -0,0 +1,23 @@ +import Collection; + +local tree = {}, i; + +for i := 100, i >= 1, i := i-1 do + tree := insert (tree, i, i); + printf ("Inserting: %s\n", i.string); + printf ("Result : %s\n", tree.string) +od; + +tree := {}; + +for i := 1, i <= 100, i := i+2 do + tree := insert (tree, i, i); + printf ("Inserting: %s\n", i.string); + printf ("Result : %s\n", tree.string) +od; + +for i := 2, i <= 100, i := i+2 do + tree := insert (tree, i, i); + printf ("Inserting: %s\n", i.string); + printf ("Result : %s\n", tree.string) +od