From 2f4233ded0dce94c12f52db5fef0769670c78fdd Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 10 Jul 2018 20:12:58 -0400 Subject: - Re-organized dictionary & set modules a bit. --- stdlib/source/lux/control/predicate.lux | 2 +- stdlib/source/lux/data/coll/dictionary.lux | 685 +++++++++++++++++++++ .../source/lux/data/coll/dictionary/unordered.lux | 685 --------------------- stdlib/source/lux/data/coll/set.lux | 81 +++ stdlib/source/lux/data/coll/set/unordered.lux | 81 --- stdlib/source/lux/data/format/context.lux | 2 +- stdlib/source/lux/data/format/json.lux | 2 +- stdlib/source/lux/data/format/xml.lux | 2 +- .../lux/lang/compiler/analysis/case/coverage.lux | 2 +- .../lux/lang/compiler/analysis/structure.lux | 2 +- stdlib/source/lux/lang/compiler/extension.lux | 2 +- .../lux/lang/compiler/extension/analysis.lux | 2 +- .../lang/compiler/extension/analysis/common.lux | 2 +- .../lang/compiler/extension/analysis/host.jvm.lux | 2 +- .../source/lux/lang/compiler/extension/bundle.lux | 2 +- .../lux/lang/compiler/extension/synthesis.lux | 2 +- .../lux/lang/compiler/extension/translation.lux | 2 +- stdlib/source/lux/lang/compiler/meta/archive.lux | 2 +- stdlib/source/lux/lang/compiler/meta/cache.lux | 4 +- .../lux/lang/compiler/meta/cache/dependency.lux | 2 +- stdlib/source/lux/lang/compiler/synthesis.lux | 2 +- .../lux/lang/compiler/synthesis/expression.lux | 2 +- .../lux/lang/compiler/synthesis/function.lux | 2 +- stdlib/source/lux/lang/compiler/translation.lux | 2 +- .../lang/compiler/translation/scheme/case.jvm.lux | 2 +- .../compiler/translation/scheme/extension.jvm.lux | 2 +- .../translation/scheme/extension/common.jvm.lux | 2 +- stdlib/source/lux/lang/syntax.lux | 2 +- stdlib/source/lux/lang/type/check.lux | 2 +- stdlib/source/lux/macro/poly.lux | 2 +- stdlib/source/lux/macro/poly/equivalence.lux | 4 +- stdlib/source/lux/macro/poly/json.lux | 2 +- stdlib/source/lux/math/logic/fuzzy.lux | 2 +- stdlib/source/lux/math/random.lux | 4 +- stdlib/source/lux/type/implicit.lux | 2 +- stdlib/source/lux/type/object/interface.lux | 2 +- stdlib/source/lux/type/resource.lux | 4 +- stdlib/source/lux/world/env.jvm.lux | 2 +- stdlib/test/test/lux/control/interval.lux | 2 +- stdlib/test/test/lux/data/coll/dictionary.lux | 128 ++++ .../test/test/lux/data/coll/dictionary/ordered.lux | 6 +- .../test/lux/data/coll/dictionary/unordered.lux | 128 ---- stdlib/test/test/lux/data/coll/set.lux | 64 ++ stdlib/test/test/lux/data/coll/set/ordered.lux | 8 +- stdlib/test/test/lux/data/coll/set/unordered.lux | 64 -- stdlib/test/test/lux/data/format/json.lux | 2 +- stdlib/test/test/lux/data/format/xml.lux | 2 +- .../test/test/lux/lang/compiler/analysis/case.lux | 2 +- .../lang/compiler/analysis/procedure/host.jvm.lux | 2 +- .../test/lux/lang/compiler/analysis/structure.lux | 2 +- .../test/lux/lang/compiler/synthesis/function.lux | 4 +- stdlib/test/test/lux/lang/syntax.lux | 2 +- stdlib/test/test/lux/lang/type/check.lux | 2 +- stdlib/test/test/lux/math/logic/fuzzy.lux | 2 +- stdlib/test/test/lux/math/random.lux | 4 +- 55 files changed, 1016 insertions(+), 1016 deletions(-) create mode 100644 stdlib/source/lux/data/coll/dictionary.lux delete mode 100644 stdlib/source/lux/data/coll/dictionary/unordered.lux create mode 100644 stdlib/source/lux/data/coll/set.lux delete mode 100644 stdlib/source/lux/data/coll/set/unordered.lux create mode 100644 stdlib/test/test/lux/data/coll/dictionary.lux delete mode 100644 stdlib/test/test/lux/data/coll/dictionary/unordered.lux create mode 100644 stdlib/test/test/lux/data/coll/set.lux delete mode 100644 stdlib/test/test/lux/data/coll/set/unordered.lux diff --git a/stdlib/source/lux/control/predicate.lux b/stdlib/source/lux/control/predicate.lux index 56c048593..d7abc4139 100644 --- a/stdlib/source/lux/control/predicate.lux +++ b/stdlib/source/lux/control/predicate.lux @@ -1,7 +1,7 @@ (.module: lux (lux (control [monoid #+ Monoid]) - (data (coll (set ["set" unordered #+ Set]))) + (data (coll [set #+ Set])) [function])) (type: #export (Predicate a) diff --git a/stdlib/source/lux/data/coll/dictionary.lux b/stdlib/source/lux/data/coll/dictionary.lux new file mode 100644 index 000000000..e971228bb --- /dev/null +++ b/stdlib/source/lux/data/coll/dictionary.lux @@ -0,0 +1,685 @@ +(.module: + lux + (lux (control hash + [equivalence #+ Equivalence]) + (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 +## Dictionaries. +(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.left-shift (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.left-shift (n/- +1 branching-exponent) +1)) + +## The size of hierarchy-nodes, which is 2^(branching-exponent). +(def: hierarchy-nodes-size + Nat + (bit.left-shift 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 (inc old-size)) + (array.copy idx +0 old-array +0) + (array.write idx value) + (array.copy (n/- idx old-size) idx old-array (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 (dec (array.size array))] + (|> (array.new new-size) + (array.copy idx +0 array +0) + (array.copy (n/- idx new-size) (inc idx) array idx)))) + +## Given a top-limit for indices, produces all indices in [0, R). +(def: indices-for + (-> Nat (List Index)) + (|>> 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 (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.logical-right-shift level hash))) + +## A mechanism to go from indices to bit-positions. +(def: (->bit-position index) + (-> Index BitPosition) + (bit.left-shift 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) + 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] + [(inc insertion-idx) + [(set-bit-position (->bit-position idx) bitmap) + (array.write insertion-idx (#.Left sub-node) base)]]) + ))) + [+0 [clean-bitmap + (array.new (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) + [(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 (~~ (static ..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] + + _ + [(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 (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 (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 (Dictionary 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) (Dictionary k v))) + {#hash Hash + #root empty}) + +(def: #export (put key val dict) + (All [k v] (-> k v (Dictionary k v) (Dictionary 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 (Dictionary k v) (Dictionary 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 (Dictionary 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 (Dictionary 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 (Dictionary k v) (Dictionary 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) (Dictionary k v) (Dictionary 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) (Dictionary k v) (Dictionary k v))) + (put key + (f (maybe.default default + (get key dict))) + dict)) + +(def: #export size + (All [k v] (-> (Dictionary k v) Nat)) + (|>> product.right size')) + +(def: #export empty? + (All [k v] (-> (Dictionary k v) Bool)) + (|>> size (n/= +0))) + +(def: #export (entries dict) + (All [k v] (-> (Dictionary k v) (List [k v]))) + (entries' (product.right dict))) + +(def: #export (from-list Hash kvs) + (All [k v] (-> (Hash k) (List [k v]) (Dictionary k v))) + (list/fold (function (_ [k v] dict) + (put k v dict)) + (new Hash) + kvs)) + +(do-template [ ] + [(def: #export ( dict) + (All [k v] (-> (Dictionary 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] (-> (Dictionary k v) (Dictionary k v) (Dictionary 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) (Dictionary k v) (Dictionary k v) (Dictionary 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 (Dictionary k v) (Dictionary 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) (Dictionary k v) (Dictionary 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] +(structure: #export (Equivalence Equivalence) (All [k v] (-> (Equivalence v) (Equivalence (Dictionary 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)] + (:: Equivalence = tk sk) + + _ + false)) + (keys test))))) diff --git a/stdlib/source/lux/data/coll/dictionary/unordered.lux b/stdlib/source/lux/data/coll/dictionary/unordered.lux deleted file mode 100644 index e971228bb..000000000 --- a/stdlib/source/lux/data/coll/dictionary/unordered.lux +++ /dev/null @@ -1,685 +0,0 @@ -(.module: - lux - (lux (control hash - [equivalence #+ Equivalence]) - (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 -## Dictionaries. -(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.left-shift (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.left-shift (n/- +1 branching-exponent) +1)) - -## The size of hierarchy-nodes, which is 2^(branching-exponent). -(def: hierarchy-nodes-size - Nat - (bit.left-shift 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 (inc old-size)) - (array.copy idx +0 old-array +0) - (array.write idx value) - (array.copy (n/- idx old-size) idx old-array (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 (dec (array.size array))] - (|> (array.new new-size) - (array.copy idx +0 array +0) - (array.copy (n/- idx new-size) (inc idx) array idx)))) - -## Given a top-limit for indices, produces all indices in [0, R). -(def: indices-for - (-> Nat (List Index)) - (|>> 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 (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.logical-right-shift level hash))) - -## A mechanism to go from indices to bit-positions. -(def: (->bit-position index) - (-> Index BitPosition) - (bit.left-shift 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) - 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] - [(inc insertion-idx) - [(set-bit-position (->bit-position idx) bitmap) - (array.write insertion-idx (#.Left sub-node) base)]]) - ))) - [+0 [clean-bitmap - (array.new (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) - [(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 (~~ (static ..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] - - _ - [(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 (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 (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 (Dictionary 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) (Dictionary k v))) - {#hash Hash - #root empty}) - -(def: #export (put key val dict) - (All [k v] (-> k v (Dictionary k v) (Dictionary 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 (Dictionary k v) (Dictionary 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 (Dictionary 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 (Dictionary 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 (Dictionary k v) (Dictionary 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) (Dictionary k v) (Dictionary 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) (Dictionary k v) (Dictionary k v))) - (put key - (f (maybe.default default - (get key dict))) - dict)) - -(def: #export size - (All [k v] (-> (Dictionary k v) Nat)) - (|>> product.right size')) - -(def: #export empty? - (All [k v] (-> (Dictionary k v) Bool)) - (|>> size (n/= +0))) - -(def: #export (entries dict) - (All [k v] (-> (Dictionary k v) (List [k v]))) - (entries' (product.right dict))) - -(def: #export (from-list Hash kvs) - (All [k v] (-> (Hash k) (List [k v]) (Dictionary k v))) - (list/fold (function (_ [k v] dict) - (put k v dict)) - (new Hash) - kvs)) - -(do-template [ ] - [(def: #export ( dict) - (All [k v] (-> (Dictionary 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] (-> (Dictionary k v) (Dictionary k v) (Dictionary 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) (Dictionary k v) (Dictionary k v) (Dictionary 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 (Dictionary k v) (Dictionary 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) (Dictionary k v) (Dictionary 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] -(structure: #export (Equivalence Equivalence) (All [k v] (-> (Equivalence v) (Equivalence (Dictionary 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)] - (:: Equivalence = tk sk) - - _ - false)) - (keys test))))) diff --git a/stdlib/source/lux/data/coll/set.lux b/stdlib/source/lux/data/coll/set.lux new file mode 100644 index 000000000..929040ad0 --- /dev/null +++ b/stdlib/source/lux/data/coll/set.lux @@ -0,0 +1,81 @@ +(.module: + lux + (lux (control [equivalence #+ Equivalence] + [hash #+ Hash]) + (data (coll ["dict" dictionary #+ Dictionary] + [list "list/" Fold])) + (type abstract))) + +(abstract: #export (Set a) + {} + + (Dictionary a a) + + (def: #export new + (All [a] (-> (Hash a) (Set a))) + (|>> dict.new :abstraction)) + + (def: #export size + (All [a] (-> (Set a) Nat)) + (|>> :representation dict.size)) + + (def: #export (add elem set) + (All [a] (-> a (Set a) (Set a))) + (|> set :representation (dict.put elem elem) :abstraction)) + + (def: #export (remove elem set) + (All [a] (-> a (Set a) (Set a))) + (|> set :representation (dict.remove elem) :abstraction)) + + (def: #export (member? set elem) + (All [a] (-> (Set a) a Bool)) + (|> set :representation (dict.contains? elem))) + + (def: #export to-list + (All [a] (-> (Set a) (List a))) + (|>> :representation dict.keys)) + + (def: #export (union xs yx) + (All [a] (-> (Set a) (Set a) (Set a))) + (:abstraction (dict.merge (:representation xs) (:representation yx)))) + + (def: #export (difference sub base) + (All [a] (-> (Set a) (Set a) (Set a))) + (list/fold ..remove base (..to-list sub))) + + (def: #export (intersection filter base) + (All [a] (-> (Set a) (Set a) (Set a))) + (:abstraction (dict.select (dict.keys (:representation filter)) + (:representation base)))) + + (structure: #export Equivalence (All [a] (Equivalence (Set a))) + (def: (= reference sample) + (let [[Hash _] (:representation reference)] + (:: (list.Equivalence (get@ #hash.eq Hash)) = + (..to-list reference) (..to-list sample))))) + + (structure: #export Hash (All [a] (Hash (Set a))) + (def: eq ..Equivalence) + + (def: (hash set) + (let [[Hash _] (:representation set)] + (list/fold (function (_ elem acc) (n/+ (:: Hash hash elem) acc)) + +0 + (..to-list set))))) + ) + +(def: #export empty? + (All [a] (-> (Set a) Bool)) + (|>> ..size (n/= +0))) + +(def: #export (from-list Hash xs) + (All [a] (-> (Hash a) (List a) (Set a))) + (list/fold ..add (..new Hash) xs)) + +(def: #export (sub? super sub) + (All [a] (-> (Set a) (Set a) Bool)) + (list.every? (..member? super) (..to-list sub))) + +(def: #export (super? sub super) + (All [a] (-> (Set a) (Set a) Bool)) + (sub? super sub)) diff --git a/stdlib/source/lux/data/coll/set/unordered.lux b/stdlib/source/lux/data/coll/set/unordered.lux deleted file mode 100644 index ba5b1e8eb..000000000 --- a/stdlib/source/lux/data/coll/set/unordered.lux +++ /dev/null @@ -1,81 +0,0 @@ -(.module: - lux - (lux (control [equivalence #+ Equivalence] - [hash #+ Hash]) - (data (coll (dictionary ["dict" unordered #+ Dictionary]) - [list "list/" Fold])) - (type abstract))) - -(abstract: #export (Set a) - {} - - (Dictionary a a) - - (def: #export new - (All [a] (-> (Hash a) (Set a))) - (|>> dict.new :abstraction)) - - (def: #export size - (All [a] (-> (Set a) Nat)) - (|>> :representation dict.size)) - - (def: #export (add elem set) - (All [a] (-> a (Set a) (Set a))) - (|> set :representation (dict.put elem elem) :abstraction)) - - (def: #export (remove elem set) - (All [a] (-> a (Set a) (Set a))) - (|> set :representation (dict.remove elem) :abstraction)) - - (def: #export (member? set elem) - (All [a] (-> (Set a) a Bool)) - (|> set :representation (dict.contains? elem))) - - (def: #export to-list - (All [a] (-> (Set a) (List a))) - (|>> :representation dict.keys)) - - (def: #export (union xs yx) - (All [a] (-> (Set a) (Set a) (Set a))) - (:abstraction (dict.merge (:representation xs) (:representation yx)))) - - (def: #export (difference sub base) - (All [a] (-> (Set a) (Set a) (Set a))) - (list/fold ..remove base (..to-list sub))) - - (def: #export (intersection filter base) - (All [a] (-> (Set a) (Set a) (Set a))) - (:abstraction (dict.select (dict.keys (:representation filter)) - (:representation base)))) - - (structure: #export Equivalence (All [a] (Equivalence (Set a))) - (def: (= reference sample) - (let [[Hash _] (:representation reference)] - (:: (list.Equivalence (get@ #hash.eq Hash)) = - (..to-list reference) (..to-list sample))))) - - (structure: #export Hash (All [a] (Hash (Set a))) - (def: eq ..Equivalence) - - (def: (hash set) - (let [[Hash _] (:representation set)] - (list/fold (function (_ elem acc) (n/+ (:: Hash hash elem) acc)) - +0 - (..to-list set))))) - ) - -(def: #export empty? - (All [a] (-> (Set a) Bool)) - (|>> ..size (n/= +0))) - -(def: #export (from-list Hash xs) - (All [a] (-> (Hash a) (List a) (Set a))) - (list/fold ..add (..new Hash) xs)) - -(def: #export (sub? super sub) - (All [a] (-> (Set a) (Set a) Bool)) - (list.every? (..member? super) (..to-list sub))) - -(def: #export (super? sub super) - (All [a] (-> (Set a) (Set a) Bool)) - (sub? super sub)) diff --git a/stdlib/source/lux/data/format/context.lux b/stdlib/source/lux/data/format/context.lux index 0eee7a061..f9874f6d2 100644 --- a/stdlib/source/lux/data/format/context.lux +++ b/stdlib/source/lux/data/format/context.lux @@ -4,7 +4,7 @@ ["ex" exception #+ exception:] [monad #+ do]) (data ["E" error] - (coll (dictionary ["dict" unordered #+ Dictionary]))))) + (coll ["dict" dictionary #+ Dictionary])))) (exception: #export (unknown-property {property Text}) property) diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux index af6348fef..c3069c939 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] [row #+ Row row "row/" Monad] - (dictionary ["dict" unordered #+ Dictionary]))) + ["dict" dictionary #+ Dictionary])) [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 2edae8971..dd389c55b 100644 --- a/stdlib/source/lux/data/format/xml.lux +++ b/stdlib/source/lux/data/format/xml.lux @@ -13,7 +13,7 @@ [maybe "m/" Monad] [ident "ident/" Equivalence Codec] (coll [list "list/" Monad] - (dictionary ["d" unordered]))))) + ["d" dictionary])))) (type: #export Tag Ident) (type: #export Attrs (d.Dictionary Ident Text)) diff --git a/stdlib/source/lux/lang/compiler/analysis/case/coverage.lux b/stdlib/source/lux/lang/compiler/analysis/case/coverage.lux index 20000a8e0..c76f98091 100644 --- a/stdlib/source/lux/lang/compiler/analysis/case/coverage.lux +++ b/stdlib/source/lux/lang/compiler/analysis/case/coverage.lux @@ -9,7 +9,7 @@ [maybe] text/format (coll [list "list/" Fold] - (dictionary ["dict" unordered #+ Dictionary])))) + ["dict" dictionary #+ Dictionary]))) [//// "operation/" Monad] [/// #+ Pattern Variant Operation]) diff --git a/stdlib/source/lux/lang/compiler/analysis/structure.lux b/stdlib/source/lux/lang/compiler/analysis/structure.lux index 7307d6472..dd832fe47 100644 --- a/stdlib/source/lux/lang/compiler/analysis/structure.lux +++ b/stdlib/source/lux/lang/compiler/analysis/structure.lux @@ -7,7 +7,7 @@ [product] [maybe] (coll [list "list/" Functor] - (dictionary ["dict" unordered #+ Dictionary])) + ["dict" dictionary #+ Dictionary]) text/format) [macro] (macro [code])) diff --git a/stdlib/source/lux/lang/compiler/extension.lux b/stdlib/source/lux/lang/compiler/extension.lux index 19f993163..ce01c16ae 100644 --- a/stdlib/source/lux/lang/compiler/extension.lux +++ b/stdlib/source/lux/lang/compiler/extension.lux @@ -4,7 +4,7 @@ ["ex" exception #+ exception:]) (data [error #+ Error] [text] - (coll (dictionary ["dict" unordered #+ Dictionary])))) + (coll ["dict" dictionary #+ Dictionary]))) [// #+ Operation Compiler]) (type: #export (Extension i) diff --git a/stdlib/source/lux/lang/compiler/extension/analysis.lux b/stdlib/source/lux/lang/compiler/extension/analysis.lux index 9a28ff39f..b770e2f7e 100644 --- a/stdlib/source/lux/lang/compiler/extension/analysis.lux +++ b/stdlib/source/lux/lang/compiler/extension/analysis.lux @@ -2,7 +2,7 @@ lux (lux (data [text] (coll [list "list/" Functor] - (dictionary ["dict" unordered #+ Dictionary])))) + ["dict" dictionary #+ Dictionary]))) [///analysis #+ Analysis State] [///synthesis #+ Synthesis] [//] diff --git a/stdlib/source/lux/lang/compiler/extension/analysis/common.lux b/stdlib/source/lux/lang/compiler/extension/analysis/common.lux index 71df4c678..1afbc13aa 100644 --- a/stdlib/source/lux/lang/compiler/extension/analysis/common.lux +++ b/stdlib/source/lux/lang/compiler/extension/analysis/common.lux @@ -8,7 +8,7 @@ text/format (coll [list "list/" Functor] [array] - (dictionary ["dict" unordered #+ Dictionary]))) + ["dict" dictionary #+ Dictionary])) [lang] (lang (type ["tc" check])) [io #+ IO]) diff --git a/stdlib/source/lux/lang/compiler/extension/analysis/host.jvm.lux b/stdlib/source/lux/lang/compiler/extension/analysis/host.jvm.lux index ead713305..4316c4a53 100644 --- a/stdlib/source/lux/lang/compiler/extension/analysis/host.jvm.lux +++ b/stdlib/source/lux/lang/compiler/extension/analysis/host.jvm.lux @@ -12,7 +12,7 @@ ["l" lexer]) (coll [list "list/" Fold Functor Monoid] [array] - (dictionary ["dict" unordered #+ Dictionary]))) + ["dict" dictionary #+ Dictionary])) [macro "macro/" Monad] (macro [code] ["s" syntax]) diff --git a/stdlib/source/lux/lang/compiler/extension/bundle.lux b/stdlib/source/lux/lang/compiler/extension/bundle.lux index e68c391c6..e4f918ef3 100644 --- a/stdlib/source/lux/lang/compiler/extension/bundle.lux +++ b/stdlib/source/lux/lang/compiler/extension/bundle.lux @@ -5,7 +5,7 @@ (data [text] text/format (coll [list "list/" Functor] - (dictionary ["dict" unordered #+ Dictionary])))) + ["dict" dictionary #+ Dictionary]))) [//]) (exception: #export (incorrect-arity {name Text} {arity Nat} {args Nat}) diff --git a/stdlib/source/lux/lang/compiler/extension/synthesis.lux b/stdlib/source/lux/lang/compiler/extension/synthesis.lux index ca20b0738..d06a2b144 100644 --- a/stdlib/source/lux/lang/compiler/extension/synthesis.lux +++ b/stdlib/source/lux/lang/compiler/extension/synthesis.lux @@ -1,7 +1,7 @@ (.module: lux (lux (data [text] - (coll (dictionary ["dict" unordered #+ Dictionary])))) + (coll ["dict" dictionary #+ Dictionary]))) [//]) (def: #export defaults diff --git a/stdlib/source/lux/lang/compiler/extension/translation.lux b/stdlib/source/lux/lang/compiler/extension/translation.lux index 2063d5fb2..367288981 100644 --- a/stdlib/source/lux/lang/compiler/extension/translation.lux +++ b/stdlib/source/lux/lang/compiler/extension/translation.lux @@ -1,7 +1,7 @@ (.module: lux (lux (data [text] - (coll (dictionary ["dict" unordered #+ Dictionary])))) + (coll ["dict" dictionary #+ Dictionary]))) [//]) (def: #export defaults diff --git a/stdlib/source/lux/lang/compiler/meta/archive.lux b/stdlib/source/lux/lang/compiler/meta/archive.lux index 09dfa211a..4a86055e8 100644 --- a/stdlib/source/lux/lang/compiler/meta/archive.lux +++ b/stdlib/source/lux/lang/compiler/meta/archive.lux @@ -7,7 +7,7 @@ [ident] [text] text/format - (coll (dictionary ["dict" unordered #+ Dictionary]))) + (coll ["dict" dictionary #+ Dictionary])) (lang [type #+ :share]) (type abstract) (world [file #+ File])) diff --git a/stdlib/source/lux/lang/compiler/meta/cache.lux b/stdlib/source/lux/lang/compiler/meta/cache.lux index dc5dda4a8..54919feb8 100644 --- a/stdlib/source/lux/lang/compiler/meta/cache.lux +++ b/stdlib/source/lux/lang/compiler/meta/cache.lux @@ -11,8 +11,8 @@ [text] text/format (coll [list "list/" Functor Fold] - (dictionary ["dict" unordered #+ Dictionary]) - (set ["set" unordered #+ Set]))) + ["dict" dictionary #+ Dictionary] + [set #+ Set])) (world [file #+ File System])) [//io #+ Context Module] [//io/context] diff --git a/stdlib/source/lux/lang/compiler/meta/cache/dependency.lux b/stdlib/source/lux/lang/compiler/meta/cache/dependency.lux index e6d94dc65..843644887 100644 --- a/stdlib/source/lux/lang/compiler/meta/cache/dependency.lux +++ b/stdlib/source/lux/lang/compiler/meta/cache/dependency.lux @@ -2,7 +2,7 @@ [lux #- Module] (lux (data [text] (coll [list "list/" Functor Fold] - (dictionary ["dict" unordered #+ Dictionary])))) + ["dict" dictionary #+ Dictionary]))) [///io #+ Module] [///archive #+ Archive]) diff --git a/stdlib/source/lux/lang/compiler/synthesis.lux b/stdlib/source/lux/lang/compiler/synthesis.lux index bd23523e3..46f376adf 100644 --- a/stdlib/source/lux/lang/compiler/synthesis.lux +++ b/stdlib/source/lux/lang/compiler/synthesis.lux @@ -2,7 +2,7 @@ [lux #- i64 Scope] (lux (control [monad #+ do]) (data [error #+ Error] - (coll (dictionary ["dict" unordered #+ Dictionary])))) + (coll ["dict" dictionary #+ Dictionary]))) [///reference #+ Register Variable Reference] [// #+ Operation Compiler] [//analysis #+ Environment Arity Analysis]) diff --git a/stdlib/source/lux/lang/compiler/synthesis/expression.lux b/stdlib/source/lux/lang/compiler/synthesis/expression.lux index 81cc89b08..c9e3c577a 100644 --- a/stdlib/source/lux/lang/compiler/synthesis/expression.lux +++ b/stdlib/source/lux/lang/compiler/synthesis/expression.lux @@ -4,7 +4,7 @@ ["ex" exception #+ exception:]) (data [maybe] (coll [list "list/" Functor] - (dictionary ["dict" unordered #+ Dictionary])))) + ["dict" dictionary #+ Dictionary]))) [///reference] [///compiler "operation/" Monad] [///analysis #+ Analysis] diff --git a/stdlib/source/lux/lang/compiler/synthesis/function.lux b/stdlib/source/lux/lang/compiler/synthesis/function.lux index 5d31a947b..2d2fffbf8 100644 --- a/stdlib/source/lux/lang/compiler/synthesis/function.lux +++ b/stdlib/source/lux/lang/compiler/synthesis/function.lux @@ -7,7 +7,7 @@ (data [maybe "maybe/" Monad] [error] (coll [list "list/" Functor Monoid Fold] - (dictionary ["dict" unordered #+ Dictionary])))) + ["dict" dictionary #+ Dictionary]))) [///reference #+ Variable] [///compiler #+ Operation] [///analysis #+ Environment Arity Analysis] diff --git a/stdlib/source/lux/lang/compiler/translation.lux b/stdlib/source/lux/lang/compiler/translation.lux index 80c606f30..1400cb446 100644 --- a/stdlib/source/lux/lang/compiler/translation.lux +++ b/stdlib/source/lux/lang/compiler/translation.lux @@ -7,7 +7,7 @@ [text] text/format (coll [row #+ Row] - (dictionary ["dict" unordered #+ Dictionary]))) + ["dict" dictionary #+ Dictionary])) (world [file #+ File])) [// #+ Operation Compiler] [//synthesis #+ Synthesis]) diff --git a/stdlib/source/lux/lang/compiler/translation/scheme/case.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/case.jvm.lux index 0ee52c54b..70da9d5d8 100644 --- a/stdlib/source/lux/lang/compiler/translation/scheme/case.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/case.jvm.lux @@ -6,7 +6,7 @@ [text] text/format (coll [list "list/" Functor Fold] - (set ["set" unordered #+ Set])))) + [set #+ Set]))) (///// [reference #+ Register] (host ["_" scheme #+ Expression Computation Var]) [compiler #+ "operation/" Monad] diff --git a/stdlib/source/lux/lang/compiler/translation/scheme/extension.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/extension.jvm.lux index 7170d29b7..c894053d2 100644 --- a/stdlib/source/lux/lang/compiler/translation/scheme/extension.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/extension.jvm.lux @@ -4,7 +4,7 @@ ["ex" exception #+ exception:]) (data [maybe] text/format - (coll (dictionary ["dict" unordered #+ Dictionary])))) + (coll ["dict" dictionary #+ Dictionary]))) (///// [reference #+ Register Variable] (host ["_" scheme #+ Computation]) [compiler "operation/" Monad] diff --git a/stdlib/source/lux/lang/compiler/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/extension/common.jvm.lux index 044b75cac..e79b11c3b 100644 --- a/stdlib/source/lux/lang/compiler/translation/scheme/extension/common.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/extension/common.jvm.lux @@ -8,7 +8,7 @@ text/format [number #+ hex] (coll [list "list/" Functor] - (dictionary ["dict" unordered #+ Dictionary]))) + ["dict" dictionary #+ Dictionary])) [macro #+ with-gensyms] (macro [code] ["s" syntax #+ syntax:]) diff --git a/stdlib/source/lux/lang/syntax.lux b/stdlib/source/lux/lang/syntax.lux index 6211edf8a..2822e5e31 100644 --- a/stdlib/source/lux/lang/syntax.lux +++ b/stdlib/source/lux/lang/syntax.lux @@ -37,7 +37,7 @@ (text ["l" lexer] format) (coll [row #+ Row] - (dictionary ["dict" unordered #+ Dictionary]))))) + ["dict" dictionary #+ Dictionary])))) (type: #export Aliases (Dictionary Text Text)) diff --git a/stdlib/source/lux/lang/type/check.lux b/stdlib/source/lux/lang/type/check.lux index ab1b6be1d..fa21654b7 100644 --- a/stdlib/source/lux/lang/type/check.lux +++ b/stdlib/source/lux/lang/type/check.lux @@ -9,7 +9,7 @@ [maybe] [product] (coll [list] - (set ["set" unordered #+ Set])) + [set #+ Set]) ["e" error]) (lang [type "type/" Equivalence]) )) diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux index 0ed67fdf1..429a93bde 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] - (dictionary ["dict" unordered #+ Dictionary])) + ["dict" dictionary #+ Dictionary]) [number "nat/" Codec] [product] [bool] diff --git a/stdlib/source/lux/macro/poly/equivalence.lux b/stdlib/source/lux/macro/poly/equivalence.lux index 44fd60ed5..f8e178700 100644 --- a/stdlib/source/lux/macro/poly/equivalence.lux +++ b/stdlib/source/lux/macro/poly/equivalence.lux @@ -9,8 +9,8 @@ [row] [array] [queue] - (set ["set" unordered]) - (dictionary ["dict" unordered #+ Dictionary]) + [set] + ["dict" dictionary #+ Dictionary] (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 1c198c1fe..8f7a1170e 100644 --- a/stdlib/source/lux/macro/poly/json.lux +++ b/stdlib/source/lux/macro/poly/json.lux @@ -16,7 +16,7 @@ [product] (coll [list "list/" Fold Monad] [row #+ Row row "row/" Monad] - (dictionary ["d" unordered])) + ["d" dictionary]) (format ["//" json #+ JSON])) (time ## ["i" instant] ["du" duration] diff --git a/stdlib/source/lux/math/logic/fuzzy.lux b/stdlib/source/lux/math/logic/fuzzy.lux index 57f5978f3..9ee9b1685 100644 --- a/stdlib/source/lux/math/logic/fuzzy.lux +++ b/stdlib/source/lux/math/logic/fuzzy.lux @@ -2,7 +2,7 @@ lux (lux (data [number "Rev/" Interval] (coll [list] - (set ["set" unordered #+ Set])) + [set #+ Set]) text/format) [math]) (// ["&" continuous])) diff --git a/stdlib/source/lux/math/random.lux b/stdlib/source/lux/math/random.lux index 887e53a9f..218c9131b 100644 --- a/stdlib/source/lux/math/random.lux +++ b/stdlib/source/lux/math/random.lux @@ -14,9 +14,9 @@ ["c" complex]) (coll [list "list/" Fold] [array] - (dictionary ["dict" unordered #+ Dictionary]) + ["dict" dictionary #+ Dictionary] [queue #+ Queue] - (set ["set" unordered #+ Set]) + [set #+ Set] [stack #+ Stack] [row #+ Row] (tree [finger #+ Tree]))) diff --git a/stdlib/source/lux/type/implicit.lux b/stdlib/source/lux/type/implicit.lux index 85ebe33c3..aa0326b93 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] - (dictionary ["dict" unordered #+ Dictionary])) + ["dict" dictionary #+ Dictionary]) [bool] [product] [maybe]) diff --git a/stdlib/source/lux/type/object/interface.lux b/stdlib/source/lux/type/object/interface.lux index e16a89f44..c2eca52ce 100644 --- a/stdlib/source/lux/type/object/interface.lux +++ b/stdlib/source/lux/type/object/interface.lux @@ -8,7 +8,7 @@ [maybe] [ident #+ "ident/" Equivalence] (coll [list "list/" Functor Fold Monoid] - (set ["set" unordered #+ Set]))) + [set #+ Set])) [macro #+ Monad "meta/" Monad] (macro [code] ["s" syntax #+ syntax:] diff --git a/stdlib/source/lux/type/resource.lux b/stdlib/source/lux/type/resource.lux index 60eeef73b..cf2650f74 100644 --- a/stdlib/source/lux/type/resource.lux +++ b/stdlib/source/lux/type/resource.lux @@ -9,8 +9,8 @@ [product] [number] text/format - (coll (dictionary ["dict" unordered #+ Dictionary]) - (set ["set" unordered]) + (coll ["dict" dictionary #+ Dictionary] + [set] [row #+ Row] [list "list/" Functor Fold])) (concurrency [promise #+ Promise]) diff --git a/stdlib/source/lux/world/env.jvm.lux b/stdlib/source/lux/world/env.jvm.lux index e2511416e..39c5f9472 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 (dictionary ["dict" unordered]))) + (coll ["dict" dictionary])) [io #- run] [host])) diff --git a/stdlib/test/test/lux/control/interval.lux b/stdlib/test/test/lux/control/interval.lux index 06fe5cbde..6b6e96789 100644 --- a/stdlib/test/test/lux/control/interval.lux +++ b/stdlib/test/test/lux/control/interval.lux @@ -8,7 +8,7 @@ ["r" math/random] (data text/format [number] - (coll ["S" set/unordered] + (coll ["S" set] ["L" list])))) (context: "Equivalence." diff --git a/stdlib/test/test/lux/data/coll/dictionary.lux b/stdlib/test/test/lux/data/coll/dictionary.lux new file mode 100644 index 000000000..9c652ee7a --- /dev/null +++ b/stdlib/test/test/lux/data/coll/dictionary.lux @@ -0,0 +1,128 @@ +(.module: + lux + (lux [io] + (control [monad #+ do Monad] + ["eq" equivalence]) + (data [text] + text/format + [number] + [maybe] + (coll ["&" dictionary] + [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.dictionary 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.Equivalence (&.values dict) val)))))] + ($_ seq + (test "Size function should correctly represent Dictionary size." + (n/= size (&.size dict))) + + (test "Dictionaries 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.Equivalence (eq.product number.Equivalence number.Equivalence)) = + (&.entries dict) + (list.zip2 (&.keys dict) + (&.values dict)))) + + (test "Dictionary 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 inc base)] + (case [(&.get non-key base) (&.get non-key updt)] + [(#.Some x) (#.Some y)] + (n/= (inc x) y) + + _ + false))) + + (test "Additions and removals to a Dictionary should affect its size." + (let [plus (&.put non-key test-val dict) + base (&.remove non-key plus)] + (and (n/= (inc (&.size dict)) (&.size plus)) + (n/= (dec (&.size plus)) (&.size base))))) + + (test "A Dictionary should equal itself & going to<->from lists shouldn't change that." + (let [(^open) (&.Equivalence number.Equivalence)] + (and (= dict dict) + (|> dict &.entries (&.from-list number.Hash) (= dict))))) + + (test "Merging a Dictionary to itself changes nothing." + (let [(^open) (&.Equivalence number.Equivalence)] + (= 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 (inc v)])) + (&.from-list number.Hash)) + (^open) (&.Equivalence number.Equivalence)] + (= 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/dictionary/ordered.lux b/stdlib/test/test/lux/data/coll/dictionary/ordered.lux index bfcd4b569..548fd7f83 100644 --- a/stdlib/test/test/lux/data/coll/dictionary/ordered.lux +++ b/stdlib/test/test/lux/data/coll/dictionary/ordered.lux @@ -5,9 +5,9 @@ [equivalence #+ Equivalence]) (data [product] [number] - (coll (set ["s" unordered]) - (dictionary ["dict" unordered] - ["&" ordered]) + (coll ["s" set] + ["dict" dictionary] + (dictionary ["&" ordered]) [list "L/" Functor])) ["r" math/random]) lux/test) diff --git a/stdlib/test/test/lux/data/coll/dictionary/unordered.lux b/stdlib/test/test/lux/data/coll/dictionary/unordered.lux deleted file mode 100644 index 3476898b6..000000000 --- a/stdlib/test/test/lux/data/coll/dictionary/unordered.lux +++ /dev/null @@ -1,128 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do Monad] - ["eq" equivalence]) - (data [text] - text/format - [number] - [maybe] - (coll (dictionary ["&" 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.dictionary 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.Equivalence (&.values dict) val)))))] - ($_ seq - (test "Size function should correctly represent Dictionary size." - (n/= size (&.size dict))) - - (test "Dictionaries 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.Equivalence (eq.product number.Equivalence number.Equivalence)) = - (&.entries dict) - (list.zip2 (&.keys dict) - (&.values dict)))) - - (test "Dictionary 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 inc base)] - (case [(&.get non-key base) (&.get non-key updt)] - [(#.Some x) (#.Some y)] - (n/= (inc x) y) - - _ - false))) - - (test "Additions and removals to a Dictionary should affect its size." - (let [plus (&.put non-key test-val dict) - base (&.remove non-key plus)] - (and (n/= (inc (&.size dict)) (&.size plus)) - (n/= (dec (&.size plus)) (&.size base))))) - - (test "A Dictionary should equal itself & going to<->from lists shouldn't change that." - (let [(^open) (&.Equivalence number.Equivalence)] - (and (= dict dict) - (|> dict &.entries (&.from-list number.Hash) (= dict))))) - - (test "Merging a Dictionary to itself changes nothing." - (let [(^open) (&.Equivalence number.Equivalence)] - (= 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 (inc v)])) - (&.from-list number.Hash)) - (^open) (&.Equivalence number.Equivalence)] - (= 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/set.lux b/stdlib/test/test/lux/data/coll/set.lux new file mode 100644 index 000000000..6b341ee3a --- /dev/null +++ b/stdlib/test/test/lux/data/coll/set.lux @@ -0,0 +1,64 @@ +(.module: + lux + (lux [io] + (control [monad #+ do Monad]) + (data (coll ["&" set #+ Set] + [list "" Fold]) + [number]) + ["r" math/random]) + lux/test) + +(def: gen-nat + (r.Random Nat) + (|> r.nat + (:: r.Monad map (n/% +100)))) + +(context: "Sets" + (<| (times +100) + (do @ + [sizeL gen-nat + sizeR gen-nat + setL (r.set number.Hash sizeL gen-nat) + setR (r.set number.Hash sizeR gen-nat) + non-member (|> gen-nat + (r.filter (|>> (&.member? setL) not))) + #let [(^open "&/") &.Equivalence]] + ($_ seq + (test "I can query the size of a set." + (and (n/= sizeL (&.size setL)) + (n/= sizeR (&.size setR)))) + + (test "Converting sets to/from lists can't change their values." + (|> setL + &.to-list (&.from-list number.Hash) + (&/= setL))) + + (test "Every set is a sub-set of the union of itself with another." + (let [setLR (&.union setL setR)] + (and (&.sub? setLR setL) + (&.sub? setLR setR)))) + + (test "Every set is a super-set of the intersection of itself with another." + (let [setLR (&.intersection setL setR)] + (and (&.super? setLR setL) + (&.super? setLR setR)))) + + (test "Union with the empty set leaves a set unchanged." + (&/= setL + (&.union (&.new number.Hash) + setL))) + + (test "Intersection with the empty set results in the empty set." + (let [empty-set (&.new number.Hash)] + (&/= empty-set + (&.intersection empty-set setL)))) + + (test "After substracting a set A from another B, no member of A can be a member of B." + (let [sub (&.difference setR setL)] + (not (list.any? (&.member? sub) (&.to-list setR))))) + + (test "Every member of a set must be identifiable." + (and (not (&.member? setL non-member)) + (&.member? (&.add non-member setL) non-member) + (not (&.member? (&.remove non-member (&.add non-member setL)) non-member)))) + )))) diff --git a/stdlib/test/test/lux/data/coll/set/ordered.lux b/stdlib/test/test/lux/data/coll/set/ordered.lux index fd4fb5579..6833bf4a6 100644 --- a/stdlib/test/test/lux/data/coll/set/ordered.lux +++ b/stdlib/test/test/lux/data/coll/set/ordered.lux @@ -2,8 +2,8 @@ lux (lux [io] (control [monad #+ do Monad]) - (data (coll (set ["s" unordered] - ["&" ordered]) + (data (coll [set] + (set ["&" ordered]) [list "" Fold]) [number] text/format) @@ -20,8 +20,8 @@ (do @ [sizeL gen-nat sizeR gen-nat - listL (|> (r.set number.Hash sizeL gen-nat) (:: @ map s.to-list)) - listR (|> (r.set number.Hash sizeR gen-nat) (:: @ map s.to-list)) + listL (|> (r.set number.Hash sizeL gen-nat) (:: @ map set.to-list)) + listR (|> (r.set number.Hash sizeR gen-nat) (:: @ map set.to-list)) #let [(^open "&/") &.Equivalence setL (&.from-list number.Order listL) setR (&.from-list number.Order listR) diff --git a/stdlib/test/test/lux/data/coll/set/unordered.lux b/stdlib/test/test/lux/data/coll/set/unordered.lux deleted file mode 100644 index f17867665..000000000 --- a/stdlib/test/test/lux/data/coll/set/unordered.lux +++ /dev/null @@ -1,64 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do Monad]) - (data (coll (set ["&" unordered #+ Set]) - [list "" Fold]) - [number]) - ["r" math/random]) - lux/test) - -(def: gen-nat - (r.Random Nat) - (|> r.nat - (:: r.Monad map (n/% +100)))) - -(context: "Sets" - (<| (times +100) - (do @ - [sizeL gen-nat - sizeR gen-nat - setL (r.set number.Hash sizeL gen-nat) - setR (r.set number.Hash sizeR gen-nat) - non-member (|> gen-nat - (r.filter (|>> (&.member? setL) not))) - #let [(^open "&/") &.Equivalence]] - ($_ seq - (test "I can query the size of a set." - (and (n/= sizeL (&.size setL)) - (n/= sizeR (&.size setR)))) - - (test "Converting sets to/from lists can't change their values." - (|> setL - &.to-list (&.from-list number.Hash) - (&/= setL))) - - (test "Every set is a sub-set of the union of itself with another." - (let [setLR (&.union setL setR)] - (and (&.sub? setLR setL) - (&.sub? setLR setR)))) - - (test "Every set is a super-set of the intersection of itself with another." - (let [setLR (&.intersection setL setR)] - (and (&.super? setLR setL) - (&.super? setLR setR)))) - - (test "Union with the empty set leaves a set unchanged." - (&/= setL - (&.union (&.new number.Hash) - setL))) - - (test "Intersection with the empty set results in the empty set." - (let [empty-set (&.new number.Hash)] - (&/= empty-set - (&.intersection empty-set setL)))) - - (test "After substracting a set A from another B, no member of A can be a member of B." - (let [sub (&.difference setR setL)] - (not (list.any? (&.member? sub) (&.to-list setR))))) - - (test "Every member of a set must be identifiable." - (and (not (&.member? setL non-member)) - (&.member? (&.add non-member setL) non-member) - (not (&.member? (&.remove non-member (&.add non-member setL)) non-member)))) - )))) diff --git a/stdlib/test/test/lux/data/format/json.lux b/stdlib/test/test/lux/data/format/json.lux index 27e9850e0..02a82bc63 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 [row #+ row] - (dictionary ["d" unordered]) + ["d" dictionary] [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 acdd2aec8..dd82c2e14 100644 --- a/stdlib/test/test/lux/data/format/xml.lux +++ b/stdlib/test/test/lux/data/format/xml.lux @@ -10,7 +10,7 @@ ["E" error] [maybe] (format ["&" xml]) - (coll (dictionary ["dict" unordered]) + (coll ["dict" dictionary] [list "list/" Functor])) ["r" math/random "r/" Monad] test) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/case.lux b/stdlib/test/test/lux/lang/compiler/analysis/case.lux index 21fa2b9f9..2088a775b 100644 --- a/stdlib/test/test/lux/lang/compiler/analysis/case.lux +++ b/stdlib/test/test/lux/lang/compiler/analysis/case.lux @@ -10,7 +10,7 @@ [text "T/" Equivalence] text/format (coll [list "list/" Monad] - (set ["set" unordered]))) + [set])) ["r" math/random "r/" Monad] [macro #+ Monad] (macro [code]) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/procedure/host.jvm.lux b/stdlib/test/test/lux/lang/compiler/analysis/procedure/host.jvm.lux index af4741918..7aa527c93 100644 --- a/stdlib/test/test/lux/lang/compiler/analysis/procedure/host.jvm.lux +++ b/stdlib/test/test/lux/lang/compiler/analysis/procedure/host.jvm.lux @@ -11,7 +11,7 @@ text/format (coll [array] [list "list/" Fold] - (dictionary ["dict" unordered]))) + ["dict" dictionary])) ["r" math/random "r/" Monad] [macro #+ Monad] (macro [code]) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/structure.lux b/stdlib/test/test/lux/lang/compiler/analysis/structure.lux index d9d029d31..0fc97dfbe 100644 --- a/stdlib/test/test/lux/lang/compiler/analysis/structure.lux +++ b/stdlib/test/test/lux/lang/compiler/analysis/structure.lux @@ -10,7 +10,7 @@ [text] text/format (coll [list "list/" Functor] - (set ["set" unordered]))) + [set])) ["r" math/random "r/" Monad] [macro] (macro [code]) diff --git a/stdlib/test/test/lux/lang/compiler/synthesis/function.lux b/stdlib/test/test/lux/lang/compiler/synthesis/function.lux index ba7d015e2..44df282b9 100644 --- a/stdlib/test/test/lux/lang/compiler/synthesis/function.lux +++ b/stdlib/test/test/lux/lang/compiler/synthesis/function.lux @@ -9,8 +9,8 @@ [number] text/format (coll [list "list/" Functor Fold] - (dictionary ["dict" unordered #+ Dictionary]) - (set ["set" unordered]))) + ["dict" dictionary #+ Dictionary] + [set])) (lang ["///." reference #+ Variable "variable/" Equivalence] ["///." compiler] [".L" analysis #+ Arity Analysis] diff --git a/stdlib/test/test/lux/lang/syntax.lux b/stdlib/test/test/lux/lang/syntax.lux index d9a16b2c3..f3066368e 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] - (dictionary ["dict" unordered #+ Dictionary]))) + ["dict" dictionary #+ Dictionary])) ["r" math/random "r/" Monad] (macro [code]) (lang ["&" syntax]) diff --git a/stdlib/test/test/lux/lang/type/check.lux b/stdlib/test/test/lux/lang/type/check.lux index 2ffee1318..7a65782de 100644 --- a/stdlib/test/test/lux/lang/type/check.lux +++ b/stdlib/test/test/lux/lang/type/check.lux @@ -9,7 +9,7 @@ [text "text/" Monoid Equivalence] text/format (coll [list "list/" Functor] - (set ["set" unordered]))) + [set])) ["r" math/random] (lang [type "type/" Equivalence] ["@" type/check])) diff --git a/stdlib/test/test/lux/math/logic/fuzzy.lux b/stdlib/test/test/lux/math/logic/fuzzy.lux index 3fa7c66cc..d4a8ced61 100644 --- a/stdlib/test/test/lux/math/logic/fuzzy.lux +++ b/stdlib/test/test/lux/math/logic/fuzzy.lux @@ -3,7 +3,7 @@ (lux [io] (control [monad #+ do Monad]) (data (coll [list] - (set ["set" unordered])) + [set]) [bool "B/" Equivalence] [number] text/format) diff --git a/stdlib/test/test/lux/math/random.lux b/stdlib/test/test/lux/math/random.lux index 46d9edef4..1e85636d5 100644 --- a/stdlib/test/test/lux/math/random.lux +++ b/stdlib/test/test/lux/math/random.lux @@ -9,8 +9,8 @@ [array] [queue] [stack] - (set ["set" unordered]) - (dictionary ["dict" unordered]))) + [set] + ["dict" dictionary])) (math ["r" random])) lux/test) -- cgit v1.2.3