diff --git a/lib/Base/Int.fram b/lib/Base/Int.fram index 074c2038..488d13df 100644 --- a/lib/Base/Int.fram +++ b/lib/Base/Int.fram @@ -16,6 +16,7 @@ pub method gt = (extern dbl_gtInt : Int -> Int -> Bool) pub method lt = (extern dbl_ltInt : Int -> Int -> Bool) pub method ge = (extern dbl_geInt : Int -> Int -> Bool) pub method le = (extern dbl_leInt : Int -> Int -> Bool) +pub method compare (self:Int) (y:Int) = if self.lt y then Lt else if y.lt self then Gt else Eq pub method add = (extern dbl_addInt : Int -> Int -> Int) pub method sub = (extern dbl_subInt : Int -> Int -> Int) diff --git a/lib/Base/String.fram b/lib/Base/String.fram index e620ca50..c44cedb0 100644 --- a/lib/Base/String.fram +++ b/lib/Base/String.fram @@ -15,6 +15,7 @@ pub method gt = (extern dbl_gtStr : String -> String -> Bool) pub method lt = (extern dbl_ltStr : String -> String -> Bool) pub method ge = (extern dbl_geStr : String -> String -> Bool) pub method le = (extern dbl_leStr : String -> String -> Bool) +pub method compare (self:String) (y:String) = if self.lt y then Lt else if y.lt self then Gt else Eq pub method length = (extern dbl_strLen : String -> Int) pub method get {~__line__, ~__file__} (self : String) (n : Int) = diff --git a/lib/Base/Types.fram b/lib/Base/Types.fram index cab416ea..7151b0f8 100644 --- a/lib/Base/Types.fram +++ b/lib/Base/Types.fram @@ -8,4 +8,6 @@ pub data Pair X Y = (,) of X, Y pub data Either X Y = Left of X | Right of Y +pub data Ord = Lt | Eq | Gt + pub data Result A E = Ok of A | Err of E diff --git a/lib/Map.fram b/lib/Map.fram index b8e8fa49..0bc058c1 100644 --- a/lib/Map.fram +++ b/lib/Map.fram @@ -2,650 +2,855 @@ # See LICENSE for details. #} -## # Finite maps from comparable keys to values. - -{## -This module provides finite maps (a.k.a. associative arrays or dictionaries) -from keys to values. The keys must support equality (method `equal`) and a -total ordering (method `lt`). The implementation is based on balanced trees -(2-3 trees), providing logarithmic time complexity for insertion, deletion, -and lookup operations. Since the correctness of the implementation relies on -invariants related to the ordering of keys, the comparison methods are the -parameters of the whole construction, instead of particular map operations. -Therefore, maps are implemented as a functor `make` that takes the type with -the comparison methods and returns a record that contains existential type -representing the map and all the operations on it. - -To create a map, use the `make` function, and unpack the result. Resulting -operations may be packed into a module using `module` pattern. For instance, -to create a map from integers, one may write: -``` -let (Map { module IntMap }) = make { Key = Int } -``` -Thanks to type inference, it is not necessary to provide the comparison -methods if they are already defined for the key type. However, they may be -overridden by providing them explicitly, for instance to change the ordering. -``` -let (Map { module IntMap }) = make - { Key = Int - , method lt x y = x > y # reverse order - } -``` -##} - -{## Signature of the map type and its operations. - - This is the record type returned by the `make` functor. Parameter `Key` is - the type of keys used in the map. ##} -pub data MapSig Key = Map of - {## Type `T Val` represents a map from keys to values of type `Val`. ##} - { T : type -> type - - {## Empty map. ##} - , empty : {Val} -> T Val - - {## Singleton map containing a single key-value pair. ##} - , singleton : {Val} -> Key -> Val -> T Val - - {## Add a key-value pair to the map. If the key already exists, its value - is replaced. ##} - , method add : {Val} -> T Val -> Key -> Val ->[] T Val - - {## Remove a key (and its value) from the map. If the key does not exist, - the map is returned unchanged. ##} - , method remove : {Val} -> T Val -> Key ->[] T Val - - {## Remove and return the key-value pair with the smallest key. If the map - is empty, `None` is returned. ##} - , method popMin : {Val} -> T Val ->[] Option (Pair (Pair Key Val) (T Val)) - - {## Like `popMin`, but calls `~onError` if the map is empty. ##} - , method popMinErr : - {Val, E, ~onError : Unit ->[E] Pair (Pair Key Val) (T Val)} -> - T Val ->[E] Pair (Pair Key Val) (T Val) - - {## Check whether the map is empty. ##} - , method isEmpty : {Val} -> T Val -> Bool - - {## Find the value associated with a key. Returns `None` if the key is not - present in the map. ##} - , method find : {Val} -> T Val -> Key ->[] Option Val - - {## Check whether a key is present in the map. ##} - , method mem : {Val} -> T Val -> Key ->[] Bool - - {## Like `find`, but calls `~onError` if the key is not present. The - `~onError` function may be used to provide a default value or to raise an - error. ##} - , method findErr : - {Val, E, ~onError : Unit ->[E] Val} -> T Val -> Key ->[E] Val - - {## Get the number of key-value pairs in the map. ##} - , method size : {Val} -> T Val -> Int - - {## Create a new map by applying a function to all values in the map. The - function receives the key as an additional named parameter. ##} - , method map : {A, B, E} -> T A -> ({key:Key} -> A ->[E] B) ->[E] T B - - {## Fold over all key-value pairs in the map. The function receives the key - as an additional named parameter. Elements are processed in ascending - order of keys. ##} - , method fold : - {Val, Acc, E} -> T Val -> - ({key:Key} -> Val -> Acc ->[E] Acc) -> Acc ->[E] Acc - - {## Iterate over all key-value pairs in the map. The function receives the - key as an additional named parameter. Elements are processed in ascending - order of keys. ##} - , method iter : - {Val, E} -> T Val -> ({key:Key} -> Val ->[E] Unit) ->[E] Unit - } - #============================================================================== -# Implementation of the map type and its operations. +# Red Black Tree implementation #============================================================================== -{# The implementation is based on balanced 2-3 trees: ordered trees where -each internal node has either two or three children, and all leaves are at the -same depth. Interestingly, the latter invariant is enforced by types, using -nested datatypes approach. To do so, we define the following two types. +# Due to frequent request for understanding this file please +# see comments at the end of this file + +import List + +data Color = + | Red + | Black + +data rec Tree Value = + | Leaf + | Node of { + color: Color, + size: Int, + left: Tree Value, + value: Value, + right: Tree Value + } + +{# Red-black invariant: +# no red node has a red child +# Black height invariant: +# for every t = Node(_, _, left, _, right), +# black-height(left) = black-height(right) +# Leaves are considered black, but do not contribute to black height. #} -data Leaf = Leaf - -data Node Key Val Repr = - | Node2 of Repr, Key, Val, Repr - | Node3 of Repr, Key, Val, Repr, Key, Val, Repr +data ZipElem Value = + | Left of Color, Value, Tree Value + | Right of Color, Tree Value, Value -{# By applying `Node Key Val` to `Leaf` n times, we get the type of balanced -2-3 trees of height n. For instance, `Node Key Val (Node Key Val Leaf)` is the -type of trees of height 2: below the root, there are nodes whose children are -leaves. To represent maps of arbitrary size, we define another datatype that -counts the height of the tree in its type. This is the only recursive type in -the whole construction. #} +# Empty tree +let empty = Leaf -data rec Tree Key Val Repr = - | Tree of Repr - | Succ of Tree Key Val (Node Key Val Repr) +# Return cached size +let size tree = + match tree with + | Leaf => 0 + | Node {size} => size + end -{# The `Tree Key Val Leaf` type represents balanced 2-3 trees of arbitrary -height. A tree of height n is represented as `Succ` applied n times to -`Tree t`, where `t` is the actual tree representation. +# Smart constructor that updates the size of node +let makeNode color left value right = + Node {color, size = size left + size right + 1, left, value, right} -Finally, to keep track of the number of elements in the map, we define the -following wrapper type. #} +# Constructor for node +let construct color size left value right = + Node {color,size,left,value,right} -data SizedTree Key Val = - { tree : Tree Key Val Leaf - , size : Int - } +# Walk upward applying recorded decisions (zipper) to rebuild tree +let rec zip tree zipper = + match zipper with + | [] => tree -{# We start by simple operations with straightforward implementations. #} + | Left color value right :: rest => + zip (makeNode color tree value right) rest -let empty = SizedTree - { tree = Tree Leaf - , size = 0 - } + | Right color left value :: rest => + zip (makeNode color left value tree) rest -let singleton k v = SizedTree - { tree = Succ (Tree (Node2 Leaf k v Leaf)) - , size = 1 - } + end -method isEmpty (SizedTree { tree }) = +{# Precondition: + # (zip (Node (RED, size, left, value ,right) zipper) + # satisfies the black-height invariant, + # and also satisfies the red-black + # invariant except possibly locally + #} +let rec zipRed value left right zipper = + match zipper with + # Root case + | [] => makeNode Black left value right + + # Father is black and we are left child then we recreate the node + # and we are rebuilding tree + | Left Black value1 right1 :: rest => + zip (makeNode Black (makeNode Red left value right) value1 right1) rest + + + # Father is black and we are right child then we recreate the node + # and we are rebuilding tree + | Right Black left1 value1 :: rest => + zip (makeNode Black left1 value1 (makeNode Red left value right)) rest + + # Father is Red and left child, the uncle is Red and we are left child. + # The father and uncle are colored Black. + # ZipRed is recursively called on the grandfather. + | Left Red value1 right1 :: + Left _ value2 + (Node {color = Red, size = size3, left = left3, + value = value3, right = right3}) :: rest => + let left' = makeNode Red left value right + let right' = construct Black size3 left3 value3 right3 in + zipRed value2 (makeNode Black left' value1 right1) right' rest + + # Father is Red and right child, the uncle is Red and we are left child. + # The father and uncle are colored Black. + # ZipRed is recursively called on the grandfather. + | Left Red value1 right1 :: + Right _ + (Node {color = Red, size = size3, left = left3, + value = value3, right = right3}) value2 :: rest => + let left' = construct Black size3 left3 value3 right3 + let right' = makeNode Red left value right in + zipRed value2 left' (makeNode Black right' value1 right1) rest + + # Father is Red and left child, the uncle is Red and we are right child. + # The father and uncle are colored Black. + # ZipRed is recursively called on the grandfather. + | Right Red left1 value1 :: + Left _ value2 + (Node {color = Red, size = size3, left = left3, + value = value3, right = right3}) :: rest => + let left' = makeNode Red left value right + let right' = construct Black size3 left3 value3 right3 in + zipRed value2 (makeNode Black left1 value1 left') right' rest + + # Father is Red and right child, the uncle is Red and we are right child. + # The father and uncle are colored Black. + # ZipRed is recursively called on the grandfather. + | Right Red left1 value1 :: + Right _ (Node {color = Red, size = size3, left = left3, + value = value3, right = right3}) value2 :: rest => + let left' = construct Black size3 left3 value3 right3 + let right' = makeNode Red left value right in + zipRed value2 left' (makeNode Black left1 value1 right') rest + + # Father is Red and left child, the uncle is Black and we are left child. + # The father and uncle are colored Red. + # The grandfather is then black and we are rebuilding the tree. + | Left Red value1 right1 :: Left _ value2 node3 :: rest => + let left' = makeNode Red left value right + let right' = makeNode Red right1 value2 node3 in + zip (makeNode Black left' value1 right') rest + + # Father is Red and right child, the uncle is Black and we are left child. + # The father and uncle are colored Red. + # The grandfather is then black and we are rebuilding the tree. + | Left Red value1 right1 :: Right _ node3 value2 :: rest => + let left' = makeNode Red node3 value2 left + let right' = makeNode Red right value1 right1 in + zip (makeNode Black left' value right') rest + + # Father is Red and left child, the uncle is Black and we are right child. + # The father and uncle are colored Red. + # The grandfather is then black and we are rebuilding the tree. + | Right Red left1 value1 :: Left _ value2 node3 :: rest => + let left' = makeNode Red left1 value1 left + let right' = makeNode Red right value2 node3 in + zip (makeNode Black left' value right') rest + + # Father is Red and right child, the uncle is Black and we are right child. + # The father and uncle are colored Red. + # The grandfather is then black and we are rebuilding the tree. + | Right Red left1 value1 :: Right _ node3 value2 :: rest => + let left' = makeNode Red node3 value2 left1 + let right' = makeNode Red left value right in + zip (makeNode Black left' value1 right') rest + + # The father is Red and a root and we are left child. + # The functions correct invariant about root. + | Left Red value1 right1 :: [] => + makeNode Black (makeNode Red left value right) value1 right1 + + # The father is Red and a root and we are right child. + # The functions correct invariant about root. + | Right Red left1 value1 :: [] => + makeNode Black left1 value1 (makeNode Red left value right) + + end + +{# Precondition: +# 1. tree is black +# 2. (zip tree zipper) satisfies the red-black invariant, and it +# would satisfy the black-height invariant if the black-height of +# tree were one higher +#} +let rec zipBlack tree zipper = + match zipper with + # Root case + | [] => tree + + # Tree is left child, and right nephew is Red. + # father(C) brother(C) + # / \ / \ + # tree brother -> father(B) rnephew(B) + # / \ / \ + # lnephew rnephew(R) tree lnephew + # After rotation, the whole tree is reconstructed + | Left color1 value1 + (Node {left = left2, value = value2, + right = (Node {color = Red, size = size3, + left = left3, value = value3, right = right3})}) :: + rest => + let left' = makeNode Black tree value1 left2 + let right' = construct Black size3 left3 value3 right3 in + zip (makeNode color1 left' value2 right') rest + + # Tree is right child, and left nephew is Red. + # Cfather Cbrother + # / \ / \ + # brother tree -> Blnephew Bfather + # / \ / \ + # Rlnephew rnephew rnephew tree + # After rotation, the whole tree is reconstructed + | Right color1 (Node { left = (Node {color = Red, size = size3, left = left3, + value = value3, right = right3}), value = value2, right = right2}) + value1 :: rest => + let left' = construct Black size3 left3 value3 right3 + let right' = makeNode Black right2 value1 tree in + zip (makeNode color1 left' value2 right') rest + + # Tree is left child, and right nephew is Red. + # Cfather Crnephew + # / \ / \ + # tree brother -> Bfather Bbrother + # / \ / \ / \ + # Rlnephew Brnephew tree left right Brnephew + # / \ + # left right + # After rotation, the whole tree is reconstructed + | Left color1 value1 (Node {left = (Node {color = Red, left = left3, + value = value3, right = right3}), + value = value2, right = right2}) :: rest => + let left' = makeNode Black tree value1 left3 + let right' = makeNode Black right3 value2 right2 in + zip (makeNode color1 left' value3 right') rest + + # Tree is right child, and left nephew is Red. + # Cfather Crnephew + # / \ / \ + # brother tree -> Bbrother Bfather + # / \ / \ / \ + # Blnephew Rrnephew Blnephew left right tree + # / \ + # left right + # After rotation, the whole tree is reconstructed + | Right color1 (Node {left = left2, value = value2, right = + (Node {color = Red, left = left3, value = value3, right = right3})}) + value1 :: rest => + let left' = makeNode Black left2 value2 left3 + let right' = makeNode Black right3 value1 tree in + zip (makeNode color1 left' value3 right') rest + + # The father is red and no nephew is red. + # Then father becomes black and brother becomes red + # removing therfore the inequality of blackness. + # After that, the whole tree is reconstructed. + | Left Red value1 (Node {size = size2, left = left2, + value = value2, right = right2}) :: rest => + let right' = construct Red size2 left2 value2 right2 in + zip (makeNode Black tree value1 right') rest + + # The father is red and no nephew is red. + # Then father becomes black and brother becomes red + # removing therfore the inequality of blackness. + # After that, the whole tree is reconstructed. + | Right Red (Node {size = size2, left = left2, + value = value2, right = right2}) value1 :: rest => + let left' = construct Red size2 left2 value2 right2 in + zip (makeNode Black left' value1 tree) rest + + # The father is black and no nephew is red. + # Brother becomes red but the inequality of blackness is sustained. + # ZipBlack recursively called on the father. + | Left Black value1 (Node {color = Black, size = size2, left = left2, + value = value2, right = right2}) :: rest => + let right' = construct Red size2 left2 value2 right2 in + zipBlack (makeNode Black tree value1 right') rest + + # The father is black and no nephew is red. + # Brother becomes red but the inequality of blackness is sustained. + # ZipBlack recursively called on the father. + | Right Black (Node {color = Black, size = size2, left = left2, + value = value2, right = right2}) value1 :: rest => + let left' = construct Red size2 left2 value2 right2 in + zipBlack (makeNode Black left' value1 tree) rest + + # The father is black and no nephew is red. + # Brother becomes red but the inequality of blackness is sustained. + # ZipBlack recursively called on the father. + | Left Black value1 (Node {color = Red, left = left2, + value = value2, right = right2}) :: rest => + zipBlack tree (Left Red value1 left2 :: Left Black value2 right2 :: rest) + + # The father is black and no nephew is red. + # Brother becomes red but the inequality of blackness is sustained. + # ZipBlack recursively called on the father. + | Right Black (Node {color = Red, left = left2, value = value2, + right = right2}) value1 :: rest => + let rest' = Right Red right2 value1 :: Right Black left2 value2 :: rest in + zipBlack tree rest' + + # Impossible + | Left _ _ Leaf :: _ => impossible () + + | Right _ Leaf _ :: _ => impossible () + + end + +# search splits tree according to compare function and builds zipper +let rec search func tree zipper = match tree with - | Tree Leaf => True - | Succ _ => False + | Leaf => (Leaf, zipper) + | Node {color, left, value, right} => + match func value with + | Lt => + search func left (Left color value right :: zipper) + | Gt => + search func right (Right color left value :: zipper) + | Eq => (tree, zipper) + end end -{# To implement addition and removal of elements, some auxiliary definitions -are needed. First, when adding an element to a tree, it may happen that the -tree needs to be split into two trees of the same height (plus a key-value -pair) to maintain the balance. We define the following datatype to represent -the result of addition to a tree represented by `Repr`. #} - -data AddResult Key Val Repr = - | AR_Ok of Repr - | AR_Split of Repr, Key, Val, Repr - -{# For removal, situation is similar, but slightly more complex. Removal may -result in decreasing the height of the tree, but how to represent that, when -the type of trees is represented abstractly by `Repr`? To solve this, handle -separately the case when the tree is empty (represented by `Leaf`), and the -case when the tree is non-empty (represented by `Node Key Val Repr`). For the -latter case, we define the following datatype to represent the result of -removal. #} - -data RemResult Key Val Repr = - | RR_Ok of Node Key Val Repr - | RR_Underflow of Repr - -{# Both types above can be converted back to `Tree` type. #} - -method toTree ar = - match ar with - | AR_Ok repr => Tree repr - | AR_Split l k v r => Succ (Tree (Node2 l k v r)) +# serachMin finds smallest element in a tree and builds zipper +let rec searchMin tree zipper = + match tree with + | Leaf => zipper + | Node {color, left, value, right} => + searchMin left (Left color value right :: zipper) end -method toTree rr = - match rr with - | RR_Ok node => Succ (Tree node) - | RR_Underflow repr => Tree repr +# serachMax finds largest element in a tree and builds zipper +let rec searchMax tree zipper = + match tree with + | Leaf => zipper + | Node {color, left, value, right} => + searchMax right (Right color left value:: zipper) end -#------------------------------------------------------------------------------ -# Smart constructors for nodes with addition and removal results. - -{# We define the following smart constructors for nodes, when one of their -subtrees is a result of addition or removal. These constructors maintain the -balance of the tree and return appropriate addition or removal results. Thanks -to the nested datatype representation, the types ensure that the resulting -trees are balanced. #} - -let node2AL l k1 v1 r = - match l with - | AR_Ok l => - AR_Ok (Node2 l k1 v1 r) - | AR_Split l k v m => - AR_Ok (Node3 l k v m k1 v1 r) +{# Removes a node if one of the child is a Leaf and rebuilds tree +# Precondition: +# (zip (Node (color, _, _, Leaf, child)) zipper) is a valid tree, +# or (zip (Node (color, _, _, child, Leaf)) zipper) is a valid tree. +#} +let deleteNearLeaf color child zipper = + match color with + {# child cannot be RED, by red-black invariant, + so it must be Leaf, by black-height invariant. + #} + | Red => zip Leaf zipper + | Black => + match child with + | Node {value} => + # Must be RED with Leaf children, by black-height invariant. + zip (makeNode Black Leaf value Leaf) zipper + | Leaf => zipBlack Leaf zipper + end end -let node2AR l k1 v1 r = - match r with - | AR_Ok r => - AR_Ok (Node2 l k1 v1 r) - | AR_Split m k v r => - AR_Ok (Node3 l k1 v1 m k v r) +{# Deletes node and adds children correctly to zipper and zip back the tree + Precondition: + zip (Node (color, _, _, left, right)) zipper is a valid tree. +#} +let delete color left right zipper = + match right with + | Leaf => + match left with + | Leaf => + match color with + | Red => zip Leaf zipper + | Black => zipBlack Leaf zipper + end + | _ => + match searchMax left [] with + | Right colorLeftMin leftLeftMin valueLeftMin :: zipperr => + deleteNearLeaf colorLeftMin leftLeftMin + (List.append zipperr (Left color valueLeftMin right :: zipper)) + | _ => Leaf #Fail "postcondition" + end + end + | _ => + match searchMin right [] with + | Left colorRightMin valueRightMin rightRightMin :: zipperr => + deleteNearLeaf colorRightMin rightRightMin + (List.append zipperr (Right color left valueRightMin :: zipper)) + | _ => Leaf #Fail "postcondition" + end end -let node3AL l k1 v1 m k2 v2 r = - match l with - | AR_Ok l => - AR_Ok (Node3 l k1 v1 m k2 v2 r) - | AR_Split ll k v lm => - AR_Split (Node2 ll k v lm) k1 v1 (Node2 m k2 v2 r) +# makes a root black +let blacken tree = + match tree with + | Node {color = Red, size, left, value, right} => + construct Black size left value right + | _ => tree end -let node3AM l k1 v1 m k2 v2 r = - match m with - | AR_Ok m => - AR_Ok (Node3 l k1 v1 m k2 v2 r) - | AR_Split ml k v mr => - AR_Split (Node2 l k1 v1 ml) k v (Node2 mr k2 v2 r) +# returns black height +let rec blackHeight tree acc = + match tree with + | Leaf => acc + | Node {color=Red,left} => blackHeight left acc + | Node {color=Black,left} => blackHeight left (1 + acc) end -let node3AR l k1 v1 m k2 v2 r = - match r with - | AR_Ok r => - AR_Ok (Node3 l k1 v1 m k2 v2 r) - | AR_Split mr k v rr => - AR_Split (Node2 l k1 v1 m) k2 v2 (Node2 mr k v rr) +{# precondition: blackHeight(tree) >= target >= 0 + find a black subtree along the left/right spine whose black-height is + blackHeight(tree) - target. +#} +let rec searchHeight leftward target tree zipper = + match tree with + | Leaf => (Leaf, zipper) + | Node {color=Red,left,value,right} => + if leftward then + searchHeight leftward target left (Left Red value right :: zipper) + else + searchHeight leftward target right (Right Red left value :: zipper) + | Node {color=Black,left,value,right} => + if 0 == target then + (tree,zipper) + else if leftward then + searchHeight leftward (target - 1) left + (Left Black value right :: zipper) + else + searchHeight leftward (target - 1) right + (Right Black left value :: zipper) end -let node2RL l k1 v1 r = - match l with - | RR_Ok l => - RR_Ok (Node2 l k1 v1 r) - | RR_Underflow l => - match r with - | Node2 m k2 v2 r => - RR_Underflow (Node3 l k1 v1 m k2 v2 r) - | Node3 ml k2 v2 mr k3 v3 r => - RR_Ok (Node2 (Node2 l k1 v1 ml) k2 v2 (Node2 mr k3 v3 r)) +# adds element to the tree +let joinVal left value right = + # without loss of generality, assume left and right have black roots + let left = blacken left in + let right = blacken right in + let lbh = blackHeight left 0 in + let rbh = blackHeight right 0 in + if lbh == rbh then + makeNode Black left value right + else if lbh > rbh then + (let (_left, zipper) = searchHeight False (lbh-rbh) left [] in + # left' and right are both black and both have black height rbh + zipRed value _left right zipper) + else + (let (_right, zipper) = searchHeight True (rbh-lbh) right [] in + # left and right' are both black and both have black height lbh + zipRed value left _right zipper) + +# joins two trees +let join left right = + match left with + | Leaf => right + | _ => + match right with + | Leaf => left + | _ => + match searchMax left [] with + | Right color leftSmall value :: zipper => + joinVal (deleteNearLeaf color leftSmall zipper) value right + |_ => left + end end end -let node2RR l k1 v1 r = - match r with - | RR_Ok r => - RR_Ok (Node2 l k1 v1 r) - | RR_Underflow r => - match l with - | Node2 l k2 v2 m => - RR_Underflow (Node3 l k2 v2 m k1 v1 r) - | Node3 ll k3 v3 lm k2 v2 m => - RR_Ok (Node2 (Node2 ll k3 v3 lm) k2 v2 (Node2 m k1 v1 r)) +# Splits tree according to the function +let rec split compareWithPivot tree = + match tree with + | Leaf => (None,Leaf,Leaf) + | Node {left,value,right} => + match compareWithPivot value with + | Eq => (Some value, left, right) + | Lt => + let (_v, _l, _r) = split compareWithPivot left in + (_v, _l, joinVal _r value right) + | Gt => let (_v, _l, _r) = split compareWithPivot right in + (_v, joinVal left value _l, _r) end end -let node3RL l k1 v1 m k2 v2 r = - match l with - | RR_Ok l => - RR_Ok (Node3 l k1 v1 m k2 v2 r) - | RR_Underflow l => - match m with - | Node2 ml k v mr => - RR_Ok (Node2 (Node3 l k1 v1 ml k v mr) k2 v2 r) - | Node3 ml kl vl mm kr vr mr => - RR_Ok (Node3 (Node2 l k1 v1 ml) kl vl (Node2 mm kr vr mr) k2 v2 r) - end - end +#============================================================================== +# Ordered Map signature +#============================================================================== -let node3RM l k1 v1 m k2 v2 r = - match m with - | RR_Ok m => - RR_Ok (Node3 l k1 v1 m k2 v2 r) - | RR_Underflow m => - match r with - | Node2 rl k3 v3 rr => - RR_Ok (Node2 l k1 v1 (Node3 m k2 v2 rl k3 v3 rr)) - | Node3 rl k3 v3 rm k4 v4 rr => - RR_Ok (Node3 l k1 v1 (Node2 m k2 v2 rl) k3 v3 (Node2 rm k4 v4 rr)) - end - end +parameter ~onError + +pub data Map Key = Map of { + T + + {## @brief Creates empty map + ##} + , empty : {Val} -> T Val + + {## @brief Method to testing whether given map is empty or not + # @return True if it's empty false otherwise + ##} + , method isEmpty : {Val} -> T Val ->[] Bool + + + {## @brief Method to get size of map + # @return Integer that is a size of map + ##} + , method size : {Val} -> T Val ->[] Int + + {## @brief Method for inserting element to the map + # @param Key which will be inserted to the map + # @param Value which will be inserted to the map + # @return Map with inserted value + ##} + , method insert : {Val} -> T Val -> + Key -> Val ->[] T Val + + {## @brief Method for inserting element to the map + # @param Key which will be inserted to the map + # @param Value which will be inserted to the map + # @return Map with inserted value + # and boolean value if the value was changed + # if the key already existed in map + ##} + , method insertChange : {Val} -> T Val -> + Key -> Val ->[] (Pair (T Val) Bool) + + {## @brief Method for removing key from the map + # @param Key which will be removed to the map + # @return Map with removed key + ##} + , method remove : {Val} -> T Val -> Key ->[] T Val + + {## @brief Method for removing key from the map + # @param Key which will be removed to the map + # @return Map with removed key + # and boolean value if the map was changed + ##} + , method removeChange : {Val} -> T Val -> + Key ->[] (Pair (T Val) Bool) + + {## @brief Method for checking if a given key is present in a map + ##} + , method member : {Val} -> T Val -> Key ->[] Bool + + {## @brief Method for getting value mapping from a key + # returns None if key is not found + ##} + , method find : {Val} -> T Val -> Key ->[] Option Val + + {## @brief Method for getting value mapping from a key, + # calls `~onError` if key is not found + ##} + , method findErr : + {Val, Err, ~onError : Unit ->[Err] Val} -> T Val -> Key ->[Err] Val + + {## @brief Method to update mapping on a key using a function + # @param key + # @param f is called with Option Val based on if the key has mapping + # in the input tree and should return Option Val to update the tree + # @return updated tree + ##} + , method update : {Val,E} -> T Val -> Key -> + (Option Val ->[E] Option Val) ->[E] T Val + + {## @brief Method to fold left through structure of map + # @param Function that receives key, value and accumulator + # @param Accumulator + # @return Result of applying function on keys + # and values of map and accumulator + ##} + , method foldl : {Val, type A,E} -> T Val -> + (Key -> Val -> A ->[E] A) -> A ->[E] A + + {## @brief Method to fold right through structure of map + # @param Function that receives key, value and accumulator + # @param Accumulator + # @return Result of applying function on keys + # and values of map and accumulator + ##} + , method foldr : {Val, type A,E} -> T Val -> + (Key -> Val -> A ->[E] A) -> A ->[E] A + + {## @brief Method that returns list of pairs (key,value) + ##} + , method toList : {Val} -> T Val ->[] List (Pair Key Val) + + {## @brief Method that returns list of values + ##} + , method toValueList : {Val} -> T Val ->[] List Val + + {## @brief Method that returns list of keys + ##} + , method domain : {Val} -> T Val ->[] List Key + + {## @brief Method that maps all values using given function + ##} + , method mapVal : {Val, type A, E} -> T Val -> + (Val ->[E] A) ->[E] T A + + {## @brief Method that maps all (key,value) in a map to (key, func key) + ##} + , method mapKey : {Val, type A,E} -> T Val -> + (Key ->[E] A) ->[E] T A + + {## @brief Method that applies function to every key and value + ##} + , method iter : {Val,E} -> T Val -> + (Key -> Val ->[E] Unit) ->[E] Unit + + {## @brief Method that joins two maps + # @param Function that resolves conflicts + # if maps have the same key + ##} + , method union : {Val,E} -> T Val -> T Val -> + (Key -> Val -> Val ->[E] Val) ->[E] T Val + + } -let node3RR l k1 v1 m k2 v2 r = - match r with - | RR_Ok r => - RR_Ok (Node3 l k1 v1 m k2 v2 r) - | RR_Underflow r => - match m with - | Node2 ml k v mr => - RR_Ok (Node2 l k1 v1 (Node3 ml k v mr k2 v2 r)) - | Node3 ml kl vl mm kr vr mr => - RR_Ok (Node3 l k1 v1 (Node2 ml kl vl mm) kr vr (Node2 mr k2 v2 r)) - end - end +#============================================================================== +# Ordered Map implementation +#============================================================================== -#------------------------------------------------------------------------------ -# Other auxiliary definitions. +parameter Key +parameter method compare : Key -> Key ->[] Ord -{# Non-empty heights of trees. +let keyComp (key : Key) (key', _) = key.compare key' -Auxiliary methods for removal need to know that the tree is non-empty, i.e., -they are represented by `Node Key Val Repr`. Since the methods in Fram are -attached to type variables at head position in the type of self, we cannot -overload them based on the type `Repr`. As a workaround, we define dummy types -to represent heights of non-empty trees, and define removal methods on -elements of these types. For instance, removing from tree of a height 1 -has type `H1 -> Node Key Val Leaf ->> _`, and removing from higher trees -has type `HS H -> Node Key Val (Node Key Val Repr) ->> _`, where `H` is the -height of `Node Key Val Repr`. #} +let isEmpty tree = + match tree with + | Leaf => True + | _ => False + end -data H1 = H1 -data HS H = HS of H +let sizeMap tree = size tree -{# Handler for resize effect, used to keep track of the size of the map. -Implemented as a standard state-like handler. #} +let insert tree (key : Key) val = + match search (keyComp key) tree [] with + | (Leaf, zipper) => zipRed (key,val) Leaf Leaf zipper + | ((Node {color, size, left, right}), zipper) => + zip (construct color size left (key,val) right) zipper + end -let hResize size = - handler effect d => fn size => resume () (size + d) - return tree => fn size => SizedTree { tree, size } - finally c => c size +let insert' tree (key : Key) val = + match search (keyComp key) tree [] with + | (Leaf, zipper) => (zipRed (key,val) Leaf Leaf zipper, False) + | (Node {color, size, left, right}, zipper) => + (zip (construct color size left (key,val) right) zipper, True) end -#============================================================================== -# popMin - -method popMin H1 (t : Node _ _ Leaf) = - match t with - | Node2 Leaf k1 v1 Leaf => - (k1, v1, RR_Underflow Leaf) - | Node3 Leaf k1 v1 Leaf k2 v2 Leaf => - (k1, v1, RR_Ok (Node2 Leaf k2 v2 Leaf)) +let remove tree (key : Key) = + match search (keyComp key) tree [] with + | (Leaf,_) => tree + | (Node {color, left, right}, zipper) => + delete color left right zipper end -method popMin - { Repr, H - , method popMin : H -> Node _ _ Repr ->[] Pair _ (RemResult _ _ Repr) - } (HS (ops : H)) (t : Node _ _ (Node _ _ Repr)) = - match t with - | Node2 l k1 v1 r => - let (kv, l) = ops.popMin l in - (kv, node2RL l k1 v1 r) - | Node3 l k1 v1 m k2 v2 r => - let (kv, l) = ops.popMin l in - (kv, node3RL l k1 v1 m k2 v2 r) +let remove' tree (key : Key) = + match search (keyComp key) tree [] with + | (Leaf,_) => (tree,False) + | (Node {color, left, right}, zipper) => + (delete color left right zipper, True) end -method rec popMin - { Repr, H - , method popMin : H -> Node _ _ Repr ->[] Pair _ (RemResult _ _ Repr) - } (t : Tree _ _ (Node _ _ Repr)) (ops : H) = - match t with - | Tree repr => - let (kv, repr) = ops.popMin repr in - (kv, repr.toTree) - | Succ tree => - let (kv, tree) = tree.popMin (HS ops) in - (kv, Succ tree) - end : Pair _ (Tree _ _ Repr) - -method popMin (SizedTree { tree, size }) = +let rec member tree (key : Key) = match tree with - | Tree Leaf => - assert (size == 0); - None - | Succ tree => - let (kv, tree) = tree.popMin H1 in - Some (kv, SizedTree { tree, size = size - 1 }) + | Leaf => False + | Node {left, value = (key',_), right} => + match key.compare key' with + | Lt => member left key + | Eq => True + | Gt => member right key + end end -method popMinErr {~onError} (sizedTree : SizedTree _ _) = - sizedTree.popMin.unwrapErr - -#============================================================================== -# Operations that depend on Key comparison - -section - parameter Key - parameter method equal : Key -> Key ->[] Bool - parameter method lt : Key -> Key ->[] Bool - - parameter E - parameter ~resize : Int ->[E] Unit - - #============================================================================ - # add - - method add Leaf k v = - ~resize 1; - AR_Split Leaf k v Leaf - - method add - { Repr - , method add : Repr -> Key -> _ ->> AddResult Key _ Repr - } (t : Node Key _ Repr) (k : Key) v = - match t with - | Node2 l k1 v1 r => - if k == k1 then - AR_Ok (Node2 l k v r) - else if k < k1 then - node2AL (l.add k v) k1 v1 r - else - node2AR l k1 v1 (r.add k v) - | Node3 l k1 v1 m k2 v2 r => - if k == k1 then - AR_Ok (Node3 l k v m k2 v2 r) - else if k < k1 then - node3AL (l.add k v) k1 v1 m k2 v2 r - else if k == k2 then - AR_Ok (Node3 l k1 v1 m k v r) - else if k < k2 then - node3AM l k1 v1 (m.add k v) k2 v2 r - else - node3AR l k1 v1 m k2 v2 (r.add k v) +let rec find tree (key : Key) = + match tree with + | Leaf => None + | Node {left, value = (key', val), right} => + match key.compare key' with + | Lt => find left key + | Eq => Some val + | Gt => find right key end + end - method rec add - { Repr - , method add : Repr -> Key -> _ ->> AddResult Key _ Repr - } - (t : Tree Key _ Repr) (k : Key) v = - match t with - | Tree repr => repr.add k v >.toTree - | Succ tree => Succ (tree.add k v) - end : Tree Key _ Repr - - method add (SizedTree { tree, size }) (k : Key) v = - handle ~resize with hResize size in - tree.add k v - - #============================================================================ - # remove - - method remove H1 (t : Node Key _ Leaf) (k : Key) = - match t with - | Node2 Leaf k1 v1 Leaf => - if k == k1 then - (~resize (-1); RR_Underflow Leaf) - else - RR_Ok t - | Node3 Leaf k1 v1 Leaf k2 v2 Leaf => - if k == k1 then - (~resize (-1); RR_Ok (Node2 Leaf k2 v2 Leaf)) - else if k == k2 then - (~resize (-1); RR_Ok (Node2 Leaf k1 v1 Leaf)) - else - RR_Ok t +let rec findErr tree (key : Key) = + match tree with + | Leaf => ~onError () + | Node {left, value = (key', val), right} => + match key.compare key' with + | Lt => findErr left key + | Eq => val + | Gt => findErr right key end + end - method remove - { Repr, H - , method remove : H -> Node Key _ Repr -> Key ->> RemResult Key _ Repr - , method popMin : - H -> Node Key _ Repr ->[] - Pair (Pair Key _) (RemResult Key _ Repr) - } (HS (ops : H)) (t : Node Key _ (Node Key _ Repr)) (k : Key) = - match t with - | Node2 l k1 v1 r => - if k == k1 then ( - ~resize (-1); - let (k1, v1, r) = ops.popMin r in - node2RR l k1 v1 r) - else if k < k1 then - node2RL (ops.remove l k) k1 v1 r - else - node2RR l k1 v1 (ops.remove r k) - | Node3 l k1 v1 m k2 v2 r => - if k == k1 then ( - ~resize (-1); - let (k1, v1, m) = ops.popMin m in - node3RM l k1 v1 m k2 v2 r) - else if k < k1 then - node3RL (ops.remove l k) k1 v1 m k2 v2 r - else if k == k2 then ( - ~resize (-1); - let (k2, v2, r) = ops.popMin r in - node3RR l k1 v1 m k2 v2 r) - else if k < k2 then - node3RM l k1 v1 (ops.remove m k) k2 v2 r - else - node3RR l k1 v1 m k2 v2 (ops.remove r k) +let update tree (key : Key) f = + match search (keyComp key) tree [] with + | (Leaf, zipper) => + match f None with + | None => tree + | Some x => zipRed (key,x) Leaf Leaf zipper end - - method rec remove - { Repr, H - , method remove : H -> Node Key _ Repr -> Key ->> RemResult Key _ Repr - , method popMin : - H -> Node Key _ Repr ->[] - Pair (Pair Key _) (RemResult Key _ Repr) - } - (t : Tree Key _ (Node Key _ Repr)) (ops : H) (k : Key) = - match t with - | Tree repr => ops.remove repr k >.toTree - | Succ tree => Succ (tree.remove (HS ops) k) - end : Tree Key _ Repr - - method remove (SizedTree { tree, size }) (k : Key) = - match tree with - | Tree Leaf => - assert (size == 0); - empty - | Succ tree => - handle ~resize with hResize size in - tree.remove H1 k + | (Node {color, size, left, value = (_, val), right}, zipper) => + match f (Some val) with + | None => delete color left right zipper + | Some x => zip (construct color size left (key,x) right) zipper end + end - #============================================================================ - # find - - method find Leaf k = None - - method find - { Repr - , method find : Repr -> Key ->[] Option _ - } (t : Node Key _ Repr) (k : Key) = - match t with - | Node2 l k1 v1 r => - if k == k1 then - Some v1 - else if k < k1 then - l.find k - else - r.find k - | Node3 l k1 v1 m k2 v2 r => - if k == k1 then - Some v1 - else if k < k1 then - l.find k - else if k == k2 then - Some v2 - else if k < k2 then - m.find k - else - r.find k - end +let rec foldr func tree acc = + match tree with + | Leaf => acc + | Node {left, value = (key, val), right} => + let val_right = foldr func right acc + let val_middle = func key val val_right in + foldr func left val_middle + end - method rec find - { Repr - , method find : Repr -> Key ->[] Option _ - } (t : Tree Key _ Repr) (k : Key) = - match t with - | Tree repr => repr.find k - | Succ tree => tree.find k - end +let rec foldl func tree acc = + match tree with + | Leaf => acc + | Node {left, value = (key, val), right} => + let val_left = foldl func left acc + let val_middle = func key val val_left in + foldl func right val_middle + end + +let rec map tree func = + match tree with + | Leaf => Leaf + | Node {color, size, left, value = (key,value), right} => + let left' = map left func + let right' = map right func in + construct color size left' (key,func value) right' + end - method find (SizedTree { tree }) (k : Key) = - tree.find k +let rec map2 tree func = + match tree with + | Leaf => Leaf + | Node {color, size, left, value = (key, _), right} => + let left' = map2 left func + let right' = map2 right func in + construct color size left' (key, func key) right' + end - method findErr {~onError} (SizedTree { tree }) (k : Key) = - tree.find k >.unwrapErr +let rec iter tree func = + match tree with + | Leaf => () + | Node {left, value = (key,value), right} => + iter left func; + func key value; + iter right func + end - method mem (SizedTree { tree }) (k : Key) = - match tree.find k with - | Some _ => True - | None => False +let rec union (tree1 : Tree (Pair Key _)) tree2 merge = + match tree1 with + | Leaf => tree2 + | Node {left = left1, value = (key1,value1), right = right1} => + match tree2 with + | Leaf => tree1 + | _ => + let (output,left2,right2) = split (keyComp key1) tree2 + let new_pair = + match output with + | None => (key1,value1) + | Some (_,value2) => (key1, merge key1 value1 value2) + end + let left' = union left1 left2 merge + let right' = union right1 right2 merge in + joinVal left' new_pair right' end -end - -#============================================================================== -# map - -method map Leaf (f : {key} -> _) = Leaf - -method map - { ReprA, ReprB - , method map : ReprA -> ({key} -> _) ->> ReprB - } (t : Node _ _ ReprA) (f : {key} -> _) = - match t with - | Node2 l k v r => - Node2 (l.map f) k (f {key=k} v) (r.map f) - | Node3 l k1 v1 m k2 v2 r => - Node3 (l.map f) k1 (f {key=k1} v1) (m.map f) k2 (f {key=k2} v2) (r.map f) end -method rec map - { ReprA, ReprB - , method map : ReprA -> ({key} -> _) ->> ReprB - } (t : Tree _ _ ReprA) (f : {key} -> _) = - match t with - | Tree repr => Tree (repr.map f) - | Succ tree => Succ (tree.map f) - end : Tree _ _ ReprB +let toList tree = foldr (fn key value acc => (key, value) :: acc) tree [] + +let toValueList tree = foldr (fn key value acc => value :: acc) tree [] -method map (SizedTree { tree, size }) (f : {key} -> _) = - SizedTree { tree = tree.map f, size } +let domain tree = foldr (fn key value acc => key :: acc) tree [] + +data MapT Key Val = MapT of Tree (Pair Key Val) #============================================================================== -# fold - -method fold Leaf (f : {key} -> _) acc = acc - -method fold - { Repr - , method fold : Repr -> ({key} -> _) ->> _ - } (t : Node _ _ Repr) (f : {key} -> _) acc = - match t with - | Node2 l k1 v1 r => - let acc = l.fold f acc - let acc = f {key=k1} v1 acc - in - r.fold f acc - | Node3 l k1 v1 m k2 v2 r => - let acc = l.fold f acc - let acc = f {key=k1} v1 acc - let acc = m.fold f acc - let acc = f {key=k2} v2 acc - in - r.fold f acc - end +# Wrappers +#============================================================================== -method rec fold - { Repr - , method fold : Repr -> ({key} -> _) ->> _ - } (t : Tree _ _ Repr) (f : {key} -> _) acc = - match t with - | Tree repr => repr.fold f acc - | Succ tree => tree.fold f acc - end +let isEmptyT (MapT tree) = isEmpty tree -method fold (SizedTree { tree }) (f : {key} -> _) acc = - tree.fold f acc +let sizeMapT (MapT tree) = sizeMap tree -#============================================================================== -# iter +let insertT (MapT tree) (key : Key) val = MapT (insert tree key val) + +let insertChangeT (MapT tree) (key : Key) val = + let (tree,bool) = insert' tree key val in (MapT tree, bool) + +let removeT (MapT tree) (key : Key) = MapT (remove tree key) + +let removeChangeT (MapT tree) (key : Key) = + let (tree,bool) = remove' tree key in (MapT tree, bool) + +let memberT (MapT tree) (key : Key) = member tree key + +let findT (MapT tree) (key : Key) = find tree key + +let findErrT (MapT tree) (key : Key) = findErr tree key + +let updateT (MapT tree) (key : Key) f = MapT (update tree key f) -method iter (SizedTree { tree }) (f : {key} -> _) = - tree.fold (fn {key} v () => f {key} v) () +let mapFoldl (MapT tree) func acc = foldl func tree acc +let mapFoldr (MapT tree) func acc = foldr func tree acc + +let toListT (MapT tree) = toList tree + +let toValueListT (MapT tree) = toValueList tree + +let domainT (MapT tree) = domain tree + +let mapVal (MapT tree) func = MapT (map tree func) + +let mapKey (MapT tree) func = MapT (map2 tree func) + +let iterT (MapT tree) func = iter tree func + +let unionT (MapT (tree1 : (Tree (Pair Key _)))) (MapT tree2) merge = + MapT (union tree1 tree2 merge) + +#============================================================================== +# Ordered Map constructor #============================================================================== -{## Functor to create a map type with operations for a given key type. ##} -pub let make - { Key - , method equal : Key -> Key ->[] Bool - , method lt : Key -> Key ->[] Bool - } = - Map { Key, empty, singleton } +pub let make {Key, method compare : Key -> Key ->[] Ord} = Map { + T = MapT Key + , empty = MapT Leaf + , method isEmpty = isEmptyT + , method size = sizeMapT + , method insert = insertT + , method insertChange = insertChangeT + , method remove = removeT + , method removeChange = removeChangeT + , method member = memberT + , method find = findT + , method findErr = fn {~onError} => findErrT + , method update = updateT + , method foldl = mapFoldl + , method foldr = mapFoldr + , method toList = toListT + , method toValueList = toValueListT + , method domain = domainT + , method mapVal = mapVal + , method mapKey = mapKey + , method iter = iterT + , method union = unionT +} + +# Papers to read: +# A dichromatic framework for balanced trees. Leo J. Guibas; Robert Sedgewick +# DOI: 10.1109/SFCS.1978.3 +# Efficient implementation of red-black trees with split and catenate operations. +# Ron Wein +# Updating a balanced search tree in O(1) rotations. Robert Tarjan +# DOI: 10.1016/0020-0190(83)90099-6 +# Similar implementation: +# https://github.com/standardml/cmlib/blob/master/red-black-tree.sml diff --git a/lib/Testing.fram b/lib/Testing.fram index b1a5b6b9..41ed47a9 100644 --- a/lib/Testing.fram +++ b/lib/Testing.fram @@ -148,7 +148,8 @@ let mkTestCase # TestCase tree # Organizes all registered tests into a tree structure -let Map {module SMap} = Map.make {Key=String} + +let Map {module SMap} = Map.make {String} type NestedCase = Pair String TestCase @@ -162,7 +163,7 @@ method addTest (tree : TestTree) (test : TestCase) = | [] => TestTree {tests = (name, test) :: tests, suites} | ns :: path => let sub = suites.find ns >.unwrapOr emptyTestTree in - TestTree {tests, suites = suites.add ns (visit sub path)} + TestTree {tests, suites = suites.insert ns (visit sub path)} end in visit tree path @@ -178,7 +179,7 @@ method iter let rec iter (tree : TestTree) (nesting : Int) = let nesting = nesting + 1 in tree.tests.iter (fn tc => f {nesting} (Right tc)); - tree.suites.iter (fn {key} suite => f {nesting} (Left key); + tree.suites.iter (fn key suite => f {nesting} (Left key); iter suite nesting) in iter tree (-1) diff --git a/test/stdlib/Map.fram b/test/stdlib/Map.fram index 80995ad8..19586dcb 100644 --- a/test/stdlib/Map.fram +++ b/test/stdlib/Map.fram @@ -1,27 +1,43 @@ -import open Testing import /Map +import open /String +import open Testing -let (Map { module IntMap }) = Map.make { Key = Int } -let (Map { module StrMap }) = Map.make { Key = String } +# let compareI (x : Int) (y : Int) = if x < y then Lt else if x > y then Gt else Eq +# let compareS (x : String) (y : String) = if x < y then Lt else if x > y then Gt else Eq + +let (Map { module IntMap }) = Map.make {Key = Int} +let (Map { module StrMap }) = Map.make {Key = String} let (Map { module IntMap2 }) = - Map.make { Key = Int, method lt = fn x y => x > y } + Map.make {Key = Int, method compare = fn (x : Int) (y : Int) => if x > y then Lt else if x < y then Gt else Eq} let _ = -testSuite "isEmpty" (fn _ => - testCase "true" (fn _ => - assertTrue (IntMap.empty {Val=Bool} >.isEmpty)); - - testCase "false" (fn _ => - assertFalse (IntMap.singleton 13 "A" >.isEmpty))); - -testSuite "size" (fn _ => - testCase "empty" (fn _ => - assertEq (IntMap.empty {Val=Int} >.size) 0); - - testCase "not empty" (fn _ => - assertEq (IntMap.singleton 42 True >.size) 1)); - -testCase "randomized test" (fn _ => +testSuite "Basic tests" (fn _ => + testCase "isEmpty" (fn _ => assertTrue ((IntMap.empty {Val = Bool} ) >.isEmpty)); + testCase "Size of empty equals 0" (fn _ => assertEq (IntMap.empty {Val = Int} >.size) 0); + testCase "None empty map is not empty" (fn _ => assertFalse (IntMap.empty >.insert 13 "A" >.isEmpty)); + testCase "None empty maps has size greater than 0" (fn _ => assertEq (IntMap.empty >.insert 42 True >.size) 1); + let x = IntMap.empty in let y = x.insert 1 1 in let z = x.insert 1 "a" in + let z = y.insert 2 1 >. insert 3 2 >. insert 4 3 in + testCase "isEmpty after removal" (fn _ => assertTrue (y.remove 1 >. isEmpty)); + testCase "domain" (fn _ => assertEq z.domain [1,2,3,4]); + testCase "toValueList" (fn _ => assertEq z.toValueList [1,1,2,3]); + testCase "toList > foldLeft" (fn _ => assertEq + (z.toList.foldLeft (fn acc (key,val) => val :: acc) []) ([1,1,2,3].rev)); + testCase "foldl" (fn _ => assertEq (z.foldl (fn key val acc => key :: acc) []) [1,2,3,4].rev); + testCase "member" (fn _ => assertTrue (z.member 1)); + testCase "find" (fn _ => assertTrue (match z.find 1 with | None => False | _ => True end)); + testCase "update" (fn _ => assertEq (let f a = match a with + | None => Some 2 | Some _ => Some 0 end in z.update 1 f >. toValueList) [0,1,2,3]); + testCase "update on nonexisting element" (fn _ => assertEq (let f a = match a with | None => Some 2 + | Some _ => Some 0 end in z.update 0 f >. toValueList) [2,1,1,2,3]); + testCase "mapVal" (fn _ => assertEq (z.mapVal (fn x => if x == x.shiftr 1 >. shiftl 1 then -x else x) + >. toValueList) [1,1,(0-2),3]); + testCase "union" (fn _ => + let y = x.insert 1.neg 2 >. insert 2.neg 3 >. insert 0 1 >. insert 1 10 in + let w = z.union y (fn key val1 val2 => val2) in + assertEq w.toValueList [3,2,1,10,1,2,3])); +testSuite "Randomized test" (fn _ => + testCase "randomized test" (fn _ => handle rand = effect () => fn seed => let seed = (seed * 39989 + 7) % 65536 in @@ -30,9 +46,9 @@ testCase "randomized test" (fn _ => finally c => c 0 let doExtraTest (map : IntMap.T Int) (bitSet : Int) (bitMap : Int) = - assertEq (map.fold (fn _ acc => acc + 1) 0) map.size; - let rest = map.fold - (fn {key} v bitSet => + assertEq (map.foldl (fn _ _ acc => acc + 1) 0) map.size; + let rest = map.foldl + (fn key v bitSet => let bit = 1 << key in assertTrue ((bitSet &&& bit) != 0); assertEq v (key + (bitMap &&& bit)); @@ -52,21 +68,21 @@ testCase "randomized test" (fn _ => let bit = 1 << key in if (bitSet &&& bit) == 0 then ( - assertFalse (map.mem key); + assertFalse (map.member key); assertEq (map.find key >.unwrapOr (-1)) (-1); assertEq (map.findErr {~onError = fn () => -1} key) (-1)) else ( - assertTrue (map.mem key); + assertTrue (map.member key); assertEq (map.find key >.unwrapOr (-1)) (key + (bitMap &&& bit)); assertEq (map.findErr {~onError = fn () => -1} key) (key + (bitMap &&& bit))); if op < 8 then ( let v = if op < 4 then 0 else bit - let map = map.add key (key + v) + let map = map.insert key (key + v) let bitSet = bitSet ||| bit let bitMap = bitMap ^^^ (bitMap &&& bit) ^^^ v in - assertTrue (map.mem key); + assertTrue (map.member key); assertEq (map.find key >.unwrapOr (-1)) (key + v); assertEq (map.findErr {~onError = fn () => -1} key) (key + v); randTest map bitSet bitMap (n - 1)) @@ -74,10 +90,11 @@ testCase "randomized test" (fn _ => let map = map.remove key let bitSet = bitSet ^^^ (bitSet &&& bit) in - assertFalse (map.mem key); + assertFalse (map.member key); assertEq (map.find key >.unwrapOr (-1)) (-1); assertEq (map.findErr {~onError = fn () => -1} key) (-1); randTest map bitSet bitMap (n - 1)) ) in randTest IntMap.empty 0 0 1000) +)