diff --git a/lib/std/core.kk b/lib/std/core.kk index e47034a6a..1a8ae1969 100644 --- a/lib/std/core.kk +++ b/lib/std/core.kk @@ -160,6 +160,7 @@ type exception type open exception-info { Error Assert + Unreachable Todo Range Pattern( location : string, definition : string ) @@ -2583,7 +2584,11 @@ fun assert( message : string, condition : bool ) : () { if (!condition) unsafe-noexn{ throw(message,Assert) } } -fun todo( message : string ) : () { +fun unreachable() : a { + unsafe-noexn{ throw("BUG: this should never happen",Unreachable) } +} + +fun todo( message : string ) : a { unsafe-noexn{ throw(message,Todo) } } diff --git a/lib/std/data/red-black-tree.kk b/lib/std/data/red-black-tree.kk new file mode 100644 index 000000000..ec09dff8c --- /dev/null +++ b/lib/std/data/red-black-tree.kk @@ -0,0 +1,256 @@ +/*--------------------------------------------------------------------------- + Copyright 2017 Microsoft Corporation. + + This is free software; you can redistribute it and/or modify it under the + terms of the Apache License, Version 2.0. A copy of the License can be + found in the file "license.txt" at the root of this distribution. +---------------------------------------------------------------------------*/ + +// Adapted from https://github.com/sweirich/dth/blob/b888942f33425a871d46105862683e8950d15b23/examples/red-black/RedBlack.lhs +// TODO unit tests +module std/data/red-black-tree + +type color { + Red + Black +} + +abstract type tree { + Empty + Node(left: tree, value: a, right: tree, color: color) +} + + +public val empty: forall tree = Empty + + +public fun single(value: a): tree { + Node(empty, value, empty, Black) +} + + +// This is unsafe because it's possible to use different compare functions on the same tree +public fun unsafe-lookup(tree: tree, key: b, compare: (b, a) -> e order): e maybe { + match (tree) { + Node(left, value, right, _) -> + match (compare(key, value)) { + Lt -> unsafe-lookup(left, key, compare) + Eq -> Just(value) + Gt -> unsafe-lookup(right, key, compare) + } + + Empty -> + Nothing + } +} + + +// TODO implement this more efficiently +public fun find-first(tree: tree, fn: (a) -> e maybe): e maybe { + match (tree) { + Node(left, value, right, _) -> match (find-first(left, fn)) { + Nothing -> match (fn(value)) { + Nothing -> find-first(right, fn) + a -> a + } + a -> a + } + Empty -> Nothing + } +} + + +public fun foldl(tree: tree, initial: b, fn: (b, a) -> e b): e b { + match (tree) { + Node(left, value, right, _) -> foldl(right, fn(foldl(left, initial, fn), value), fn) + Empty -> initial + } +} + + +public fun foldr(tree: tree, initial: b, fn: (a, b) -> e b): e b { + match (tree) { + Node(left, value, right, _) -> foldr(left, fn(value, foldr(right, initial, fn)), fn) + Empty -> initial + } +} + + +public fun map(tree: tree, fn: (a) -> e b): e tree { + match (tree) { + // TODO this can be parallelized + Node(left, value, right, color) -> Node(map(left, fn), fn(value), map(right, fn), color) + Empty -> empty + } +} + + +public fun to-list(tree: tree): list { + tree.foldr([], Cons) +} + + +// TODO should this be called unsafe ? +public fun from-list(list: list, map: (a) -> e b, compare: (b, a) -> e order): e tree { + list.foldl(empty) fun(l, r) { + unsafe-insert(l, map(r), r, compare, True) + } +} + + +fun balance(tree: tree): tree { + match (tree) { + Node(Node(Node(a, x, b, Red), y, c, Red), z, d, Black) -> + Node(Node(a, x, b, Black), y, Node(c, z, d, Black), Red) + + Node(Node(a, x, Node(b, y, c, Red), Red), z, d, Black) -> + Node(Node(a, x, b, Black), y, Node(c, z, d, Black), Red) + + Node(a, x, Node(Node(b, y, c, Red), z, d, Red), Black) -> + Node(Node(a, x, b, Black), y, Node(c, z, d, Black), Red) + + Node(a, x, Node(b, y, Node(c, z, d, Red), Red), Black) -> + Node(Node(a, x, b, Black), y, Node(c, z, d, Black), Red) + + a -> a + } +} + +fun balance-left(left: tree, value: a, right: tree): tree { + match (left) { + Node(a, x, b, Red) -> + Node(Node(a, x, b, Black), value, right, Red) + + _ -> match (right) { + Node(a, y, b, Black) -> + balance(Node(left, value, Node(a, y, b, Red), Black)) + + Node(Node(a, y, b, Black), z, c, Red) -> + Node(Node(left, value, a, Black), y, balance(Node(b, z, redden(c), Black)), Red) + + _ -> unreachable() + } + } +} + +fun balance-right(left: tree, value: a, right: tree): tree { + match (right) { + Node(b, y, c, Red) -> + Node(left, value, Node(b, y, c, Black), Red) + + _ -> match (left) { + Node(a, x, b, Black) -> + balance(Node(Node(a, x, b, Red), value, right, Black)) + + Node(a, x, Node(b, y, c, Black), Red) -> + Node(balance(Node(redden(a), x, b, Black)), y, Node(c, value, right, Black), Red) + + _ -> unreachable() + } + } +} + +fun unsafe-merge(left: tree, right: tree): tree { + // TODO replace this with multi-pattern matching ? + match (left) { + Empty -> right + + Node(a, x, b, Red) -> match (right) { + Empty -> left + + Node(c, y, d, Red) -> + match (unsafe-merge(b, c)) { + Node(b1, z, c1, Red) -> Node(Node(a, x, b1, Red), z, Node(c1, y, d, Red), Red) + bc -> Node(a, x, Node(bc, y, d, Red), Red) + } + + _ -> Node(a, x, unsafe-merge(b, right), Red) + } + + Node(a, x, b, Black) -> match (right) { + Empty -> left + + Node(c, y, d, Black) -> + match (unsafe-merge(b, c)) { + Node(b1, z, c1, Red) -> Node(Node(a, x, b1, Black), z, Node(c1, y, d, Black), Red) + bc -> balance-left(a, x, Node(bc, y, d, Black)) + } + + Node(b1, x1, c, Red) -> + Node(unsafe-merge(left, b1), x1, c, Red) + + _ -> unreachable() // TODO remove this after Koka's exhaustiveness checker is fixed + } + + _ -> unreachable() // TODO remove this after Koka's exhaustiveness checker is fixed + } +} + + +fun blacken(tree: tree): tree { + match (tree) { + Node(left, value, right, Red) -> Node(left, value, right, Black) + a -> a + } +} + +fun redden(tree: tree): tree { + match (tree) { + Node(left, value, right, Black) -> Node(left, value, right, Red) + _ -> unreachable() + } +} + + +fun unsafe-insert1(tree: tree, key: b, value: a, compare: (b, a) -> e order, replace: bool): e tree { + match (tree) { + Node(left, middle, right, color) -> + match (compare(key, middle)) { + Lt -> balance(Node(unsafe-insert1(left, key, value, compare, replace), middle, right, color)) + + Gt -> balance(Node(left, middle, unsafe-insert1(right, key, value, compare, replace), color)) + + Eq -> if (replace) { + // TODO in this situation we should avoid balancing, because the structure hasn't changed + Node(left, value, right, color) // TODO return the Node unchanged if value is equal to middle + } else { + // TODO in this situation we should immediately return all the way to the root, because nothing has changed + tree + } + } + + Empty -> Node(empty, value, empty, Red) + } +} + +// This is unsafe because it's possible to use different compare functions on the same tree +public fun unsafe-insert(tree: tree, key: b, value: a, compare: (b, a) -> e order, replace: bool): e tree { + blacken(unsafe-insert1(tree, key, value, compare, replace)) +} + + +fun unsafe-remove1(tree: tree, key: b, compare: (b, a) -> e order): e tree { + match (tree) { + Node(left, middle, right, _) -> + match (compare(key, middle)) { + Lt -> match (left) { + Node(_, _, _, Black) -> balance-left(unsafe-remove1(left, key, compare), middle, right) + _ -> Node(unsafe-remove1(left, key, compare), middle, right, Red) + } + + Eq -> unsafe-merge(left, right) + + Gt -> match (right) { + Node(_, _, _, Black) -> balance-right(left, middle, unsafe-remove1(right, key, compare)) + _ -> Node(left, middle, unsafe-remove1(right, key, compare), Red) + } + } + + Empty -> tree + } +} + +// This is unsafe because it's possible to use different compare functions on the same tree +public fun unsafe-remove(tree: tree, key: b, compare: (b, a) -> e order): e tree { + blacken(unsafe-remove1(tree, key, compare)) +} diff --git a/lib/std/data/sorted-dict.kk b/lib/std/data/sorted-dict.kk new file mode 100644 index 000000000..fcffeddc3 --- /dev/null +++ b/lib/std/data/sorted-dict.kk @@ -0,0 +1,100 @@ +/*--------------------------------------------------------------------------- + Copyright 2017 Microsoft Corporation. + + This is free software; you can redistribute it and/or modify it under the + terms of the Apache License, Version 2.0. A copy of the License can be + found in the file "license.txt" at the root of this distribution. +---------------------------------------------------------------------------*/ + +// TODO unit tests +// TODO maybe allow for compare functions with effects +// TODO maybe add in the other functions from sorted-set +module std/data/sorted-dict + +import red-black-tree + + +abstract struct sorted-dict( + compare: (k, (k, a)) -> order, + tree: tree<(k, a)> +) + +fun from-compare(compare: (k, k) -> order): ((k, (k, a)) -> order) { + (fun(k1, v2) { + match (v2) { + (k2, _) -> compare(k1, k2) + } + }) +} + +public fun from-list(list: list<(k, a)>, compare: (k, k) -> order): sorted-dict { + val compare2 = from-compare(compare) + Sorted-dict(compare2, from-list(list, fst, compare2)) +} + +public fun to-list(dict: sorted-dict): list<(k, a)> { + to-list(dict.tree) +} + +public fun empty(compare: (k, k) -> order): sorted-dict { + Sorted-dict(from-compare(compare), empty) +} + +public fun [](dict: sorted-dict, key: k): maybe { + unsafe-lookup(dict.tree, key, dict.compare).map(snd) +} + +// TODO inline this +// TODO maybe it shouldn't include this ? +public fun [](dict: sorted-dict, key: k, value: a): sorted-dict { + set(dict, key, value) +} + +public fun has?(dict: sorted-dict, key: k): bool { + // TODO this can be implemented faster + bool(dict[key]) +} + +public fun set(dict: sorted-dict, key: k, value: a): sorted-dict { + dict(tree = unsafe-insert(dict.tree, key, (key, value), dict.compare, True)) +} + +public fun remove(dict: sorted-dict, key: k): sorted-dict { + dict(tree = unsafe-remove(dict.tree, key, dict.compare)) +} + +public fun merge-left(left: sorted-dict, right: sorted-dict): sorted-dict { + val compare = left.compare + left( + tree = right.tree.foldl(left.tree) fun(old, a) { + match (a) { + // If a value exists in both `left` and `right` it will prefer the value from `left` + (key, _) -> unsafe-insert(old, key, a, compare, False) + } + } + ) +} + +public fun merge-right(left: sorted-dict, right: sorted-dict): sorted-dict { + val compare = right.compare + right( + tree = left.tree.foldl(right.tree) fun(old, a) { + match (a) { + // If a value exists in both `left` and `right` it will prefer the value from `right` + (key, _) -> unsafe-insert(old, key, a, compare, False) + } + } + ) +} + +public fun subset-of?(smaller: sorted-dict, bigger: sorted-dict): bool { + smaller.tree.find-first fun(a) { + match (a) { + (key, _) -> if (bigger.has?(key)) { + Nothing + } else { + Just(False) + } + } + }.default(True) +} diff --git a/lib/std/data/sorted-set.kk b/lib/std/data/sorted-set.kk new file mode 100644 index 000000000..19fd1c5be --- /dev/null +++ b/lib/std/data/sorted-set.kk @@ -0,0 +1,113 @@ +/*--------------------------------------------------------------------------- + Copyright 2017 Microsoft Corporation. + + This is free software; you can redistribute it and/or modify it under the + terms of the Apache License, Version 2.0. A copy of the License can be + found in the file "license.txt" at the root of this distribution. +---------------------------------------------------------------------------*/ + +// TODO unit tests +// TODO disjoint unions +// TODO power set +// TODO cartesian product +// TODO maybe allow for compare functions with effects +module std/data/sorted-set + +import red-black-tree + + +abstract struct sorted-set( + compare: (a, a) -> order, + tree: tree +) + +public fun from-list(list: list, compare: (a, a) -> order): sorted-set { + Sorted-set(compare, from-list(list, id, compare)) +} + +public fun to-list(set: sorted-set): list { + to-list(set.tree) +} + +public fun empty(compare: (a, a) -> order): sorted-set { + Sorted-set(compare, empty) +} + +public fun has?(set: sorted-set, value: a): bool { + // TODO this can be implemented faster + bool(unsafe-lookup(set.tree, value, set.compare)) +} + +public fun insert(set: sorted-set, value: a): sorted-set { + set(tree = unsafe-insert(set.tree, value, value, set.compare, True)) +} + +public fun remove(set: sorted-set, value: a): sorted-set { + set(tree = unsafe-remove(set.tree, value, set.compare)) +} + +public fun exclude(set: sorted-set, exclude: sorted-set): sorted-set { + val compare = set.compare + set( + tree = exclude.tree.foldl(set.tree) fun(old, value) { + unsafe-remove(old, value, compare) + } + ) +} + +public fun intersection-right(left: sorted-set, right: sorted-set): sorted-set { + val compare = right.compare + right( + tree = right.tree.foldl(empty) fun(old, value) { + if (left.has?(value)) { + unsafe-insert(old, value, value, compare, True) + } else { + old + } + } + ) +} + +public fun intersection-left(left: sorted-set, right: sorted-set): sorted-set { + intersection-right(right, left) +} + +public fun difference-left(left: sorted-set, right: sorted-set): sorted-set { + // TODO implement this more efficiently + union-left(exclude(left, right), exclude(right, left)) +} + +public fun difference-right(left: sorted-set, right: sorted-set): sorted-set { + // TODO implement this more efficiently + union-right(exclude(left, right), exclude(right, left)) +} + +public fun union-left(left: sorted-set, right: sorted-set): sorted-set { + val compare = left.compare + left( + tree = right.tree.foldl(left.tree) fun(old, value) { + // If a value exists in both `left` and `right` it will prefer the value from `left` + unsafe-insert(old, value, value, compare, False) + } + ) +} + +public fun union-right(left: sorted-set, right: sorted-set): sorted-set { + val compare = right.compare + right( + tree = left.tree.foldl(right.tree) fun(old, value) { + // If a value exists in both `left` and `right` it will prefer the value from `right` + unsafe-insert(old, value, value, compare, False) + } + ) +} + +public fun subset-of?(smaller: sorted-set, bigger: sorted-set): bool { + smaller.tree.find-first fun(value) { + if (bigger.has?(value)) { + Nothing + } else { + Just(False) + } + }.default(True) +}