From 00c5bad77dda7e204642976e67da536f82f0cbcf Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 1 May 2018 21:51:02 -0400 Subject: - Re-organized dict modules. --- stdlib/source/lux/data/coll/dict.lux | 685 ---------------------- stdlib/source/lux/data/coll/dict/ordered.lux | 563 ++++++++++++++++++ stdlib/source/lux/data/coll/dict/unordered.lux | 685 ++++++++++++++++++++++ stdlib/source/lux/data/coll/ordered/dict.lux | 563 ------------------ stdlib/source/lux/data/coll/set/ordered.lux | 2 +- stdlib/source/lux/data/coll/set/unordered.lux | 12 +- stdlib/source/lux/data/format/context.lux | 6 +- stdlib/source/lux/data/format/json.lux | 2 +- stdlib/source/lux/data/format/xml.lux | 12 +- stdlib/source/lux/lang/syntax.lux | 4 +- stdlib/source/lux/macro/poly.lux | 2 +- stdlib/source/lux/macro/poly/eq.lux | 2 +- stdlib/source/lux/macro/poly/json.lux | 2 +- stdlib/source/lux/math/random.lux | 2 +- stdlib/source/lux/type/implicit.lux | 4 +- stdlib/source/lux/type/resource.lux | 2 +- stdlib/source/lux/world/env.jvm.lux | 2 +- stdlib/test/test/lux/data/coll/dict.lux | 128 ---- stdlib/test/test/lux/data/coll/dict/ordered.lux | 88 +++ stdlib/test/test/lux/data/coll/dict/unordered.lux | 128 ++++ stdlib/test/test/lux/data/coll/ordered/dict.lux | 88 --- stdlib/test/test/lux/data/format/json.lux | 2 +- stdlib/test/test/lux/data/format/xml.lux | 6 +- stdlib/test/test/lux/lang/syntax.lux | 2 +- stdlib/test/test/lux/math/random.lux | 2 +- stdlib/test/tests.lux | 6 +- 26 files changed, 1500 insertions(+), 1500 deletions(-) delete mode 100644 stdlib/source/lux/data/coll/dict.lux create mode 100644 stdlib/source/lux/data/coll/dict/ordered.lux create mode 100644 stdlib/source/lux/data/coll/dict/unordered.lux delete mode 100644 stdlib/source/lux/data/coll/ordered/dict.lux delete mode 100644 stdlib/test/test/lux/data/coll/dict.lux create mode 100644 stdlib/test/test/lux/data/coll/dict/ordered.lux create mode 100644 stdlib/test/test/lux/data/coll/dict/unordered.lux delete mode 100644 stdlib/test/test/lux/data/coll/ordered/dict.lux (limited to 'stdlib') diff --git a/stdlib/source/lux/data/coll/dict.lux b/stdlib/source/lux/data/coll/dict.lux deleted file mode 100644 index 97a119755..000000000 --- a/stdlib/source/lux/data/coll/dict.lux +++ /dev/null @@ -1,685 +0,0 @@ -(.module: - lux - (lux (control hash - [eq #+ Eq]) - (data [maybe] - (coll [list "list/" Fold Functor Monoid] - [array "array/" Functor Fold]) - [bit] - [product] - [number]) - )) - -## This implementation of Hash Array Mapped Trie (HAMT) is based on -## Clojure's PersistentHashMap implementation. -## That one is further based on Phil Bagwell's Hash Array Mapped Trie. - -## [Utils] -## Bitmaps are used to figure out which branches on a #Base node are -## populated. The number of bits that are 1s in a bitmap signal the -## size of the #Base node. -(type: BitMap Nat) - -## Represents the position of a node in a BitMap. -## It's meant to be a single bit set on a 32-bit word. -## The position of the bit reflects whether an entry in an analogous -## position exists within a #Base, as reflected in it's BitMap. -(type: BitPosition Nat) - -## An index into an array. -(type: Index Nat) - -## A hash-code derived from a key during tree-traversal. -(type: Hash-Code Nat) - -## Represents the nesting level of a leaf or node, when looking-it-up -## while exploring the tree. -## Changes in levels are done by right-shifting the hashes of keys by -## the appropriate multiple of the branching-exponent. -## A shift of 0 means root level. -## A shift of (* branching-exponent 1) means level 2. -## A shift of (* branching-exponent N) means level N+1. -(type: Level Nat) - -## Nodes for the tree data-structure that organizes the data inside -## Dicts. -(type: (Node k v) - (#Hierarchy Nat (Array (Node k v))) - (#Base BitMap - (Array (Either (Node k v) - [k v]))) - (#Collisions Hash-Code (Array [k v]))) - -## #Hierarchy nodes are meant to point down only to lower-level nodes. -(type: (Hierarchy k v) - [Nat (Array (Node k v))]) - -## #Base nodes may point down to other nodes, but also to leaves, -## which are KV-pairs. -(type: (Base k v) - (Array (Either (Node k v) - [k v]))) - -## #Collisions are collections of KV-pairs for which the key is -## different on each case, but their hashes are all the same (thus -## causing a collision). -(type: (Collisions k v) - (Array [k v])) - -## That bitmap for an empty #Base is 0. -## Which is the same as 0000 0000 0000 0000 0000 0000 0000 0000. -## Or 0x00000000. -## Which is 32 zeroes, since the branching factor is 32. -(def: clean-bitmap - BitMap - +0) - -## Bitmap position (while looking inside #Base nodes) is determined by -## getting 5 bits from a hash of the key being looked up and using -## them as an index into the array inside #Base. -## Since the data-structure can have multiple levels (and the hash has -## more than 5 bits), the binary-representation of the hash is shifted -## by 5 positions on each step (2^5 = 32, which is the branching -## factor). -## The initial shifting level, though, is 0 (which corresponds to the -## shift in the shallowest node on the tree, which is the root node). -(def: root-level - Level - +0) - -## The exponent to which 2 must be elevated, to reach the branching -## factor of the data-structure. -(def: branching-exponent - Nat - +5) - -## The threshold on which #Hierarchy nodes are demoted to #Base nodes, -## which is 1/4 of the branching factor (or a left-shift 2). -(def: demotion-threshold - Nat - (bit.shift-left (n/- +2 branching-exponent) +1)) - -## The threshold on which #Base nodes are promoted to #Hierarchy nodes, -## which is 1/2 of the branching factor (or a left-shift 1). -(def: promotion-threshold - Nat - (bit.shift-left (n/- +1 branching-exponent) +1)) - -## The size of hierarchy-nodes, which is 2^(branching-exponent). -(def: hierarchy-nodes-size - Nat - (bit.shift-left branching-exponent +1)) - -## The cannonical empty node, which is just an empty #Base node. -(def: empty - Node - (#Base clean-bitmap (array.new +0))) - -## Expands a copy of the array, to have 1 extra slot, which is used -## for storing the value. -(def: (insert! idx value old-array) - (All [a] (-> Index a (Array a) (Array a))) - (let [old-size (array.size old-array)] - (|> (array.new (n/inc old-size)) - (array.copy idx +0 old-array +0) - (array.write idx value) - (array.copy (n/- idx old-size) idx old-array (n/inc idx))))) - -## Creates a copy of an array with an index set to a particular value. -(def: (update! idx value array) - (All [a] (-> Index a (Array a) (Array a))) - (|> array array.clone (array.write idx value))) - -## Creates a clone of the array, with an empty position at index. -(def: (vacant! idx array) - (All [a] (-> Index (Array a) (Array a))) - (|> array array.clone (array.delete idx))) - -## Shrinks a copy of the array by removing the space at index. -(def: (remove! idx array) - (All [a] (-> Index (Array a) (Array a))) - (let [new-size (n/dec (array.size array))] - (|> (array.new new-size) - (array.copy idx +0 array +0) - (array.copy (n/- idx new-size) (n/inc idx) array idx)))) - -## Given a top-limit for indices, produces all indices in [0, R). -(def: indices-for - (-> Nat (List Index)) - (|>> n/dec (list.n/range +0))) - -## Increases the level-shift by the branching-exponent, to explore -## levels further down the tree. -(def: level-up - (-> Level Level) - (n/+ branching-exponent)) - -(def: hierarchy-mask BitMap (n/dec hierarchy-nodes-size)) - -## Gets the branching-factor sized section of the hash corresponding -## to a particular level, and uses that as an index into the array. -(def: (level-index level hash) - (-> Level Hash-Code Index) - (bit.and hierarchy-mask - (bit.shift-right level hash))) - -## A mechanism to go from indices to bit-positions. -(def: (->bit-position index) - (-> Index BitPosition) - (bit.shift-left index +1)) - -## The bit-position within a base that a given hash-code would have. -(def: (bit-position level hash) - (-> Level Hash-Code BitPosition) - (->bit-position (level-index level hash))) - -(def: (bit-position-is-set? bit bitmap) - (-> BitPosition BitMap Bool) - (not (n/= clean-bitmap (bit.and bit bitmap)))) - -## Figures out whether a bitmap only contains a single bit-position. -(def: only-bit-position? - (-> BitPosition BitMap Bool) - n/=) - -(def: (set-bit-position bit bitmap) - (-> BitPosition BitMap BitMap) - (bit.or bit bitmap)) - -(def: unset-bit-position - (-> BitPosition BitMap BitMap) - bit.xor) - -## Figures out the size of a bitmap-indexed array by counting all the -## 1s within the bitmap. -(def: bitmap-size - (-> BitMap Nat) - bit.count) - -## A mask that, for a given bit position, only allows all the 1s prior -## to it, which would indicate the bitmap-size (and, thus, index) -## associated with it. -(def: bit-position-mask - (-> BitPosition BitMap) - n/dec) - -## The index on the base array, based on it's bit-position. -(def: (base-index bit-position bitmap) - (-> BitPosition BitMap Index) - (bitmap-size (bit.and (bit-position-mask bit-position) - bitmap))) - -## Produces the index of a KV-pair within a #Collisions node. -(def: (collision-index Hash key colls) - (All [k v] (-> (Hash k) k (Collisions k v) (Maybe Index))) - (:: maybe.Monad map product.left - (array.find+ (function (_ idx [key' val']) - (:: Hash = key key')) - colls))) - -## When #Hierarchy nodes grow too small, they're demoted to #Base -## nodes to save space. -(def: (demote-hierarchy except-idx [h-size h-array]) - (All [k v] (-> Index (Hierarchy k v) [BitMap (Base k v)])) - (product.right (list/fold (function (_ idx [insertion-idx node]) - (let [[bitmap base] node] - (case (array.read idx h-array) - #.None [insertion-idx node] - (#.Some sub-node) (if (n/= except-idx idx) - [insertion-idx node] - [(n/inc insertion-idx) - [(set-bit-position (->bit-position idx) bitmap) - (array.write insertion-idx (#.Left sub-node) base)]]) - ))) - [+0 [clean-bitmap - (array.new (n/dec h-size))]] - (list.indices (array.size h-array))))) - -## When #Base nodes grow too large, they're promoted to #Hierarchy to -## add some depth to the tree and help keep it's balance. -(def: hierarchy-indices (List Index) (indices-for hierarchy-nodes-size)) - -(def: (promote-base put' Hash level bitmap base) - (All [k v] - (-> (-> Level Hash-Code k v (Hash k) (Node k v) (Node k v)) - (Hash k) Level - BitMap (Base k v) - (Array (Node k v)))) - (product.right (list/fold (function (_ hierarchy-idx (^@ default [base-idx h-array])) - (if (bit-position-is-set? (->bit-position hierarchy-idx) - bitmap) - [(n/inc base-idx) - (case (array.read base-idx base) - (#.Some (#.Left sub-node)) - (array.write hierarchy-idx sub-node h-array) - - (#.Some (#.Right [key' val'])) - (array.write hierarchy-idx - (put' (level-up level) (:: Hash hash key') key' val' Hash empty) - h-array) - - #.None - (undefined))] - default)) - [+0 - (array.new hierarchy-nodes-size)] - hierarchy-indices))) - -## All empty nodes look the same (a #Base node with clean bitmap is -## used). -## So, this test is introduced to detect them. -(def: (empty?' node) - (All [k v] (-> (Node k v) Bool)) - (case node - (^~ (#Base ..clean-bitmap _)) - true - - _ - false)) - -(def: (put' level hash key val Hash node) - (All [k v] (-> Level Hash-Code k v (Hash k) (Node k v) (Node k v))) - (case node - ## For #Hierarchy nodes, I check whether I can add the element to - ## a sub-node. If impossible, I introduced a new singleton sub-node. - (#Hierarchy _size hierarchy) - (let [idx (level-index level hash) - [_size' sub-node] (case (array.read idx hierarchy) - (#.Some sub-node) - [_size sub-node] - - _ - [(n/inc _size) empty])] - (#Hierarchy _size' - (update! idx (put' (level-up level) hash key val Hash sub-node) - hierarchy))) - - ## For #Base nodes, I check if the corresponding BitPosition has - ## already been used. - (#Base bitmap base) - (let [bit (bit-position level hash)] - (if (bit-position-is-set? bit bitmap) - ## If so... - (let [idx (base-index bit bitmap)] - (case (array.read idx base) - #.None - (undefined) - - ## If it's being used by a node, I add the KV to it. - (#.Some (#.Left sub-node)) - (let [sub-node' (put' (level-up level) hash key val Hash sub-node)] - (#Base bitmap (update! idx (#.Left sub-node') base))) - - ## Otherwise, if it's being used by a KV, I compare the keys. - (#.Some (#.Right key' val')) - (if (:: Hash = key key') - ## If the same key is found, I replace the value. - (#Base bitmap (update! idx (#.Right key val) base)) - ## Otherwise, I compare the hashes of the keys. - (#Base bitmap (update! idx - (#.Left (let [hash' (:: Hash hash key')] - (if (n/= hash hash') - ## If the hashes are - ## the same, a new - ## #Collisions node - ## is added. - (#Collisions hash (|> (array.new +2) - (array.write +0 [key' val']) - (array.write +1 [key val]))) - ## Otherwise, I can - ## just keep using - ## #Base nodes, so I - ## add both KV-pairs - ## to the empty one. - (let [next-level (level-up level)] - (|> empty - (put' next-level hash' key' val' Hash) - (put' next-level hash key val Hash)))))) - base))))) - ## However, if the BitPosition has not been used yet, I check - ## whether this #Base node is ready for a promotion. - (let [base-count (bitmap-size bitmap)] - (if (n/>= promotion-threshold base-count) - ## If so, I promote it to a #Hierarchy node, and add the new - ## KV-pair as a singleton node to it. - (#Hierarchy (n/inc base-count) - (|> (promote-base put' Hash level bitmap base) - (array.write (level-index level hash) - (put' (level-up level) hash key val Hash empty)))) - ## Otherwise, I just resize the #Base node to accommodate the - ## new KV-pair. - (#Base (set-bit-position bit bitmap) - (insert! (base-index bit bitmap) (#.Right [key val]) base)))))) - - ## For #Collisions nodes, I compare the hashes. - (#Collisions _hash _colls) - (if (n/= hash _hash) - ## If they're equal, that means the new KV contributes to the - ## collisions. - (case (collision-index Hash key _colls) - ## If the key was already present in the collisions-list, it's - ## value gets updated. - (#.Some coll-idx) - (#Collisions _hash (update! coll-idx [key val] _colls)) - - ## Otherwise, the KV-pair is added to the collisions-list. - #.None - (#Collisions _hash (insert! (array.size _colls) [key val] _colls))) - ## If the hashes are not equal, I create a new #Base node that - ## contains the old #Collisions node, plus the new KV-pair. - (|> (#Base (bit-position level _hash) - (|> (array.new +1) - (array.write +0 (#.Left node)))) - (put' level hash key val Hash))) - )) - -(def: (remove' level hash key Hash node) - (All [k v] (-> Level Hash-Code k (Hash k) (Node k v) (Node k v))) - (case node - ## For #Hierarchy nodes, find out if there's a valid sub-node for - ## the Hash-Code. - (#Hierarchy h-size h-array) - (let [idx (level-index level hash)] - (case (array.read idx h-array) - ## If not, there's nothing to remove. - #.None - node - - ## But if there is, try to remove the key from the sub-node. - (#.Some sub-node) - (let [sub-node' (remove' (level-up level) hash key Hash sub-node)] - ## Then check if a removal was actually done. - (if (is? sub-node sub-node') - ## If not, then there's nothing to change here either. - node - ## But if the sub-removal yielded an empty sub-node... - (if (empty?' sub-node') - ## Check if it's due time for a demotion. - (if (n/<= demotion-threshold h-size) - ## If so, perform it. - (#Base (demote-hierarchy idx [h-size h-array])) - ## Otherwise, just clear the space. - (#Hierarchy (n/dec h-size) (vacant! idx h-array))) - ## But if the sub-removal yielded a non-empty node, then - ## just update the hiearchy branch. - (#Hierarchy h-size (update! idx sub-node' h-array))))))) - - ## For #Base nodes, check whether the BitPosition is set. - (#Base bitmap base) - (let [bit (bit-position level hash)] - (if (bit-position-is-set? bit bitmap) - (let [idx (base-index bit bitmap)] - (case (array.read idx base) - #.None - (undefined) - - ## If set, check if it's a sub-node, and remove the KV - ## from it. - (#.Some (#.Left sub-node)) - (let [sub-node' (remove' (level-up level) hash key Hash sub-node)] - ## Verify that it was removed. - (if (is? sub-node sub-node') - ## If not, there's also nothing to change here. - node - ## But if it came out empty... - (if (empty?' sub-node') - ### ... figure out whether that's the only position left. - (if (only-bit-position? bit bitmap) - ## If so, removing it leaves this node empty too. - empty - ## But if not, then just unset the position and - ## remove the node. - (#Base (unset-bit-position bit bitmap) - (remove! idx base))) - ## But, if it did not come out empty, then the - ## position is kept, and the node gets updated. - (#Base bitmap - (update! idx (#.Left sub-node') base))))) - - ## If, however, there was a KV-pair instead of a sub-node. - (#.Some (#.Right [key' val'])) - ## Check if the keys match. - (if (:: Hash = key key') - ## If so, remove the KV-pair and unset the BitPosition. - (#Base (unset-bit-position bit bitmap) - (remove! idx base)) - ## Otherwise, there's nothing to remove. - node))) - ## If the BitPosition is not set, there's nothing to remove. - node)) - - ## For #Collisions nodes, It need to find out if the key already existst. - (#Collisions _hash _colls) - (case (collision-index Hash key _colls) - ## If not, then there's nothing to remove. - #.None - node - - ## But if so, then check the size of the collisions list. - (#.Some idx) - (if (n/= +1 (array.size _colls)) - ## If there's only one left, then removing it leaves us with - ## an empty node. - empty - ## Otherwise, just shrink the array by removing the KV-pair. - (#Collisions _hash (remove! idx _colls)))) - )) - -(def: (get' level hash key Hash node) - (All [k v] (-> Level Hash-Code k (Hash k) (Node k v) (Maybe v))) - (case node - ## For #Hierarchy nodes, just look-up the key on its children. - (#Hierarchy _size hierarchy) - (case (array.read (level-index level hash) hierarchy) - #.None #.None - (#.Some sub-node) (get' (level-up level) hash key Hash sub-node)) - - ## For #Base nodes, check the leaves, and recursively check the branches. - (#Base bitmap base) - (let [bit (bit-position level hash)] - (if (bit-position-is-set? bit bitmap) - (case (array.read (base-index bit bitmap) base) - #.None - (undefined) - - (#.Some (#.Left sub-node)) - (get' (level-up level) hash key Hash sub-node) - - (#.Some (#.Right [key' val'])) - (if (:: Hash = key key') - (#.Some val') - #.None)) - #.None)) - - ## For #Collisions nodes, do a linear scan of all the known KV-pairs. - (#Collisions _hash _colls) - (:: maybe.Monad map product.right - (array.find (|>> product.left (:: Hash = key)) - _colls)) - )) - -(def: (size' node) - (All [k v] (-> (Node k v) Nat)) - (case node - (#Hierarchy _size hierarchy) - (array/fold n/+ +0 (array/map size' hierarchy)) - - (#Base _ base) - (array/fold n/+ +0 (array/map (function (_ sub-node') - (case sub-node' - (#.Left sub-node) (size' sub-node) - (#.Right _) +1)) - base)) - - (#Collisions hash colls) - (array.size colls) - )) - -(def: (entries' node) - (All [k v] (-> (Node k v) (List [k v]))) - (case node - (#Hierarchy _size hierarchy) - (array/fold (function (_ sub-node tail) (list/compose (entries' sub-node) tail)) - #.Nil - hierarchy) - - (#Base bitmap base) - (array/fold (function (_ branch tail) - (case branch - (#.Left sub-node) - (list/compose (entries' sub-node) tail) - - (#.Right [key' val']) - (#.Cons [key' val'] tail))) - #.Nil - base) - - (#Collisions hash colls) - (array/fold (function (_ [key' val'] tail) (#.Cons [key' val'] tail)) - #.Nil - colls))) - -## [Exports] -(type: #export (Dict k v) - {#.doc "A dictionary implemented as a Hash-Array Mapped Trie (HAMT)."} - {#hash (Hash k) - #root (Node k v)}) - -(def: #export (new Hash) - (All [k v] (-> (Hash k) (Dict k v))) - {#hash Hash - #root empty}) - -(def: #export (put key val dict) - (All [k v] (-> k v (Dict k v) (Dict k v))) - (let [[Hash node] dict] - [Hash (put' root-level (:: Hash hash key) key val Hash node)])) - -(def: #export (remove key dict) - (All [k v] (-> k (Dict k v) (Dict k v))) - (let [[Hash node] dict] - [Hash (remove' root-level (:: Hash hash key) key Hash node)])) - -(def: #export (get key dict) - (All [k v] (-> k (Dict k v) (Maybe v))) - (let [[Hash node] dict] - (get' root-level (:: Hash hash key) key Hash node))) - -(def: #export (contains? key dict) - (All [k v] (-> k (Dict k v) Bool)) - (case (get key dict) - #.None false - (#.Some _) true)) - -(def: #export (put~ key val dict) - {#.doc "Only puts the KV-pair if the key is not already present."} - (All [k v] (-> k v (Dict k v) (Dict k v))) - (if (contains? key dict) - dict - (put key val dict))) - -(def: #export (update key f dict) - {#.doc "Transforms the value located at key (if available), using the given function."} - (All [k v] (-> k (-> v v) (Dict k v) (Dict k v))) - (case (get key dict) - #.None - dict - - (#.Some val) - (put key (f val) dict))) - -(def: #export (update~ key default f dict) - {#.doc "Transforms the value located at key (if available), using the given function."} - (All [k v] (-> k v (-> v v) (Dict k v) (Dict k v))) - (put key - (f (maybe.default default - (get key dict))) - dict)) - -(def: #export size - (All [k v] (-> (Dict k v) Nat)) - (|>> product.right size')) - -(def: #export empty? - (All [k v] (-> (Dict k v) Bool)) - (|>> size (n/= +0))) - -(def: #export (entries dict) - (All [k v] (-> (Dict k v) (List [k v]))) - (entries' (product.right dict))) - -(def: #export (from-list Hash kvs) - (All [k v] (-> (Hash k) (List [k v]) (Dict k v))) - (list/fold (function (_ [k v] dict) - (put k v dict)) - (new Hash) - kvs)) - -(do-template [ ] - [(def: #export ( dict) - (All [k v] (-> (Dict k v) (List ))) - (|> dict entries (list/map )))] - - [keys k product.left] - [values v product.right] - ) - -(def: #export (merge dict2 dict1) - {#.doc "Merges 2 dictionaries. - - If any collisions with keys occur, the values of dict2 will overwrite those of dict1."} - (All [k v] (-> (Dict k v) (Dict k v) (Dict k v))) - (list/fold (function (_ [key val] dict) (put key val dict)) - dict1 - (entries dict2))) - -(def: #export (merge-with f dict2 dict1) - {#.doc "Merges 2 dictionaries. - - If any collisions with keys occur, a new value will be computed by applying 'f' to the values of dict2 and dict1."} - (All [k v] (-> (-> v v v) (Dict k v) (Dict k v) (Dict k v))) - (list/fold (function (_ [key val2] dict) - (case (get key dict) - #.None - (put key val2 dict) - - (#.Some val1) - (put key (f val2 val1) dict))) - dict1 - (entries dict2))) - -(def: #export (re-bind from-key to-key dict) - (All [k v] (-> k k (Dict k v) (Dict k v))) - (case (get from-key dict) - #.None - dict - - (#.Some val) - (|> dict - (remove from-key) - (put to-key val)))) - -(def: #export (select keys dict) - {#.doc "Creates a sub-set of the given dict, with only the specified keys."} - (All [k v] (-> (List k) (Dict k v) (Dict k v))) - (let [[Hash _] dict] - (list/fold (function (_ key new-dict) - (case (get key dict) - #.None new-dict - (#.Some val) (put key val new-dict))) - (new Hash) - keys))) - -## [Structures] -(struct: #export (Eq Eq) (All [k v] (-> (Eq v) (Eq (Dict k v)))) - (def: (= test subject) - (and (n/= (size test) - (size subject)) - (list.every? (function (_ k) - (case [(get k test) (get k subject)] - [(#.Some tk) (#.Some sk)] - (:: Eq = tk sk) - - _ - false)) - (keys test))))) diff --git a/stdlib/source/lux/data/coll/dict/ordered.lux b/stdlib/source/lux/data/coll/dict/ordered.lux new file mode 100644 index 000000000..a099087f3 --- /dev/null +++ b/stdlib/source/lux/data/coll/dict/ordered.lux @@ -0,0 +1,563 @@ +(.module: + lux + (lux (control [monad #+ do Monad] + eq + [order #+ Order]) + (data (coll [list "L/" Monad Monoid Fold]) + ["p" product] + [maybe]) + [macro] + (macro [code] + ["s" syntax #+ syntax: Syntax]))) + +(def: error-message Text "Invariant violation") + +(type: Color #Red #Black) + +(type: (Node k v) + {#color Color + #key k + #value v + #left (Maybe (Node k v)) + #right (Maybe (Node k v))}) + +(do-template [ ] + [(def: ( key value left right) + (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) + {#color + #key key + #value value + #left left + #right right})] + + [red #Red] + [black #Black] + ) + +(type: #export (Dict k v) + {#order (Order k) + #root (Maybe (Node k v))}) + +(def: #export (new Order) + (All [k v] (-> (Order k) (Dict k v))) + {#order Order + #root #.None}) + +## TODO: Doing inneficient access of Order functions due to compiler bug. +## TODO: Must improve it as soon as bug is fixed. +(def: #export (get key dict) + (All [k v] (-> k (Dict k v) (Maybe v))) + (let [## (^open "T/") (get@ #order dict) + ] + (loop [node (get@ #root dict)] + (case node + #.None + #.None + + (#.Some node) + (let [node-key (get@ #key node)] + (cond (:: dict = node-key key) + ## (T/= node-key key) + (#.Some (get@ #value node)) + + (:: dict < node-key key) + ## (T/< node-key key) + (recur (get@ #left node)) + + ## (T/> (get@ #key node) key) + (recur (get@ #right node)))) + )))) + +(def: #export (contains? key dict) + (All [k v] (-> k (Dict k v) Bool)) + (let [## (^open "T/") (get@ #order dict) + ] + (loop [node (get@ #root dict)] + (case node + #.None + false + + (#.Some node) + (let [node-key (get@ #key node)] + (or (:: dict = node-key key) + ## (T/= node-key key) + (if (:: dict < node-key key) + ## (T/< node-key key) + (recur (get@ #left node)) + (recur (get@ #right node))))))))) + +(do-template [ ] + [(def: #export ( dict) + (All [k v] (-> (Dict k v) (Maybe v))) + (case (get@ #root dict) + #.None + #.None + + (#.Some node) + (loop [node node] + (case (get@ node) + #.None + (#.Some (get@ #value node)) + + (#.Some side) + (recur side)))))] + + [min #left] + [max #right] + ) + +(do-template [ ] + [(def: #export ( dict) + (All [k v] (-> (Dict k v) Nat)) + (loop [node (get@ #root dict)] + (case node + #.None + +0 + + (#.Some node) + (n/inc ( (recur (get@ #left node)) + (recur (get@ #right node)))))))] + + [size n/+] + [depth n/max] + ) + +(do-template [ ] + [(def: ( self) + (All [k v] (-> (Node k v) (Node k v))) + (case (get@ #color self) + + (set@ #color self) + + + + ))] + + [blacken #Red #Black self] + [redden #Black #Red (error! error-message)] + ) + +(def: (balance-left-add parent self) + (All [k v] (-> (Node k v) (Node k v) (Node k v))) + (with-expansions + [ (as-is (black (get@ #key parent) + (get@ #value parent) + (#.Some self) + (get@ #right parent)))] + (case (get@ #color self) + #Red + (case (get@ #left self) + (^multi (#.Some left) + [(get@ #color left) #Red]) + (red (get@ #key self) + (get@ #value self) + (#.Some (blacken left)) + (#.Some (black (get@ #key parent) + (get@ #value parent) + (get@ #right self) + (get@ #right parent)))) + + _ + (case (get@ #right self) + (^multi (#.Some right) + [(get@ #color right) #Red]) + (red (get@ #key right) + (get@ #value right) + (#.Some (black (get@ #key self) + (get@ #value self) + (get@ #left self) + (get@ #left right))) + (#.Some (black (get@ #key parent) + (get@ #value parent) + (get@ #right right) + (get@ #right parent)))) + + _ + )) + + #Black + + ))) + +(def: (balance-right-add parent self) + (All [k v] (-> (Node k v) (Node k v) (Node k v))) + (with-expansions + [ (as-is (black (get@ #key parent) + (get@ #value parent) + (get@ #left parent) + (#.Some self)))] + (case (get@ #color self) + #Red + (case (get@ #right self) + (^multi (#.Some right) + [(get@ #color right) #Red]) + (red (get@ #key self) + (get@ #value self) + (#.Some (black (get@ #key parent) + (get@ #value parent) + (get@ #left parent) + (get@ #left self))) + (#.Some (blacken right))) + + _ + (case (get@ #left self) + (^multi (#.Some left) + [(get@ #color left) #Red]) + (red (get@ #key left) + (get@ #value left) + (#.Some (black (get@ #key parent) + (get@ #value parent) + (get@ #left parent) + (get@ #left left))) + (#.Some (black (get@ #key self) + (get@ #value self) + (get@ #right left) + (get@ #right self)))) + + _ + )) + + #Black + + ))) + +(def: (add-left addition center) + (All [k v] (-> (Node k v) (Node k v) (Node k v))) + (case (get@ #color center) + #Red + (red (get@ #key center) (get@ #value center) (#.Some addition) (get@ #right center)) + + #Black + (balance-left-add center addition) + )) + +(def: (add-right addition center) + (All [k v] (-> (Node k v) (Node k v) (Node k v))) + (case (get@ #color center) + #Red + (red (get@ #key center) (get@ #value center) (get@ #left center) (#.Some addition)) + + #Black + (balance-right-add center addition) + )) + +(def: #export (put key value dict) + (All [k v] (-> k v (Dict k v) (Dict k v))) + (let [(^open "T/") (get@ #order dict) + root' (loop [?root (get@ #root dict)] + (case ?root + #.None + (#.Some (red key value #.None #.None)) + + (#.Some root) + (let [reference (get@ #key root)] + (`` (cond (~~ (do-template [ ] + [( reference key) + (let [side-root (get@ root) + outcome (recur side-root)] + (if (is? side-root outcome) + ?root + (#.Some ( (maybe.assume outcome) + root))))] + + [T/< #left add-left] + [T/> #right add-right] + )) + + ## (T/= reference key) + ?root + ))) + ))] + (set@ #root root' dict))) + +(def: (left-balance key value ?left ?right) + (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) + (case ?left + (^multi (#.Some left) + [(get@ #color left) #Red] + [(get@ #left left) (#.Some left>>left)] + [(get@ #color left>>left) #Red]) + (red (get@ #key left) + (get@ #value left) + (#.Some (blacken left>>left)) + (#.Some (black key value (get@ #right left) ?right))) + + (^multi (#.Some left) + [(get@ #color left) #Red] + [(get@ #right left) (#.Some left>>right)] + [(get@ #color left>>right) #Red]) + (red (get@ #key left>>right) + (get@ #value left>>right) + (#.Some (black (get@ #key left) + (get@ #value left) + (get@ #left left) + (get@ #left left>>right))) + (#.Some (black key value + (get@ #right left>>right) + ?right))) + + _ + (black key value ?left ?right))) + +(def: (right-balance key value ?left ?right) + (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) + (case ?right + (^multi (#.Some right) + [(get@ #color right) #Red] + [(get@ #right right) (#.Some right>>right)] + [(get@ #color right>>right) #Red]) + (red (get@ #key right) + (get@ #value right) + (#.Some (black key value ?left (get@ #left right))) + (#.Some (blacken right>>right))) + + (^multi (#.Some right) + [(get@ #color right) #Red] + [(get@ #left right) (#.Some right>>left)] + [(get@ #color right>>left) #Red]) + (red (get@ #key right>>left) + (get@ #value right>>left) + (#.Some (black key value ?left (get@ #left right>>left))) + (#.Some (black (get@ #key right) + (get@ #value right) + (get@ #right right>>left) + (get@ #right right)))) + + _ + (black key value ?left ?right))) + +(def: (balance-left-remove key value ?left ?right) + (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) + (case ?left + (^multi (#.Some left) + [(get@ #color left) #Red]) + (red key value (#.Some (blacken left)) ?right) + + _ + (case ?right + (^multi (#.Some right) + [(get@ #color right) #Black]) + (right-balance key value ?left (#.Some (redden right))) + + (^multi (#.Some right) + [(get@ #color right) #Red] + [(get@ #left right) (#.Some right>>left)] + [(get@ #color right>>left) #Black]) + (red (get@ #key right>>left) + (get@ #value right>>left) + (#.Some (black key value ?left (get@ #left right>>left))) + (#.Some (right-balance (get@ #key right) + (get@ #value right) + (get@ #right right>>left) + (:: maybe.Functor map redden (get@ #right right))))) + + _ + (error! error-message)) + )) + +(def: (balance-right-remove key value ?left ?right) + (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) + (case ?right + (^multi (#.Some right) + [(get@ #color right) #Red]) + (red key value ?left (#.Some (blacken right))) + + _ + (case ?left + (^multi (#.Some left) + [(get@ #color left) #Black]) + (left-balance key value (#.Some (redden left)) ?right) + + (^multi (#.Some left) + [(get@ #color left) #Red] + [(get@ #right left) (#.Some left>>right)] + [(get@ #color left>>right) #Black]) + (red (get@ #key left>>right) + (get@ #value left>>right) + (#.Some (left-balance (get@ #key left) + (get@ #value left) + (:: maybe.Functor map redden (get@ #left left)) + (get@ #left left>>right))) + (#.Some (black key value (get@ #right left>>right) ?right))) + + _ + (error! error-message) + ))) + +(def: (prepend ?left ?right) + (All [k v] (-> (Maybe (Node k v)) (Maybe (Node k v)) (Maybe (Node k v)))) + (case [?left ?right] + [#.None _] + ?right + + [_ #.None] + ?left + + [(#.Some left) (#.Some right)] + (case [(get@ #color left) (get@ #color right)] + [#Red #Red] + (do maybe.Monad + [fused (prepend (get@ #right left) (get@ #right right))] + (case (get@ #color fused) + #Red + (wrap (red (get@ #key fused) + (get@ #value fused) + (#.Some (red (get@ #key left) + (get@ #value left) + (get@ #left left) + (get@ #left fused))) + (#.Some (red (get@ #key right) + (get@ #value right) + (get@ #right fused) + (get@ #right right))))) + + #Black + (wrap (red (get@ #key left) + (get@ #value left) + (get@ #left left) + (#.Some (red (get@ #key right) + (get@ #value right) + (#.Some fused) + (get@ #right right))))))) + + [#Red #Black] + (#.Some (red (get@ #key left) + (get@ #value left) + (get@ #left left) + (prepend (get@ #right left) + ?right))) + + [#Black #Red] + (#.Some (red (get@ #key right) + (get@ #value right) + (prepend ?left + (get@ #left right)) + (get@ #right right))) + + [#Black #Black] + (do maybe.Monad + [fused (prepend (get@ #right left) (get@ #left right))] + (case (get@ #color fused) + #Red + (wrap (red (get@ #key fused) + (get@ #value fused) + (#.Some (black (get@ #key left) + (get@ #value left) + (get@ #left left) + (get@ #left fused))) + (#.Some (black (get@ #key right) + (get@ #value right) + (get@ #right fused) + (get@ #right right))))) + + #Black + (wrap (balance-left-remove (get@ #key left) + (get@ #value left) + (get@ #left left) + (#.Some (black (get@ #key right) + (get@ #value right) + (#.Some fused) + (get@ #right right))))) + )) + ) + + _ + (undefined))) + +(def: #export (remove key dict) + (All [k v] (-> k (Dict k v) (Dict k v))) + (let [(^open "T/") (get@ #order dict) + [?root found?] (loop [?root (get@ #root dict)] + (case ?root + #.None + [#.None false] + + (#.Some root) + (let [root-key (get@ #key root) + root-val (get@ #value root)] + (if (T/= root-key key) + [(prepend (get@ #left root) + (get@ #right root)) + true] + (let [go-left? (T/< root-key key)] + (case (recur (if go-left? + (get@ #left root) + (get@ #right root))) + [#.None false] + [#.None false] + + [side-outcome _] + (if go-left? + (case (get@ #left root) + (^multi (#.Some left) + [(get@ #color left) #Black]) + [(#.Some (balance-left-remove root-key root-val side-outcome (get@ #right root))) + false] + + _ + [(#.Some (red root-key root-val side-outcome (get@ #right root))) + false]) + (case (get@ #right root) + (^multi (#.Some right) + [(get@ #color right) #Black]) + [(#.Some (balance-right-remove root-key root-val (get@ #left root) side-outcome)) + false] + + _ + [(#.Some (red root-key root-val (get@ #left root) side-outcome)) + false]) + ))) + )) + ))] + (case ?root + #.None + (if found? + (set@ #root ?root dict) + dict) + + (#.Some root) + (set@ #root (#.Some (blacken root)) dict) + ))) + +(def: #export (from-list Order list) + (All [k v] (-> (Order k) (List [k v]) (Dict k v))) + (L/fold (function (_ [key value] dict) + (put key value dict)) + (new Order) + list)) + +(do-template [ ] + [(def: #export ( dict) + (All [k v] (-> (Dict k v) (List ))) + (loop [node (get@ #root dict)] + (case node + #.None + (list) + + (#.Some node') + ($_ L/compose + (recur (get@ #left node')) + (list ) + (recur (get@ #right node'))))))] + + [entries [k v] [(get@ #key node') (get@ #value node')]] + [keys k (get@ #key node')] + [values v (get@ #value node')] + ) + +(struct: #export (Eq Eq) (All [k v] (-> (Eq v) (Eq (Dict k v)))) + (def: (= reference sample) + (let [Eq (:: sample eq)] + (loop [entriesR (entries reference) + entriesS (entries sample)] + (case [entriesR entriesS] + [#.Nil #.Nil] + true + + [(#.Cons [keyR valueR] entriesR') (#.Cons [keyS valueS] entriesS')] + (and (:: Eq = keyR keyS) + (:: Eq = valueR valueS) + (recur entriesR' entriesS')) + + _ + false))))) diff --git a/stdlib/source/lux/data/coll/dict/unordered.lux b/stdlib/source/lux/data/coll/dict/unordered.lux new file mode 100644 index 000000000..97a119755 --- /dev/null +++ b/stdlib/source/lux/data/coll/dict/unordered.lux @@ -0,0 +1,685 @@ +(.module: + lux + (lux (control hash + [eq #+ Eq]) + (data [maybe] + (coll [list "list/" Fold Functor Monoid] + [array "array/" Functor Fold]) + [bit] + [product] + [number]) + )) + +## This implementation of Hash Array Mapped Trie (HAMT) is based on +## Clojure's PersistentHashMap implementation. +## That one is further based on Phil Bagwell's Hash Array Mapped Trie. + +## [Utils] +## Bitmaps are used to figure out which branches on a #Base node are +## populated. The number of bits that are 1s in a bitmap signal the +## size of the #Base node. +(type: BitMap Nat) + +## Represents the position of a node in a BitMap. +## It's meant to be a single bit set on a 32-bit word. +## The position of the bit reflects whether an entry in an analogous +## position exists within a #Base, as reflected in it's BitMap. +(type: BitPosition Nat) + +## An index into an array. +(type: Index Nat) + +## A hash-code derived from a key during tree-traversal. +(type: Hash-Code Nat) + +## Represents the nesting level of a leaf or node, when looking-it-up +## while exploring the tree. +## Changes in levels are done by right-shifting the hashes of keys by +## the appropriate multiple of the branching-exponent. +## A shift of 0 means root level. +## A shift of (* branching-exponent 1) means level 2. +## A shift of (* branching-exponent N) means level N+1. +(type: Level Nat) + +## Nodes for the tree data-structure that organizes the data inside +## Dicts. +(type: (Node k v) + (#Hierarchy Nat (Array (Node k v))) + (#Base BitMap + (Array (Either (Node k v) + [k v]))) + (#Collisions Hash-Code (Array [k v]))) + +## #Hierarchy nodes are meant to point down only to lower-level nodes. +(type: (Hierarchy k v) + [Nat (Array (Node k v))]) + +## #Base nodes may point down to other nodes, but also to leaves, +## which are KV-pairs. +(type: (Base k v) + (Array (Either (Node k v) + [k v]))) + +## #Collisions are collections of KV-pairs for which the key is +## different on each case, but their hashes are all the same (thus +## causing a collision). +(type: (Collisions k v) + (Array [k v])) + +## That bitmap for an empty #Base is 0. +## Which is the same as 0000 0000 0000 0000 0000 0000 0000 0000. +## Or 0x00000000. +## Which is 32 zeroes, since the branching factor is 32. +(def: clean-bitmap + BitMap + +0) + +## Bitmap position (while looking inside #Base nodes) is determined by +## getting 5 bits from a hash of the key being looked up and using +## them as an index into the array inside #Base. +## Since the data-structure can have multiple levels (and the hash has +## more than 5 bits), the binary-representation of the hash is shifted +## by 5 positions on each step (2^5 = 32, which is the branching +## factor). +## The initial shifting level, though, is 0 (which corresponds to the +## shift in the shallowest node on the tree, which is the root node). +(def: root-level + Level + +0) + +## The exponent to which 2 must be elevated, to reach the branching +## factor of the data-structure. +(def: branching-exponent + Nat + +5) + +## The threshold on which #Hierarchy nodes are demoted to #Base nodes, +## which is 1/4 of the branching factor (or a left-shift 2). +(def: demotion-threshold + Nat + (bit.shift-left (n/- +2 branching-exponent) +1)) + +## The threshold on which #Base nodes are promoted to #Hierarchy nodes, +## which is 1/2 of the branching factor (or a left-shift 1). +(def: promotion-threshold + Nat + (bit.shift-left (n/- +1 branching-exponent) +1)) + +## The size of hierarchy-nodes, which is 2^(branching-exponent). +(def: hierarchy-nodes-size + Nat + (bit.shift-left branching-exponent +1)) + +## The cannonical empty node, which is just an empty #Base node. +(def: empty + Node + (#Base clean-bitmap (array.new +0))) + +## Expands a copy of the array, to have 1 extra slot, which is used +## for storing the value. +(def: (insert! idx value old-array) + (All [a] (-> Index a (Array a) (Array a))) + (let [old-size (array.size old-array)] + (|> (array.new (n/inc old-size)) + (array.copy idx +0 old-array +0) + (array.write idx value) + (array.copy (n/- idx old-size) idx old-array (n/inc idx))))) + +## Creates a copy of an array with an index set to a particular value. +(def: (update! idx value array) + (All [a] (-> Index a (Array a) (Array a))) + (|> array array.clone (array.write idx value))) + +## Creates a clone of the array, with an empty position at index. +(def: (vacant! idx array) + (All [a] (-> Index (Array a) (Array a))) + (|> array array.clone (array.delete idx))) + +## Shrinks a copy of the array by removing the space at index. +(def: (remove! idx array) + (All [a] (-> Index (Array a) (Array a))) + (let [new-size (n/dec (array.size array))] + (|> (array.new new-size) + (array.copy idx +0 array +0) + (array.copy (n/- idx new-size) (n/inc idx) array idx)))) + +## Given a top-limit for indices, produces all indices in [0, R). +(def: indices-for + (-> Nat (List Index)) + (|>> n/dec (list.n/range +0))) + +## Increases the level-shift by the branching-exponent, to explore +## levels further down the tree. +(def: level-up + (-> Level Level) + (n/+ branching-exponent)) + +(def: hierarchy-mask BitMap (n/dec hierarchy-nodes-size)) + +## Gets the branching-factor sized section of the hash corresponding +## to a particular level, and uses that as an index into the array. +(def: (level-index level hash) + (-> Level Hash-Code Index) + (bit.and hierarchy-mask + (bit.shift-right level hash))) + +## A mechanism to go from indices to bit-positions. +(def: (->bit-position index) + (-> Index BitPosition) + (bit.shift-left index +1)) + +## The bit-position within a base that a given hash-code would have. +(def: (bit-position level hash) + (-> Level Hash-Code BitPosition) + (->bit-position (level-index level hash))) + +(def: (bit-position-is-set? bit bitmap) + (-> BitPosition BitMap Bool) + (not (n/= clean-bitmap (bit.and bit bitmap)))) + +## Figures out whether a bitmap only contains a single bit-position. +(def: only-bit-position? + (-> BitPosition BitMap Bool) + n/=) + +(def: (set-bit-position bit bitmap) + (-> BitPosition BitMap BitMap) + (bit.or bit bitmap)) + +(def: unset-bit-position + (-> BitPosition BitMap BitMap) + bit.xor) + +## Figures out the size of a bitmap-indexed array by counting all the +## 1s within the bitmap. +(def: bitmap-size + (-> BitMap Nat) + bit.count) + +## A mask that, for a given bit position, only allows all the 1s prior +## to it, which would indicate the bitmap-size (and, thus, index) +## associated with it. +(def: bit-position-mask + (-> BitPosition BitMap) + n/dec) + +## The index on the base array, based on it's bit-position. +(def: (base-index bit-position bitmap) + (-> BitPosition BitMap Index) + (bitmap-size (bit.and (bit-position-mask bit-position) + bitmap))) + +## Produces the index of a KV-pair within a #Collisions node. +(def: (collision-index Hash key colls) + (All [k v] (-> (Hash k) k (Collisions k v) (Maybe Index))) + (:: maybe.Monad map product.left + (array.find+ (function (_ idx [key' val']) + (:: Hash = key key')) + colls))) + +## When #Hierarchy nodes grow too small, they're demoted to #Base +## nodes to save space. +(def: (demote-hierarchy except-idx [h-size h-array]) + (All [k v] (-> Index (Hierarchy k v) [BitMap (Base k v)])) + (product.right (list/fold (function (_ idx [insertion-idx node]) + (let [[bitmap base] node] + (case (array.read idx h-array) + #.None [insertion-idx node] + (#.Some sub-node) (if (n/= except-idx idx) + [insertion-idx node] + [(n/inc insertion-idx) + [(set-bit-position (->bit-position idx) bitmap) + (array.write insertion-idx (#.Left sub-node) base)]]) + ))) + [+0 [clean-bitmap + (array.new (n/dec h-size))]] + (list.indices (array.size h-array))))) + +## When #Base nodes grow too large, they're promoted to #Hierarchy to +## add some depth to the tree and help keep it's balance. +(def: hierarchy-indices (List Index) (indices-for hierarchy-nodes-size)) + +(def: (promote-base put' Hash level bitmap base) + (All [k v] + (-> (-> Level Hash-Code k v (Hash k) (Node k v) (Node k v)) + (Hash k) Level + BitMap (Base k v) + (Array (Node k v)))) + (product.right (list/fold (function (_ hierarchy-idx (^@ default [base-idx h-array])) + (if (bit-position-is-set? (->bit-position hierarchy-idx) + bitmap) + [(n/inc base-idx) + (case (array.read base-idx base) + (#.Some (#.Left sub-node)) + (array.write hierarchy-idx sub-node h-array) + + (#.Some (#.Right [key' val'])) + (array.write hierarchy-idx + (put' (level-up level) (:: Hash hash key') key' val' Hash empty) + h-array) + + #.None + (undefined))] + default)) + [+0 + (array.new hierarchy-nodes-size)] + hierarchy-indices))) + +## All empty nodes look the same (a #Base node with clean bitmap is +## used). +## So, this test is introduced to detect them. +(def: (empty?' node) + (All [k v] (-> (Node k v) Bool)) + (case node + (^~ (#Base ..clean-bitmap _)) + true + + _ + false)) + +(def: (put' level hash key val Hash node) + (All [k v] (-> Level Hash-Code k v (Hash k) (Node k v) (Node k v))) + (case node + ## For #Hierarchy nodes, I check whether I can add the element to + ## a sub-node. If impossible, I introduced a new singleton sub-node. + (#Hierarchy _size hierarchy) + (let [idx (level-index level hash) + [_size' sub-node] (case (array.read idx hierarchy) + (#.Some sub-node) + [_size sub-node] + + _ + [(n/inc _size) empty])] + (#Hierarchy _size' + (update! idx (put' (level-up level) hash key val Hash sub-node) + hierarchy))) + + ## For #Base nodes, I check if the corresponding BitPosition has + ## already been used. + (#Base bitmap base) + (let [bit (bit-position level hash)] + (if (bit-position-is-set? bit bitmap) + ## If so... + (let [idx (base-index bit bitmap)] + (case (array.read idx base) + #.None + (undefined) + + ## If it's being used by a node, I add the KV to it. + (#.Some (#.Left sub-node)) + (let [sub-node' (put' (level-up level) hash key val Hash sub-node)] + (#Base bitmap (update! idx (#.Left sub-node') base))) + + ## Otherwise, if it's being used by a KV, I compare the keys. + (#.Some (#.Right key' val')) + (if (:: Hash = key key') + ## If the same key is found, I replace the value. + (#Base bitmap (update! idx (#.Right key val) base)) + ## Otherwise, I compare the hashes of the keys. + (#Base bitmap (update! idx + (#.Left (let [hash' (:: Hash hash key')] + (if (n/= hash hash') + ## If the hashes are + ## the same, a new + ## #Collisions node + ## is added. + (#Collisions hash (|> (array.new +2) + (array.write +0 [key' val']) + (array.write +1 [key val]))) + ## Otherwise, I can + ## just keep using + ## #Base nodes, so I + ## add both KV-pairs + ## to the empty one. + (let [next-level (level-up level)] + (|> empty + (put' next-level hash' key' val' Hash) + (put' next-level hash key val Hash)))))) + base))))) + ## However, if the BitPosition has not been used yet, I check + ## whether this #Base node is ready for a promotion. + (let [base-count (bitmap-size bitmap)] + (if (n/>= promotion-threshold base-count) + ## If so, I promote it to a #Hierarchy node, and add the new + ## KV-pair as a singleton node to it. + (#Hierarchy (n/inc base-count) + (|> (promote-base put' Hash level bitmap base) + (array.write (level-index level hash) + (put' (level-up level) hash key val Hash empty)))) + ## Otherwise, I just resize the #Base node to accommodate the + ## new KV-pair. + (#Base (set-bit-position bit bitmap) + (insert! (base-index bit bitmap) (#.Right [key val]) base)))))) + + ## For #Collisions nodes, I compare the hashes. + (#Collisions _hash _colls) + (if (n/= hash _hash) + ## If they're equal, that means the new KV contributes to the + ## collisions. + (case (collision-index Hash key _colls) + ## If the key was already present in the collisions-list, it's + ## value gets updated. + (#.Some coll-idx) + (#Collisions _hash (update! coll-idx [key val] _colls)) + + ## Otherwise, the KV-pair is added to the collisions-list. + #.None + (#Collisions _hash (insert! (array.size _colls) [key val] _colls))) + ## If the hashes are not equal, I create a new #Base node that + ## contains the old #Collisions node, plus the new KV-pair. + (|> (#Base (bit-position level _hash) + (|> (array.new +1) + (array.write +0 (#.Left node)))) + (put' level hash key val Hash))) + )) + +(def: (remove' level hash key Hash node) + (All [k v] (-> Level Hash-Code k (Hash k) (Node k v) (Node k v))) + (case node + ## For #Hierarchy nodes, find out if there's a valid sub-node for + ## the Hash-Code. + (#Hierarchy h-size h-array) + (let [idx (level-index level hash)] + (case (array.read idx h-array) + ## If not, there's nothing to remove. + #.None + node + + ## But if there is, try to remove the key from the sub-node. + (#.Some sub-node) + (let [sub-node' (remove' (level-up level) hash key Hash sub-node)] + ## Then check if a removal was actually done. + (if (is? sub-node sub-node') + ## If not, then there's nothing to change here either. + node + ## But if the sub-removal yielded an empty sub-node... + (if (empty?' sub-node') + ## Check if it's due time for a demotion. + (if (n/<= demotion-threshold h-size) + ## If so, perform it. + (#Base (demote-hierarchy idx [h-size h-array])) + ## Otherwise, just clear the space. + (#Hierarchy (n/dec h-size) (vacant! idx h-array))) + ## But if the sub-removal yielded a non-empty node, then + ## just update the hiearchy branch. + (#Hierarchy h-size (update! idx sub-node' h-array))))))) + + ## For #Base nodes, check whether the BitPosition is set. + (#Base bitmap base) + (let [bit (bit-position level hash)] + (if (bit-position-is-set? bit bitmap) + (let [idx (base-index bit bitmap)] + (case (array.read idx base) + #.None + (undefined) + + ## If set, check if it's a sub-node, and remove the KV + ## from it. + (#.Some (#.Left sub-node)) + (let [sub-node' (remove' (level-up level) hash key Hash sub-node)] + ## Verify that it was removed. + (if (is? sub-node sub-node') + ## If not, there's also nothing to change here. + node + ## But if it came out empty... + (if (empty?' sub-node') + ### ... figure out whether that's the only position left. + (if (only-bit-position? bit bitmap) + ## If so, removing it leaves this node empty too. + empty + ## But if not, then just unset the position and + ## remove the node. + (#Base (unset-bit-position bit bitmap) + (remove! idx base))) + ## But, if it did not come out empty, then the + ## position is kept, and the node gets updated. + (#Base bitmap + (update! idx (#.Left sub-node') base))))) + + ## If, however, there was a KV-pair instead of a sub-node. + (#.Some (#.Right [key' val'])) + ## Check if the keys match. + (if (:: Hash = key key') + ## If so, remove the KV-pair and unset the BitPosition. + (#Base (unset-bit-position bit bitmap) + (remove! idx base)) + ## Otherwise, there's nothing to remove. + node))) + ## If the BitPosition is not set, there's nothing to remove. + node)) + + ## For #Collisions nodes, It need to find out if the key already existst. + (#Collisions _hash _colls) + (case (collision-index Hash key _colls) + ## If not, then there's nothing to remove. + #.None + node + + ## But if so, then check the size of the collisions list. + (#.Some idx) + (if (n/= +1 (array.size _colls)) + ## If there's only one left, then removing it leaves us with + ## an empty node. + empty + ## Otherwise, just shrink the array by removing the KV-pair. + (#Collisions _hash (remove! idx _colls)))) + )) + +(def: (get' level hash key Hash node) + (All [k v] (-> Level Hash-Code k (Hash k) (Node k v) (Maybe v))) + (case node + ## For #Hierarchy nodes, just look-up the key on its children. + (#Hierarchy _size hierarchy) + (case (array.read (level-index level hash) hierarchy) + #.None #.None + (#.Some sub-node) (get' (level-up level) hash key Hash sub-node)) + + ## For #Base nodes, check the leaves, and recursively check the branches. + (#Base bitmap base) + (let [bit (bit-position level hash)] + (if (bit-position-is-set? bit bitmap) + (case (array.read (base-index bit bitmap) base) + #.None + (undefined) + + (#.Some (#.Left sub-node)) + (get' (level-up level) hash key Hash sub-node) + + (#.Some (#.Right [key' val'])) + (if (:: Hash = key key') + (#.Some val') + #.None)) + #.None)) + + ## For #Collisions nodes, do a linear scan of all the known KV-pairs. + (#Collisions _hash _colls) + (:: maybe.Monad map product.right + (array.find (|>> product.left (:: Hash = key)) + _colls)) + )) + +(def: (size' node) + (All [k v] (-> (Node k v) Nat)) + (case node + (#Hierarchy _size hierarchy) + (array/fold n/+ +0 (array/map size' hierarchy)) + + (#Base _ base) + (array/fold n/+ +0 (array/map (function (_ sub-node') + (case sub-node' + (#.Left sub-node) (size' sub-node) + (#.Right _) +1)) + base)) + + (#Collisions hash colls) + (array.size colls) + )) + +(def: (entries' node) + (All [k v] (-> (Node k v) (List [k v]))) + (case node + (#Hierarchy _size hierarchy) + (array/fold (function (_ sub-node tail) (list/compose (entries' sub-node) tail)) + #.Nil + hierarchy) + + (#Base bitmap base) + (array/fold (function (_ branch tail) + (case branch + (#.Left sub-node) + (list/compose (entries' sub-node) tail) + + (#.Right [key' val']) + (#.Cons [key' val'] tail))) + #.Nil + base) + + (#Collisions hash colls) + (array/fold (function (_ [key' val'] tail) (#.Cons [key' val'] tail)) + #.Nil + colls))) + +## [Exports] +(type: #export (Dict k v) + {#.doc "A dictionary implemented as a Hash-Array Mapped Trie (HAMT)."} + {#hash (Hash k) + #root (Node k v)}) + +(def: #export (new Hash) + (All [k v] (-> (Hash k) (Dict k v))) + {#hash Hash + #root empty}) + +(def: #export (put key val dict) + (All [k v] (-> k v (Dict k v) (Dict k v))) + (let [[Hash node] dict] + [Hash (put' root-level (:: Hash hash key) key val Hash node)])) + +(def: #export (remove key dict) + (All [k v] (-> k (Dict k v) (Dict k v))) + (let [[Hash node] dict] + [Hash (remove' root-level (:: Hash hash key) key Hash node)])) + +(def: #export (get key dict) + (All [k v] (-> k (Dict k v) (Maybe v))) + (let [[Hash node] dict] + (get' root-level (:: Hash hash key) key Hash node))) + +(def: #export (contains? key dict) + (All [k v] (-> k (Dict k v) Bool)) + (case (get key dict) + #.None false + (#.Some _) true)) + +(def: #export (put~ key val dict) + {#.doc "Only puts the KV-pair if the key is not already present."} + (All [k v] (-> k v (Dict k v) (Dict k v))) + (if (contains? key dict) + dict + (put key val dict))) + +(def: #export (update key f dict) + {#.doc "Transforms the value located at key (if available), using the given function."} + (All [k v] (-> k (-> v v) (Dict k v) (Dict k v))) + (case (get key dict) + #.None + dict + + (#.Some val) + (put key (f val) dict))) + +(def: #export (update~ key default f dict) + {#.doc "Transforms the value located at key (if available), using the given function."} + (All [k v] (-> k v (-> v v) (Dict k v) (Dict k v))) + (put key + (f (maybe.default default + (get key dict))) + dict)) + +(def: #export size + (All [k v] (-> (Dict k v) Nat)) + (|>> product.right size')) + +(def: #export empty? + (All [k v] (-> (Dict k v) Bool)) + (|>> size (n/= +0))) + +(def: #export (entries dict) + (All [k v] (-> (Dict k v) (List [k v]))) + (entries' (product.right dict))) + +(def: #export (from-list Hash kvs) + (All [k v] (-> (Hash k) (List [k v]) (Dict k v))) + (list/fold (function (_ [k v] dict) + (put k v dict)) + (new Hash) + kvs)) + +(do-template [ ] + [(def: #export ( dict) + (All [k v] (-> (Dict k v) (List ))) + (|> dict entries (list/map )))] + + [keys k product.left] + [values v product.right] + ) + +(def: #export (merge dict2 dict1) + {#.doc "Merges 2 dictionaries. + + If any collisions with keys occur, the values of dict2 will overwrite those of dict1."} + (All [k v] (-> (Dict k v) (Dict k v) (Dict k v))) + (list/fold (function (_ [key val] dict) (put key val dict)) + dict1 + (entries dict2))) + +(def: #export (merge-with f dict2 dict1) + {#.doc "Merges 2 dictionaries. + + If any collisions with keys occur, a new value will be computed by applying 'f' to the values of dict2 and dict1."} + (All [k v] (-> (-> v v v) (Dict k v) (Dict k v) (Dict k v))) + (list/fold (function (_ [key val2] dict) + (case (get key dict) + #.None + (put key val2 dict) + + (#.Some val1) + (put key (f val2 val1) dict))) + dict1 + (entries dict2))) + +(def: #export (re-bind from-key to-key dict) + (All [k v] (-> k k (Dict k v) (Dict k v))) + (case (get from-key dict) + #.None + dict + + (#.Some val) + (|> dict + (remove from-key) + (put to-key val)))) + +(def: #export (select keys dict) + {#.doc "Creates a sub-set of the given dict, with only the specified keys."} + (All [k v] (-> (List k) (Dict k v) (Dict k v))) + (let [[Hash _] dict] + (list/fold (function (_ key new-dict) + (case (get key dict) + #.None new-dict + (#.Some val) (put key val new-dict))) + (new Hash) + keys))) + +## [Structures] +(struct: #export (Eq Eq) (All [k v] (-> (Eq v) (Eq (Dict k v)))) + (def: (= test subject) + (and (n/= (size test) + (size subject)) + (list.every? (function (_ k) + (case [(get k test) (get k subject)] + [(#.Some tk) (#.Some sk)] + (:: Eq = tk sk) + + _ + false)) + (keys test))))) diff --git a/stdlib/source/lux/data/coll/ordered/dict.lux b/stdlib/source/lux/data/coll/ordered/dict.lux deleted file mode 100644 index a099087f3..000000000 --- a/stdlib/source/lux/data/coll/ordered/dict.lux +++ /dev/null @@ -1,563 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do Monad] - eq - [order #+ Order]) - (data (coll [list "L/" Monad Monoid Fold]) - ["p" product] - [maybe]) - [macro] - (macro [code] - ["s" syntax #+ syntax: Syntax]))) - -(def: error-message Text "Invariant violation") - -(type: Color #Red #Black) - -(type: (Node k v) - {#color Color - #key k - #value v - #left (Maybe (Node k v)) - #right (Maybe (Node k v))}) - -(do-template [ ] - [(def: ( key value left right) - (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) - {#color - #key key - #value value - #left left - #right right})] - - [red #Red] - [black #Black] - ) - -(type: #export (Dict k v) - {#order (Order k) - #root (Maybe (Node k v))}) - -(def: #export (new Order) - (All [k v] (-> (Order k) (Dict k v))) - {#order Order - #root #.None}) - -## TODO: Doing inneficient access of Order functions due to compiler bug. -## TODO: Must improve it as soon as bug is fixed. -(def: #export (get key dict) - (All [k v] (-> k (Dict k v) (Maybe v))) - (let [## (^open "T/") (get@ #order dict) - ] - (loop [node (get@ #root dict)] - (case node - #.None - #.None - - (#.Some node) - (let [node-key (get@ #key node)] - (cond (:: dict = node-key key) - ## (T/= node-key key) - (#.Some (get@ #value node)) - - (:: dict < node-key key) - ## (T/< node-key key) - (recur (get@ #left node)) - - ## (T/> (get@ #key node) key) - (recur (get@ #right node)))) - )))) - -(def: #export (contains? key dict) - (All [k v] (-> k (Dict k v) Bool)) - (let [## (^open "T/") (get@ #order dict) - ] - (loop [node (get@ #root dict)] - (case node - #.None - false - - (#.Some node) - (let [node-key (get@ #key node)] - (or (:: dict = node-key key) - ## (T/= node-key key) - (if (:: dict < node-key key) - ## (T/< node-key key) - (recur (get@ #left node)) - (recur (get@ #right node))))))))) - -(do-template [ ] - [(def: #export ( dict) - (All [k v] (-> (Dict k v) (Maybe v))) - (case (get@ #root dict) - #.None - #.None - - (#.Some node) - (loop [node node] - (case (get@ node) - #.None - (#.Some (get@ #value node)) - - (#.Some side) - (recur side)))))] - - [min #left] - [max #right] - ) - -(do-template [ ] - [(def: #export ( dict) - (All [k v] (-> (Dict k v) Nat)) - (loop [node (get@ #root dict)] - (case node - #.None - +0 - - (#.Some node) - (n/inc ( (recur (get@ #left node)) - (recur (get@ #right node)))))))] - - [size n/+] - [depth n/max] - ) - -(do-template [ ] - [(def: ( self) - (All [k v] (-> (Node k v) (Node k v))) - (case (get@ #color self) - - (set@ #color self) - - - - ))] - - [blacken #Red #Black self] - [redden #Black #Red (error! error-message)] - ) - -(def: (balance-left-add parent self) - (All [k v] (-> (Node k v) (Node k v) (Node k v))) - (with-expansions - [ (as-is (black (get@ #key parent) - (get@ #value parent) - (#.Some self) - (get@ #right parent)))] - (case (get@ #color self) - #Red - (case (get@ #left self) - (^multi (#.Some left) - [(get@ #color left) #Red]) - (red (get@ #key self) - (get@ #value self) - (#.Some (blacken left)) - (#.Some (black (get@ #key parent) - (get@ #value parent) - (get@ #right self) - (get@ #right parent)))) - - _ - (case (get@ #right self) - (^multi (#.Some right) - [(get@ #color right) #Red]) - (red (get@ #key right) - (get@ #value right) - (#.Some (black (get@ #key self) - (get@ #value self) - (get@ #left self) - (get@ #left right))) - (#.Some (black (get@ #key parent) - (get@ #value parent) - (get@ #right right) - (get@ #right parent)))) - - _ - )) - - #Black - - ))) - -(def: (balance-right-add parent self) - (All [k v] (-> (Node k v) (Node k v) (Node k v))) - (with-expansions - [ (as-is (black (get@ #key parent) - (get@ #value parent) - (get@ #left parent) - (#.Some self)))] - (case (get@ #color self) - #Red - (case (get@ #right self) - (^multi (#.Some right) - [(get@ #color right) #Red]) - (red (get@ #key self) - (get@ #value self) - (#.Some (black (get@ #key parent) - (get@ #value parent) - (get@ #left parent) - (get@ #left self))) - (#.Some (blacken right))) - - _ - (case (get@ #left self) - (^multi (#.Some left) - [(get@ #color left) #Red]) - (red (get@ #key left) - (get@ #value left) - (#.Some (black (get@ #key parent) - (get@ #value parent) - (get@ #left parent) - (get@ #left left))) - (#.Some (black (get@ #key self) - (get@ #value self) - (get@ #right left) - (get@ #right self)))) - - _ - )) - - #Black - - ))) - -(def: (add-left addition center) - (All [k v] (-> (Node k v) (Node k v) (Node k v))) - (case (get@ #color center) - #Red - (red (get@ #key center) (get@ #value center) (#.Some addition) (get@ #right center)) - - #Black - (balance-left-add center addition) - )) - -(def: (add-right addition center) - (All [k v] (-> (Node k v) (Node k v) (Node k v))) - (case (get@ #color center) - #Red - (red (get@ #key center) (get@ #value center) (get@ #left center) (#.Some addition)) - - #Black - (balance-right-add center addition) - )) - -(def: #export (put key value dict) - (All [k v] (-> k v (Dict k v) (Dict k v))) - (let [(^open "T/") (get@ #order dict) - root' (loop [?root (get@ #root dict)] - (case ?root - #.None - (#.Some (red key value #.None #.None)) - - (#.Some root) - (let [reference (get@ #key root)] - (`` (cond (~~ (do-template [ ] - [( reference key) - (let [side-root (get@ root) - outcome (recur side-root)] - (if (is? side-root outcome) - ?root - (#.Some ( (maybe.assume outcome) - root))))] - - [T/< #left add-left] - [T/> #right add-right] - )) - - ## (T/= reference key) - ?root - ))) - ))] - (set@ #root root' dict))) - -(def: (left-balance key value ?left ?right) - (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) - (case ?left - (^multi (#.Some left) - [(get@ #color left) #Red] - [(get@ #left left) (#.Some left>>left)] - [(get@ #color left>>left) #Red]) - (red (get@ #key left) - (get@ #value left) - (#.Some (blacken left>>left)) - (#.Some (black key value (get@ #right left) ?right))) - - (^multi (#.Some left) - [(get@ #color left) #Red] - [(get@ #right left) (#.Some left>>right)] - [(get@ #color left>>right) #Red]) - (red (get@ #key left>>right) - (get@ #value left>>right) - (#.Some (black (get@ #key left) - (get@ #value left) - (get@ #left left) - (get@ #left left>>right))) - (#.Some (black key value - (get@ #right left>>right) - ?right))) - - _ - (black key value ?left ?right))) - -(def: (right-balance key value ?left ?right) - (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) - (case ?right - (^multi (#.Some right) - [(get@ #color right) #Red] - [(get@ #right right) (#.Some right>>right)] - [(get@ #color right>>right) #Red]) - (red (get@ #key right) - (get@ #value right) - (#.Some (black key value ?left (get@ #left right))) - (#.Some (blacken right>>right))) - - (^multi (#.Some right) - [(get@ #color right) #Red] - [(get@ #left right) (#.Some right>>left)] - [(get@ #color right>>left) #Red]) - (red (get@ #key right>>left) - (get@ #value right>>left) - (#.Some (black key value ?left (get@ #left right>>left))) - (#.Some (black (get@ #key right) - (get@ #value right) - (get@ #right right>>left) - (get@ #right right)))) - - _ - (black key value ?left ?right))) - -(def: (balance-left-remove key value ?left ?right) - (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) - (case ?left - (^multi (#.Some left) - [(get@ #color left) #Red]) - (red key value (#.Some (blacken left)) ?right) - - _ - (case ?right - (^multi (#.Some right) - [(get@ #color right) #Black]) - (right-balance key value ?left (#.Some (redden right))) - - (^multi (#.Some right) - [(get@ #color right) #Red] - [(get@ #left right) (#.Some right>>left)] - [(get@ #color right>>left) #Black]) - (red (get@ #key right>>left) - (get@ #value right>>left) - (#.Some (black key value ?left (get@ #left right>>left))) - (#.Some (right-balance (get@ #key right) - (get@ #value right) - (get@ #right right>>left) - (:: maybe.Functor map redden (get@ #right right))))) - - _ - (error! error-message)) - )) - -(def: (balance-right-remove key value ?left ?right) - (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) - (case ?right - (^multi (#.Some right) - [(get@ #color right) #Red]) - (red key value ?left (#.Some (blacken right))) - - _ - (case ?left - (^multi (#.Some left) - [(get@ #color left) #Black]) - (left-balance key value (#.Some (redden left)) ?right) - - (^multi (#.Some left) - [(get@ #color left) #Red] - [(get@ #right left) (#.Some left>>right)] - [(get@ #color left>>right) #Black]) - (red (get@ #key left>>right) - (get@ #value left>>right) - (#.Some (left-balance (get@ #key left) - (get@ #value left) - (:: maybe.Functor map redden (get@ #left left)) - (get@ #left left>>right))) - (#.Some (black key value (get@ #right left>>right) ?right))) - - _ - (error! error-message) - ))) - -(def: (prepend ?left ?right) - (All [k v] (-> (Maybe (Node k v)) (Maybe (Node k v)) (Maybe (Node k v)))) - (case [?left ?right] - [#.None _] - ?right - - [_ #.None] - ?left - - [(#.Some left) (#.Some right)] - (case [(get@ #color left) (get@ #color right)] - [#Red #Red] - (do maybe.Monad - [fused (prepend (get@ #right left) (get@ #right right))] - (case (get@ #color fused) - #Red - (wrap (red (get@ #key fused) - (get@ #value fused) - (#.Some (red (get@ #key left) - (get@ #value left) - (get@ #left left) - (get@ #left fused))) - (#.Some (red (get@ #key right) - (get@ #value right) - (get@ #right fused) - (get@ #right right))))) - - #Black - (wrap (red (get@ #key left) - (get@ #value left) - (get@ #left left) - (#.Some (red (get@ #key right) - (get@ #value right) - (#.Some fused) - (get@ #right right))))))) - - [#Red #Black] - (#.Some (red (get@ #key left) - (get@ #value left) - (get@ #left left) - (prepend (get@ #right left) - ?right))) - - [#Black #Red] - (#.Some (red (get@ #key right) - (get@ #value right) - (prepend ?left - (get@ #left right)) - (get@ #right right))) - - [#Black #Black] - (do maybe.Monad - [fused (prepend (get@ #right left) (get@ #left right))] - (case (get@ #color fused) - #Red - (wrap (red (get@ #key fused) - (get@ #value fused) - (#.Some (black (get@ #key left) - (get@ #value left) - (get@ #left left) - (get@ #left fused))) - (#.Some (black (get@ #key right) - (get@ #value right) - (get@ #right fused) - (get@ #right right))))) - - #Black - (wrap (balance-left-remove (get@ #key left) - (get@ #value left) - (get@ #left left) - (#.Some (black (get@ #key right) - (get@ #value right) - (#.Some fused) - (get@ #right right))))) - )) - ) - - _ - (undefined))) - -(def: #export (remove key dict) - (All [k v] (-> k (Dict k v) (Dict k v))) - (let [(^open "T/") (get@ #order dict) - [?root found?] (loop [?root (get@ #root dict)] - (case ?root - #.None - [#.None false] - - (#.Some root) - (let [root-key (get@ #key root) - root-val (get@ #value root)] - (if (T/= root-key key) - [(prepend (get@ #left root) - (get@ #right root)) - true] - (let [go-left? (T/< root-key key)] - (case (recur (if go-left? - (get@ #left root) - (get@ #right root))) - [#.None false] - [#.None false] - - [side-outcome _] - (if go-left? - (case (get@ #left root) - (^multi (#.Some left) - [(get@ #color left) #Black]) - [(#.Some (balance-left-remove root-key root-val side-outcome (get@ #right root))) - false] - - _ - [(#.Some (red root-key root-val side-outcome (get@ #right root))) - false]) - (case (get@ #right root) - (^multi (#.Some right) - [(get@ #color right) #Black]) - [(#.Some (balance-right-remove root-key root-val (get@ #left root) side-outcome)) - false] - - _ - [(#.Some (red root-key root-val (get@ #left root) side-outcome)) - false]) - ))) - )) - ))] - (case ?root - #.None - (if found? - (set@ #root ?root dict) - dict) - - (#.Some root) - (set@ #root (#.Some (blacken root)) dict) - ))) - -(def: #export (from-list Order list) - (All [k v] (-> (Order k) (List [k v]) (Dict k v))) - (L/fold (function (_ [key value] dict) - (put key value dict)) - (new Order) - list)) - -(do-template [ ] - [(def: #export ( dict) - (All [k v] (-> (Dict k v) (List ))) - (loop [node (get@ #root dict)] - (case node - #.None - (list) - - (#.Some node') - ($_ L/compose - (recur (get@ #left node')) - (list ) - (recur (get@ #right node'))))))] - - [entries [k v] [(get@ #key node') (get@ #value node')]] - [keys k (get@ #key node')] - [values v (get@ #value node')] - ) - -(struct: #export (Eq Eq) (All [k v] (-> (Eq v) (Eq (Dict k v)))) - (def: (= reference sample) - (let [Eq (:: sample eq)] - (loop [entriesR (entries reference) - entriesS (entries sample)] - (case [entriesR entriesS] - [#.Nil #.Nil] - true - - [(#.Cons [keyR valueR] entriesR') (#.Cons [keyS valueS] entriesS')] - (and (:: Eq = keyR keyS) - (:: Eq = valueR valueS) - (recur entriesR' entriesS')) - - _ - false))))) diff --git a/stdlib/source/lux/data/coll/set/ordered.lux b/stdlib/source/lux/data/coll/set/ordered.lux index 5d6ba5478..9ae151762 100644 --- a/stdlib/source/lux/data/coll/set/ordered.lux +++ b/stdlib/source/lux/data/coll/set/ordered.lux @@ -4,7 +4,7 @@ eq [order #+ Order]) (data (coll [list "L/" Monad Monoid Fold] - (ordered ["d" dict])) + (dict ["d" ordered])) ["p" product] ["M" maybe #+ Functor]) [macro] diff --git a/stdlib/source/lux/data/coll/set/unordered.lux b/stdlib/source/lux/data/coll/set/unordered.lux index a09300a7a..797ac7849 100644 --- a/stdlib/source/lux/data/coll/set/unordered.lux +++ b/stdlib/source/lux/data/coll/set/unordered.lux @@ -2,12 +2,12 @@ lux (lux (control [eq #+ Eq] [hash #*]) - (data (coll [dict] - [list "List/" Fold Functor])))) + (data (coll (dict ["dict" unordered #+ Dict]) + [list "list/" Fold Functor])))) ## [Types] (type: #export (Set a) - (dict.Dict a a)) + (Dict a a)) ## [Values] (def: #export (new Hash) @@ -32,7 +32,7 @@ (def: #export (from-list Hash xs) (All [a] (-> (Hash a) (List a) (Set a))) - (List/fold add (new Hash) xs)) + (list/fold add (new Hash) xs)) (def: #export (union xs yx) (All [a] (-> (Set a) (Set a) (Set a))) @@ -40,7 +40,7 @@ (def: #export (difference sub base) (All [a] (-> (Set a) (Set a) (Set a))) - (List/fold remove base (to-list sub))) + (list/fold remove base (to-list sub))) (def: #export (intersection filter base) (All [a] (-> (Set a) (Set a) (Set a))) @@ -71,6 +71,6 @@ (def: eq Eq) (def: (hash (^@ set [Hash _])) - (List/fold (function (_ elem acc) (n/+ (:: Hash hash elem) acc)) + (list/fold (function (_ elem acc) (n/+ (:: Hash hash elem) acc)) +0 (to-list set)))) diff --git a/stdlib/source/lux/data/format/context.lux b/stdlib/source/lux/data/format/context.lux index 9f58e9ede..c6ffbed82 100644 --- a/stdlib/source/lux/data/format/context.lux +++ b/stdlib/source/lux/data/format/context.lux @@ -4,13 +4,13 @@ ["ex" exception #+ exception:] [monad #+ do]) (data ["E" error] - (coll ["d" dict])))) + (coll (dict ["dict" unordered #+ Dict]))))) (exception: #export (Unknown-Property {property Text}) property) (type: #export Context - (d.Dict Text Text)) + (Dict Text Text)) (type: #export (Property a) (p.Parser Context a)) @@ -18,7 +18,7 @@ (def: #export (property name) (-> Text (Property Text)) (function (_ context) - (case (d.get name context) + (case (dict.get name context) (#.Some value) (ex.return [context value]) diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux index 86faa0509..8ce54e9f2 100644 --- a/stdlib/source/lux/data/format/json.lux +++ b/stdlib/source/lux/data/format/json.lux @@ -16,7 +16,7 @@ [product] (coll [list "list/" Fold Monad] [sequence #+ Sequence sequence "sequence/" Monad] - [dict #+ Dict])) + (dict ["dict" unordered #+ Dict]))) [macro #+ Monad with-gensyms] (macro ["s" syntax #+ syntax:] [code] diff --git a/stdlib/source/lux/data/format/xml.lux b/stdlib/source/lux/data/format/xml.lux index 29a4410fd..d3f3d6110 100644 --- a/stdlib/source/lux/data/format/xml.lux +++ b/stdlib/source/lux/data/format/xml.lux @@ -12,8 +12,8 @@ [product] [maybe "m/" Monad] [ident "ident/" Eq Codec] - (coll [list "L/" Monad] - ["d" dict])))) + (coll [list "list/" Monad] + (dict ["d" unordered]))))) (type: #export Tag Ident) (type: #export Attrs (d.Dict Ident Text)) @@ -191,8 +191,8 @@ (-> Attrs Text) (|> attrs d.entries - (L/map (function (_ [key value]) - ($_ text/compose (write-tag key) "=" "\""(sanitize-value value) "\""))) + (list/map (function (_ [key value]) + ($_ text/compose (write-tag key) "=" "\""(sanitize-value value) "\""))) (text.join-with " "))) (def: xml-header @@ -216,7 +216,7 @@ ($_ text/compose "<" tag attrs "/>") ($_ text/compose "<" tag attrs ">" (|> xml-children - (L/map recur) + (list/map recur) (text.join-with "")) ""))))))) @@ -254,7 +254,7 @@ (exception: #export (Unconsumed-Inputs {inputs (List XML)}) (|> inputs - (L/map (:: Codec encode)) + (list/map (:: Codec encode)) (text.join-with "\n\n"))) (def: #export text diff --git a/stdlib/source/lux/lang/syntax.lux b/stdlib/source/lux/lang/syntax.lux index 88a784980..1a9b5e84c 100644 --- a/stdlib/source/lux/lang/syntax.lux +++ b/stdlib/source/lux/lang/syntax.lux @@ -1,4 +1,4 @@ -## This is the LuxC's parser. +## This is LuxC's parser. ## It takes the source code of a Lux file in raw text form and ## extracts the syntactic structure of the code from it. ## It only produces Lux Code nodes, and thus removes any white-space @@ -38,7 +38,7 @@ (text ["l" lexer] format) (coll [sequence #+ Sequence] - [dict #+ Dict])))) + (dict ["dict" unordered #+ Dict]))))) (type: #export Aliases (Dict Text Text)) diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux index 7582e8a62..f7914f189 100644 --- a/stdlib/source/lux/macro/poly.lux +++ b/stdlib/source/lux/macro/poly.lux @@ -7,7 +7,7 @@ [function] (data [text "text/" Monoid] (coll [list "list/" Fold Monad Monoid] - [dict #+ Dict]) + (dict ["dict" unordered #+ Dict])) [number "nat/" Codec] [product] [bool] diff --git a/stdlib/source/lux/macro/poly/eq.lux b/stdlib/source/lux/macro/poly/eq.lux index a5b312a2d..d3a06fd30 100644 --- a/stdlib/source/lux/macro/poly/eq.lux +++ b/stdlib/source/lux/macro/poly/eq.lux @@ -10,7 +10,7 @@ [array] [queue] (set ["set" unordered]) - [dict #+ Dict] + (dict ["dict" unordered #+ Dict]) (tree [rose])) [number "nat/" Codec] [product] diff --git a/stdlib/source/lux/macro/poly/json.lux b/stdlib/source/lux/macro/poly/json.lux index d2e73d4a8..8abfeb65e 100644 --- a/stdlib/source/lux/macro/poly/json.lux +++ b/stdlib/source/lux/macro/poly/json.lux @@ -15,7 +15,7 @@ [product] (coll [list "list/" Fold Monad] [sequence #+ Sequence sequence "sequence/" Monad] - ["d" dict]) + (dict ["d" unordered])) (format ["//" json #+ JSON])) (time ## ["i" instant] ["du" duration] diff --git a/stdlib/source/lux/math/random.lux b/stdlib/source/lux/math/random.lux index 7172309d0..8e1dfd8fb 100644 --- a/stdlib/source/lux/math/random.lux +++ b/stdlib/source/lux/math/random.lux @@ -13,7 +13,7 @@ ["c" complex]) (coll [list "list/" Fold] [array] - [dict #+ Dict] + (dict ["dict" unordered #+ Dict]) [queue #+ Queue] (set ["set" unordered #+ Set]) [stack #+ Stack] diff --git a/stdlib/source/lux/type/implicit.lux b/stdlib/source/lux/type/implicit.lux index 88a2db2b8..fc08d01bc 100644 --- a/stdlib/source/lux/type/implicit.lux +++ b/stdlib/source/lux/type/implicit.lux @@ -7,7 +7,7 @@ text/format [number] (coll [list "list/" Monad Fold] - [dict]) + (dict ["dict" unordered #+ Dict])) [bool] [product] [maybe]) @@ -122,7 +122,7 @@ [local-batches macro.locals #let [total-locals (list/fold (function (_ [name type] table) (dict.put~ name type table)) - (: (dict.Dict Text Type) + (: (Dict Text Type) (dict.new text.Hash)) (list/join local-batches))]] (wrap (|> total-locals diff --git a/stdlib/source/lux/type/resource.lux b/stdlib/source/lux/type/resource.lux index ce792af96..a95207ac8 100644 --- a/stdlib/source/lux/type/resource.lux +++ b/stdlib/source/lux/type/resource.lux @@ -9,7 +9,7 @@ [product] [number] text/format - (coll [dict #+ Dict] + (coll (dict ["dict" unordered #+ Dict]) (set ["set" unordered]) [sequence #+ Sequence] [list "list/" Functor Fold])) diff --git a/stdlib/source/lux/world/env.jvm.lux b/stdlib/source/lux/world/env.jvm.lux index ee20b9b1c..70b6a91ff 100644 --- a/stdlib/source/lux/world/env.jvm.lux +++ b/stdlib/source/lux/world/env.jvm.lux @@ -2,7 +2,7 @@ lux (lux (data [text] (format [context #+ Context]) - (coll [dict])) + (coll (dict ["dict" unordered]))) [io #- run] [host])) diff --git a/stdlib/test/test/lux/data/coll/dict.lux b/stdlib/test/test/lux/data/coll/dict.lux deleted file mode 100644 index 01074b6fc..000000000 --- a/stdlib/test/test/lux/data/coll/dict.lux +++ /dev/null @@ -1,128 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do Monad] - [eq]) - (data [text] - text/format - [number] - [maybe] - (coll ["&" dict] - [list "list/" Fold Functor])) - ["r" math/random]) - lux/test) - -(context: "Dictionaries." - (<| (times +100) - (do @ - [#let [capped-nat (:: r.Monad map (n/% +100) r.nat)] - size capped-nat - dict (r.dict number.Hash size r.nat capped-nat) - non-key (|> r.nat (r.filter (function (_ key) (not (&.contains? key dict))))) - test-val (|> r.nat (r.filter (function (_ val) (not (list.member? number.Eq (&.values dict) val)))))] - ($_ seq - (test "Size function should correctly represent Dict size." - (n/= size (&.size dict))) - - (test "Dicts of size 0 should be considered empty." - (if (n/= +0 size) - (&.empty? dict) - (not (&.empty? dict)))) - - (test "The functions 'entries', 'keys' and 'values' should be synchronized." - (:: (list.Eq (eq.product number.Eq number.Eq)) = - (&.entries dict) - (list.zip2 (&.keys dict) - (&.values dict)))) - - (test "Dict should be able to recognize it's own keys." - (list.every? (function (_ key) (&.contains? key dict)) - (&.keys dict))) - - (test "Should be able to get every key." - (list.every? (function (_ key) (case (&.get key dict) - (#.Some _) true - _ false)) - (&.keys dict))) - - (test "Shouldn't be able to access non-existant keys." - (case (&.get non-key dict) - (#.Some _) false - _ true)) - - (test "Should be able to put and then get a value." - (case (&.get non-key (&.put non-key test-val dict)) - (#.Some v) (n/= test-val v) - _ true)) - - (test "Should be able to put~ and then get a value." - (case (&.get non-key (&.put~ non-key test-val dict)) - (#.Some v) (n/= test-val v) - _ true)) - - (test "Shouldn't be able to put~ an existing key." - (or (n/= +0 size) - (let [first-key (|> dict &.keys list.head maybe.assume)] - (case (&.get first-key (&.put~ first-key test-val dict)) - (#.Some v) (not (n/= test-val v)) - _ true)))) - - (test "Removing a key should make it's value inaccessible." - (let [base (&.put non-key test-val dict)] - (and (&.contains? non-key base) - (not (&.contains? non-key (&.remove non-key base)))))) - - (test "Should be possible to update values via their keys." - (let [base (&.put non-key test-val dict) - updt (&.update non-key n/inc base)] - (case [(&.get non-key base) (&.get non-key updt)] - [(#.Some x) (#.Some y)] - (n/= (n/inc x) y) - - _ - false))) - - (test "Additions and removals to a Dict should affect its size." - (let [plus (&.put non-key test-val dict) - base (&.remove non-key plus)] - (and (n/= (n/inc (&.size dict)) (&.size plus)) - (n/= (n/dec (&.size plus)) (&.size base))))) - - (test "A Dict should equal itself & going to<->from lists shouldn't change that." - (let [(^open) (&.Eq number.Eq)] - (and (= dict dict) - (|> dict &.entries (&.from-list number.Hash) (= dict))))) - - (test "Merging a Dict to itself changes nothing." - (let [(^open) (&.Eq number.Eq)] - (= dict (&.merge dict dict)))) - - (test "If you merge, and the second dict has overlapping keys, it should overwrite yours." - (let [dict' (|> dict &.entries - (list/map (function (_ [k v]) [k (n/inc v)])) - (&.from-list number.Hash)) - (^open) (&.Eq number.Eq)] - (= dict' (&.merge dict' dict)))) - - (test "Can merge values in such a way that they become combined." - (list.every? (function (_ [x x*2]) (n/= (n/* +2 x) x*2)) - (list.zip2 (&.values dict) - (&.values (&.merge-with n/+ dict dict))))) - - (test "Should be able to select subset of keys from dict." - (|> dict - (&.put non-key test-val) - (&.select (list non-key)) - &.size - (n/= +1))) - - (test "Should be able to re-bind existing values to different keys." - (or (n/= +0 size) - (let [first-key (|> dict &.keys list.head maybe.assume) - rebound (&.re-bind first-key non-key dict)] - (and (n/= (&.size dict) (&.size rebound)) - (&.contains? non-key rebound) - (not (&.contains? first-key rebound)) - (n/= (maybe.assume (&.get first-key dict)) - (maybe.assume (&.get non-key rebound))))))) - )))) diff --git a/stdlib/test/test/lux/data/coll/dict/ordered.lux b/stdlib/test/test/lux/data/coll/dict/ordered.lux new file mode 100644 index 000000000..73a1ebcad --- /dev/null +++ b/stdlib/test/test/lux/data/coll/dict/ordered.lux @@ -0,0 +1,88 @@ +(.module: + lux + (lux [io] + (control [monad #+ do Monad] + [eq #+ Eq]) + (data [product] + [number] + (coll (set ["s" unordered]) + (dict ["dict" unordered] + ["&" ordered]) + [list "L/" Functor])) + ["r" math/random]) + lux/test) + +(context: "Dict" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (n/% +100))) + keys (r.set number.Hash size r.nat) + values (r.set number.Hash size r.nat) + extra-key (|> r.nat (r.filter (|>> (s.member? keys) not))) + extra-value r.nat + #let [pairs (list.zip2 (s.to-list keys) + (s.to-list values)) + sample (&.from-list number.Order pairs) + sorted-pairs (list.sort (function (_ [left _] [right _]) + (n/< left right)) + pairs) + sorted-values (L/map product.right sorted-pairs) + (^open "&/") (&.Eq number.Eq)]] + ($_ seq + (test "Can query the size of a dictionary." + (n/= size (&.size sample))) + + (test "Can query value for minimum key." + (case [(&.min sample) (list.head sorted-values)] + [#.None #.None] + true + + [(#.Some reference) (#.Some sample)] + (n/= reference sample) + + _ + false)) + + (test "Can query value for maximum key." + (case [(&.max sample) (list.last sorted-values)] + [#.None #.None] + true + + [(#.Some reference) (#.Some sample)] + (n/= reference sample) + + _ + false)) + + (test "Converting dictionaries to/from lists cannot change their values." + (|> sample + &.entries (&.from-list number.Order) + (&/= sample))) + + (test "Order is preserved." + (let [(^open "L/") (list.Eq (: (Eq [Nat Nat]) + (function (_ [kr vr] [ks vs]) + (and (n/= kr ks) + (n/= vr vs)))))] + (L/= (&.entries sample) + sorted-pairs))) + + (test "Every key in a dictionary must be identifiable." + (list.every? (function (_ key) (&.contains? key sample)) + (&.keys sample))) + + (test "Can add and remove elements in a dictionary." + (and (not (&.contains? extra-key sample)) + (let [sample' (&.put extra-key extra-value sample) + sample'' (&.remove extra-key sample')] + (and (&.contains? extra-key sample') + (not (&.contains? extra-key sample'')) + (case [(&.get extra-key sample') + (&.get extra-key sample'')] + [(#.Some found) #.None] + (n/= extra-value found) + + _ + false))) + )) + )))) diff --git a/stdlib/test/test/lux/data/coll/dict/unordered.lux b/stdlib/test/test/lux/data/coll/dict/unordered.lux new file mode 100644 index 000000000..73b0df822 --- /dev/null +++ b/stdlib/test/test/lux/data/coll/dict/unordered.lux @@ -0,0 +1,128 @@ +(.module: + lux + (lux [io] + (control [monad #+ do Monad] + [eq]) + (data [text] + text/format + [number] + [maybe] + (coll (dict ["&" unordered]) + [list "list/" Fold Functor])) + ["r" math/random]) + lux/test) + +(context: "Dictionaries." + (<| (times +100) + (do @ + [#let [capped-nat (:: r.Monad map (n/% +100) r.nat)] + size capped-nat + dict (r.dict number.Hash size r.nat capped-nat) + non-key (|> r.nat (r.filter (function (_ key) (not (&.contains? key dict))))) + test-val (|> r.nat (r.filter (function (_ val) (not (list.member? number.Eq (&.values dict) val)))))] + ($_ seq + (test "Size function should correctly represent Dict size." + (n/= size (&.size dict))) + + (test "Dicts of size 0 should be considered empty." + (if (n/= +0 size) + (&.empty? dict) + (not (&.empty? dict)))) + + (test "The functions 'entries', 'keys' and 'values' should be synchronized." + (:: (list.Eq (eq.product number.Eq number.Eq)) = + (&.entries dict) + (list.zip2 (&.keys dict) + (&.values dict)))) + + (test "Dict should be able to recognize it's own keys." + (list.every? (function (_ key) (&.contains? key dict)) + (&.keys dict))) + + (test "Should be able to get every key." + (list.every? (function (_ key) (case (&.get key dict) + (#.Some _) true + _ false)) + (&.keys dict))) + + (test "Shouldn't be able to access non-existant keys." + (case (&.get non-key dict) + (#.Some _) false + _ true)) + + (test "Should be able to put and then get a value." + (case (&.get non-key (&.put non-key test-val dict)) + (#.Some v) (n/= test-val v) + _ true)) + + (test "Should be able to put~ and then get a value." + (case (&.get non-key (&.put~ non-key test-val dict)) + (#.Some v) (n/= test-val v) + _ true)) + + (test "Shouldn't be able to put~ an existing key." + (or (n/= +0 size) + (let [first-key (|> dict &.keys list.head maybe.assume)] + (case (&.get first-key (&.put~ first-key test-val dict)) + (#.Some v) (not (n/= test-val v)) + _ true)))) + + (test "Removing a key should make it's value inaccessible." + (let [base (&.put non-key test-val dict)] + (and (&.contains? non-key base) + (not (&.contains? non-key (&.remove non-key base)))))) + + (test "Should be possible to update values via their keys." + (let [base (&.put non-key test-val dict) + updt (&.update non-key n/inc base)] + (case [(&.get non-key base) (&.get non-key updt)] + [(#.Some x) (#.Some y)] + (n/= (n/inc x) y) + + _ + false))) + + (test "Additions and removals to a Dict should affect its size." + (let [plus (&.put non-key test-val dict) + base (&.remove non-key plus)] + (and (n/= (n/inc (&.size dict)) (&.size plus)) + (n/= (n/dec (&.size plus)) (&.size base))))) + + (test "A Dict should equal itself & going to<->from lists shouldn't change that." + (let [(^open) (&.Eq number.Eq)] + (and (= dict dict) + (|> dict &.entries (&.from-list number.Hash) (= dict))))) + + (test "Merging a Dict to itself changes nothing." + (let [(^open) (&.Eq number.Eq)] + (= dict (&.merge dict dict)))) + + (test "If you merge, and the second dict has overlapping keys, it should overwrite yours." + (let [dict' (|> dict &.entries + (list/map (function (_ [k v]) [k (n/inc v)])) + (&.from-list number.Hash)) + (^open) (&.Eq number.Eq)] + (= dict' (&.merge dict' dict)))) + + (test "Can merge values in such a way that they become combined." + (list.every? (function (_ [x x*2]) (n/= (n/* +2 x) x*2)) + (list.zip2 (&.values dict) + (&.values (&.merge-with n/+ dict dict))))) + + (test "Should be able to select subset of keys from dict." + (|> dict + (&.put non-key test-val) + (&.select (list non-key)) + &.size + (n/= +1))) + + (test "Should be able to re-bind existing values to different keys." + (or (n/= +0 size) + (let [first-key (|> dict &.keys list.head maybe.assume) + rebound (&.re-bind first-key non-key dict)] + (and (n/= (&.size dict) (&.size rebound)) + (&.contains? non-key rebound) + (not (&.contains? first-key rebound)) + (n/= (maybe.assume (&.get first-key dict)) + (maybe.assume (&.get non-key rebound))))))) + )))) diff --git a/stdlib/test/test/lux/data/coll/ordered/dict.lux b/stdlib/test/test/lux/data/coll/ordered/dict.lux deleted file mode 100644 index 301e64927..000000000 --- a/stdlib/test/test/lux/data/coll/ordered/dict.lux +++ /dev/null @@ -1,88 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do Monad] - [eq #+ Eq]) - (data [product] - [number] - (coll (ordered ["&" dict]) - (set ["s" unordered]) - ["d" dict] - [list "L/" Functor])) - ["r" math/random]) - lux/test) - -(context: "Dict" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (n/% +100))) - keys (r.set number.Hash size r.nat) - values (r.set number.Hash size r.nat) - extra-key (|> r.nat (r.filter (|>> (s.member? keys) not))) - extra-value r.nat - #let [pairs (list.zip2 (s.to-list keys) - (s.to-list values)) - sample (&.from-list number.Order pairs) - sorted-pairs (list.sort (function (_ [left _] [right _]) - (n/< left right)) - pairs) - sorted-values (L/map product.right sorted-pairs) - (^open "&/") (&.Eq number.Eq)]] - ($_ seq - (test "Can query the size of a dictionary." - (n/= size (&.size sample))) - - (test "Can query value for minimum key." - (case [(&.min sample) (list.head sorted-values)] - [#.None #.None] - true - - [(#.Some reference) (#.Some sample)] - (n/= reference sample) - - _ - false)) - - (test "Can query value for maximum key." - (case [(&.max sample) (list.last sorted-values)] - [#.None #.None] - true - - [(#.Some reference) (#.Some sample)] - (n/= reference sample) - - _ - false)) - - (test "Converting dictionaries to/from lists cannot change their values." - (|> sample - &.entries (&.from-list number.Order) - (&/= sample))) - - (test "Order is preserved." - (let [(^open "L/") (list.Eq (: (Eq [Nat Nat]) - (function (_ [kr vr] [ks vs]) - (and (n/= kr ks) - (n/= vr vs)))))] - (L/= (&.entries sample) - sorted-pairs))) - - (test "Every key in a dictionary must be identifiable." - (list.every? (function (_ key) (&.contains? key sample)) - (&.keys sample))) - - (test "Can add and remove elements in a dictionary." - (and (not (&.contains? extra-key sample)) - (let [sample' (&.put extra-key extra-value sample) - sample'' (&.remove extra-key sample')] - (and (&.contains? extra-key sample') - (not (&.contains? extra-key sample'')) - (case [(&.get extra-key sample') - (&.get extra-key sample'')] - [(#.Some found) #.None] - (n/= extra-value found) - - _ - false))) - )) - )))) diff --git a/stdlib/test/test/lux/data/format/json.lux b/stdlib/test/test/lux/data/format/json.lux index eec53b9cc..d302c63b0 100644 --- a/stdlib/test/test/lux/data/format/json.lux +++ b/stdlib/test/test/lux/data/format/json.lux @@ -14,7 +14,7 @@ [number] (format ["@" json]) (coll [sequence #+ sequence] - ["d" dict] + (dict ["d" unordered]) [list])) [macro #+ with-gensyms] (macro [code] diff --git a/stdlib/test/test/lux/data/format/xml.lux b/stdlib/test/test/lux/data/format/xml.lux index ed337a0b7..80ac5bcb1 100644 --- a/stdlib/test/test/lux/data/format/xml.lux +++ b/stdlib/test/test/lux/data/format/xml.lux @@ -10,8 +10,8 @@ ["E" error] [maybe] (format ["&" xml]) - (coll [dict] - [list "L/" Functor])) + (coll (dict ["dict" unordered]) + [list "list/" Functor])) ["r" math/random "r/" Monad] test) ) @@ -85,7 +85,7 @@ value (xml-text^ +1 +10) #let [node (#&.Node tag (dict.put attr value &.attrs) - (L/map (|>> #&.Text) children))]] + (list/map (|>> #&.Text) children))]] ($_ seq (test "Can parse text." (E.default false diff --git a/stdlib/test/test/lux/lang/syntax.lux b/stdlib/test/test/lux/lang/syntax.lux index 2b4d6789f..49967e071 100644 --- a/stdlib/test/test/lux/lang/syntax.lux +++ b/stdlib/test/test/lux/lang/syntax.lux @@ -8,7 +8,7 @@ (text format ["l" lexer]) (coll [list] - [dict #+ Dict])) + (dict ["dict" unordered #+ Dict]))) ["r" math/random "r/" Monad] (macro [code]) (lang ["&" syntax]) diff --git a/stdlib/test/test/lux/math/random.lux b/stdlib/test/test/lux/math/random.lux index eed882ea7..45c83016c 100644 --- a/stdlib/test/test/lux/math/random.lux +++ b/stdlib/test/test/lux/math/random.lux @@ -10,7 +10,7 @@ [queue] [stack] (set ["set" unordered]) - [dict])) + (dict ["dict" unordered]))) (math ["r" random])) lux/test) diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux index 9739c63e5..2c462e248 100644 --- a/stdlib/test/tests.lux +++ b/stdlib/test/tests.lux @@ -43,7 +43,8 @@ ["_." xml]) (coll ["_." array] ["_." bits] - ["_." dict] + ["_." dict/unordered] + ["_." dict/ordered] ["_." list] ["_." queue] ["_." set/unordered] @@ -53,8 +54,7 @@ ["_." priority-queue] ["_." stream] (tree ["tree_." rose] - ["tree_." zipper]) - (ordered ["ordered_." dict])) + ["tree_." zipper])) (text ["_." format] ["_." lexer] ["_." regex])) -- cgit v1.2.3