From 786532a1cad201a8f460f312b236e926b0c2959c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 1 May 2018 21:58:26 -0400 Subject: - Re-named "lux/data/coll/dict/*" to "lux/data/coll/dictionary/*". --- stdlib/source/lux/data/coll/dict/ordered.lux | 563 ----------------- stdlib/source/lux/data/coll/dict/unordered.lux | 685 --------------------- stdlib/source/lux/data/coll/dictionary/ordered.lux | 563 +++++++++++++++++ .../source/lux/data/coll/dictionary/unordered.lux | 685 +++++++++++++++++++++ stdlib/source/lux/data/coll/set/ordered.lux | 2 +- stdlib/source/lux/data/coll/set/unordered.lux | 2 +- stdlib/source/lux/data/format/context.lux | 2 +- stdlib/source/lux/data/format/json.lux | 2 +- stdlib/source/lux/data/format/xml.lux | 2 +- stdlib/source/lux/lang/syntax.lux | 2 +- 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 | 2 +- stdlib/source/lux/type/resource.lux | 2 +- stdlib/source/lux/world/env.jvm.lux | 2 +- 17 files changed, 1261 insertions(+), 1261 deletions(-) delete mode 100644 stdlib/source/lux/data/coll/dict/ordered.lux delete mode 100644 stdlib/source/lux/data/coll/dict/unordered.lux create mode 100644 stdlib/source/lux/data/coll/dictionary/ordered.lux create mode 100644 stdlib/source/lux/data/coll/dictionary/unordered.lux (limited to 'stdlib/source') diff --git a/stdlib/source/lux/data/coll/dict/ordered.lux b/stdlib/source/lux/data/coll/dict/ordered.lux deleted file mode 100644 index a099087f3..000000000 --- a/stdlib/source/lux/data/coll/dict/ordered.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/dict/unordered.lux b/stdlib/source/lux/data/coll/dict/unordered.lux deleted file mode 100644 index 97a119755..000000000 --- a/stdlib/source/lux/data/coll/dict/unordered.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/dictionary/ordered.lux b/stdlib/source/lux/data/coll/dictionary/ordered.lux new file mode 100644 index 000000000..a099087f3 --- /dev/null +++ b/stdlib/source/lux/data/coll/dictionary/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/dictionary/unordered.lux b/stdlib/source/lux/data/coll/dictionary/unordered.lux new file mode 100644 index 000000000..97a119755 --- /dev/null +++ b/stdlib/source/lux/data/coll/dictionary/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/set/ordered.lux b/stdlib/source/lux/data/coll/set/ordered.lux index 9ae151762..2e2ca56fc 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] - (dict ["d" ordered])) + (dictionary ["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 797ac7849..199a076c8 100644 --- a/stdlib/source/lux/data/coll/set/unordered.lux +++ b/stdlib/source/lux/data/coll/set/unordered.lux @@ -2,7 +2,7 @@ lux (lux (control [eq #+ Eq] [hash #*]) - (data (coll (dict ["dict" unordered #+ Dict]) + (data (coll (dictionary ["dict" unordered #+ Dict]) [list "list/" Fold Functor])))) ## [Types] diff --git a/stdlib/source/lux/data/format/context.lux b/stdlib/source/lux/data/format/context.lux index c6ffbed82..1810a66a2 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 (dict ["dict" unordered #+ Dict]))))) + (coll (dictionary ["dict" unordered #+ Dict]))))) (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 8ce54e9f2..7dfb7be5e 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" unordered #+ Dict]))) + (dictionary ["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 d3f3d6110..06b4b3994 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/" Eq Codec] (coll [list "list/" Monad] - (dict ["d" unordered]))))) + (dictionary ["d" unordered]))))) (type: #export Tag Ident) (type: #export Attrs (d.Dict Ident Text)) diff --git a/stdlib/source/lux/lang/syntax.lux b/stdlib/source/lux/lang/syntax.lux index 1a9b5e84c..1296cfaa5 100644 --- a/stdlib/source/lux/lang/syntax.lux +++ b/stdlib/source/lux/lang/syntax.lux @@ -38,7 +38,7 @@ (text ["l" lexer] format) (coll [sequence #+ Sequence] - (dict ["dict" unordered #+ Dict]))))) + (dictionary ["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 f7914f189..763596473 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" unordered #+ Dict])) + (dictionary ["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 d3a06fd30..7990bd3c4 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" unordered #+ Dict]) + (dictionary ["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 8abfeb65e..38bf86866 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] - (dict ["d" unordered])) + (dictionary ["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 8e1dfd8fb..60f9b729d 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" unordered #+ Dict]) + (dictionary ["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 fc08d01bc..bc361d5e5 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" unordered #+ Dict])) + (dictionary ["dict" unordered #+ Dict])) [bool] [product] [maybe]) diff --git a/stdlib/source/lux/type/resource.lux b/stdlib/source/lux/type/resource.lux index a95207ac8..bbef1783a 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" unordered #+ Dict]) + (coll (dictionary ["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 70b6a91ff..fab0de3cc 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 ["dict" unordered]))) + (coll (dictionary ["dict" unordered]))) [io #- run] [host])) -- cgit v1.2.3