From 83f18eb967cfaa4f3403f58f3f80bc4945218cd8 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 10 Jul 2018 20:42:57 -0400 Subject: - Re-named path "lux/data/coll/*" to "lux/data/collection/*". --- stdlib/source/lux.lux | 4 +- stdlib/source/lux/cli.lux | 2 +- stdlib/source/lux/concurrency/actor.lux | 2 +- stdlib/source/lux/concurrency/frp.lux | 2 +- stdlib/source/lux/concurrency/stm.lux | 2 +- stdlib/source/lux/control/comonad.lux | 4 +- stdlib/source/lux/control/concatenative.lux | 2 +- stdlib/source/lux/control/exception.lux | 2 +- stdlib/source/lux/control/monad/indexed.lux | 2 +- stdlib/source/lux/control/parser.lux | 2 +- stdlib/source/lux/control/pipe.lux | 2 +- stdlib/source/lux/control/predicate.lux | 2 +- stdlib/source/lux/control/region.lux | 2 +- stdlib/source/lux/data/coll/array.lux | 211 ------- stdlib/source/lux/data/coll/bits.lux | 164 ----- stdlib/source/lux/data/coll/dictionary.lux | 685 --------------------- stdlib/source/lux/data/coll/dictionary/ordered.lux | 569 ----------------- stdlib/source/lux/data/coll/dictionary/plist.lux | 62 -- stdlib/source/lux/data/coll/list.lux | 554 ----------------- stdlib/source/lux/data/coll/queue.lux | 78 --- stdlib/source/lux/data/coll/queue/priority.lux | 102 --- stdlib/source/lux/data/coll/row.lux | 437 ------------- stdlib/source/lux/data/coll/sequence.lux | 146 ----- stdlib/source/lux/data/coll/set.lux | 81 --- stdlib/source/lux/data/coll/set/ordered.lux | 86 --- stdlib/source/lux/data/coll/stack.lux | 42 -- stdlib/source/lux/data/coll/tree/finger.lux | 61 -- stdlib/source/lux/data/coll/tree/rose.lux | 73 --- stdlib/source/lux/data/coll/tree/rose/parser.lux | 50 -- stdlib/source/lux/data/coll/tree/rose/zipper.lux | 235 ------- stdlib/source/lux/data/collection/array.lux | 211 +++++++ stdlib/source/lux/data/collection/bits.lux | 164 +++++ stdlib/source/lux/data/collection/dictionary.lux | 685 +++++++++++++++++++++ .../lux/data/collection/dictionary/ordered.lux | 569 +++++++++++++++++ .../lux/data/collection/dictionary/plist.lux | 62 ++ stdlib/source/lux/data/collection/list.lux | 554 +++++++++++++++++ stdlib/source/lux/data/collection/queue.lux | 78 +++ .../source/lux/data/collection/queue/priority.lux | 102 +++ stdlib/source/lux/data/collection/row.lux | 437 +++++++++++++ stdlib/source/lux/data/collection/sequence.lux | 146 +++++ stdlib/source/lux/data/collection/set.lux | 81 +++ stdlib/source/lux/data/collection/set/ordered.lux | 86 +++ stdlib/source/lux/data/collection/stack.lux | 42 ++ stdlib/source/lux/data/collection/tree/finger.lux | 61 ++ stdlib/source/lux/data/collection/tree/rose.lux | 73 +++ .../lux/data/collection/tree/rose/parser.lux | 50 ++ .../lux/data/collection/tree/rose/zipper.lux | 235 +++++++ stdlib/source/lux/data/color.lux | 2 +- stdlib/source/lux/data/format/context.lux | 2 +- stdlib/source/lux/data/format/css.lux | 2 +- stdlib/source/lux/data/format/html.lux | 2 +- stdlib/source/lux/data/format/json.lux | 6 +- stdlib/source/lux/data/format/xml.lux | 4 +- stdlib/source/lux/data/number/complex.lux | 2 +- stdlib/source/lux/data/text.lux | 2 +- stdlib/source/lux/data/text/buffer.lux | 2 +- stdlib/source/lux/data/text/format.lux | 2 +- stdlib/source/lux/data/text/lexer.lux | 2 +- stdlib/source/lux/data/text/regex.lux | 2 +- stdlib/source/lux/data/text/unicode.lux | 4 +- stdlib/source/lux/host.js.lux | 2 +- stdlib/source/lux/host.jvm.lux | 2 +- stdlib/source/lux/io.lux | 2 +- stdlib/source/lux/lang/compiler/analysis.lux | 2 +- stdlib/source/lux/lang/compiler/analysis/case.lux | 2 +- .../lux/lang/compiler/analysis/case/coverage.lux | 4 +- .../source/lux/lang/compiler/analysis/function.lux | 2 +- .../lux/lang/compiler/analysis/inference.lux | 2 +- .../lux/lang/compiler/analysis/structure.lux | 4 +- .../source/lux/lang/compiler/default/repl/type.lux | 2 +- stdlib/source/lux/lang/compiler/extension.lux | 2 +- .../lux/lang/compiler/extension/analysis.lux | 4 +- .../lang/compiler/extension/analysis/common.lux | 6 +- .../lang/compiler/extension/analysis/host.jvm.lux | 6 +- .../source/lux/lang/compiler/extension/bundle.lux | 4 +- .../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 | 6 +- .../lux/lang/compiler/meta/cache/dependency.lux | 4 +- stdlib/source/lux/lang/compiler/synthesis.lux | 2 +- stdlib/source/lux/lang/compiler/synthesis/case.lux | 2 +- .../lux/lang/compiler/synthesis/expression.lux | 4 +- .../lux/lang/compiler/synthesis/function.lux | 4 +- stdlib/source/lux/lang/compiler/synthesis/loop.lux | 2 +- stdlib/source/lux/lang/compiler/translation.lux | 4 +- .../lang/compiler/translation/scheme/case.jvm.lux | 10 +- .../compiler/translation/scheme/extension.jvm.lux | 2 +- .../translation/scheme/extension/common.jvm.lux | 4 +- .../compiler/translation/scheme/function.jvm.lux | 2 +- .../lang/compiler/translation/scheme/loop.jvm.lux | 2 +- .../compiler/translation/scheme/runtime.jvm.lux | 2 +- stdlib/source/lux/lang/host/scheme.lux | 2 +- stdlib/source/lux/lang/module.lux | 4 +- stdlib/source/lux/lang/scope.lux | 4 +- stdlib/source/lux/lang/syntax.lux | 4 +- stdlib/source/lux/lang/type.lux | 2 +- stdlib/source/lux/lang/type/check.lux | 4 +- stdlib/source/lux/macro.lux | 2 +- stdlib/source/lux/macro/code.lux | 2 +- stdlib/source/lux/macro/poly.lux | 4 +- stdlib/source/lux/macro/poly/equivalence.lux | 14 +- stdlib/source/lux/macro/poly/functor.lux | 2 +- stdlib/source/lux/macro/poly/json.lux | 6 +- stdlib/source/lux/macro/syntax.lux | 2 +- stdlib/source/lux/macro/syntax/common/reader.lux | 2 +- stdlib/source/lux/macro/syntax/common/writer.lux | 2 +- stdlib/source/lux/math.lux | 2 +- stdlib/source/lux/math/logic/fuzzy.lux | 7 +- stdlib/source/lux/math/random.lux | 16 +- stdlib/source/lux/test.lux | 6 +- stdlib/source/lux/time/date.lux | 2 +- stdlib/source/lux/time/instant.lux | 4 +- stdlib/source/lux/type/abstract.lux | 2 +- stdlib/source/lux/type/implicit.lux | 4 +- stdlib/source/lux/type/object/interface.lux | 4 +- stdlib/source/lux/type/object/protocol.lux | 2 +- stdlib/source/lux/type/resource.lux | 8 +- stdlib/source/lux/world/env.jvm.lux | 2 +- stdlib/source/lux/world/file.lux | 2 +- stdlib/source/lux/world/net/udp.jvm.lux | 2 +- stdlib/test/test/lux/cli.lux | 2 +- stdlib/test/test/lux/concurrency/atom.lux | 2 +- stdlib/test/test/lux/concurrency/frp.lux | 2 +- stdlib/test/test/lux/concurrency/semaphore.lux | 2 +- stdlib/test/test/lux/concurrency/stm.lux | 2 +- stdlib/test/test/lux/control/continuation.lux | 2 +- stdlib/test/test/lux/control/interval.lux | 4 +- stdlib/test/test/lux/control/region.lux | 2 +- stdlib/test/test/lux/data/coll/array.lux | 140 ----- stdlib/test/test/lux/data/coll/bits.lux | 80 --- stdlib/test/test/lux/data/coll/dictionary.lux | 128 ---- .../test/test/lux/data/coll/dictionary/ordered.lux | 88 --- stdlib/test/test/lux/data/coll/list.lux | 235 ------- stdlib/test/test/lux/data/coll/queue.lux | 51 -- stdlib/test/test/lux/data/coll/queue/priority.lux | 52 -- stdlib/test/test/lux/data/coll/row.lux | 73 --- stdlib/test/test/lux/data/coll/sequence.lux | 101 --- stdlib/test/test/lux/data/coll/set.lux | 64 -- stdlib/test/test/lux/data/coll/set/ordered.lux | 94 --- stdlib/test/test/lux/data/coll/stack.lux | 45 -- stdlib/test/test/lux/data/coll/tree/rose.lux | 47 -- .../test/test/lux/data/coll/tree/rose/zipper.lux | 124 ---- stdlib/test/test/lux/data/collection/array.lux | 140 +++++ stdlib/test/test/lux/data/collection/bits.lux | 80 +++ .../test/test/lux/data/collection/dictionary.lux | 128 ++++ .../lux/data/collection/dictionary/ordered.lux | 88 +++ stdlib/test/test/lux/data/collection/list.lux | 235 +++++++ stdlib/test/test/lux/data/collection/queue.lux | 51 ++ .../test/lux/data/collection/queue/priority.lux | 52 ++ stdlib/test/test/lux/data/collection/row.lux | 73 +++ stdlib/test/test/lux/data/collection/sequence.lux | 101 +++ stdlib/test/test/lux/data/collection/set.lux | 64 ++ .../test/test/lux/data/collection/set/ordered.lux | 94 +++ stdlib/test/test/lux/data/collection/stack.lux | 45 ++ stdlib/test/test/lux/data/collection/tree/rose.lux | 47 ++ .../test/lux/data/collection/tree/rose/zipper.lux | 124 ++++ stdlib/test/test/lux/data/format/json.lux | 6 +- stdlib/test/test/lux/data/format/xml.lux | 4 +- stdlib/test/test/lux/data/number/complex.lux | 2 +- stdlib/test/test/lux/data/sum.lux | 2 +- stdlib/test/test/lux/data/text.lux | 2 +- stdlib/test/test/lux/data/text/lexer.lux | 2 +- .../test/test/lux/lang/compiler/analysis/case.lux | 4 +- .../test/lux/lang/compiler/analysis/function.lux | 2 +- .../lang/compiler/analysis/procedure/common.lux | 2 +- .../lang/compiler/analysis/procedure/host.jvm.lux | 6 +- .../test/lux/lang/compiler/analysis/structure.lux | 4 +- .../test/lux/lang/compiler/synthesis/function.lux | 6 +- .../test/lux/lang/compiler/synthesis/structure.lux | 2 +- stdlib/test/test/lux/lang/syntax.lux | 4 +- stdlib/test/test/lux/lang/type.lux | 2 +- stdlib/test/test/lux/lang/type/check.lux | 4 +- stdlib/test/test/lux/macro/poly/equivalence.lux | 2 +- stdlib/test/test/lux/math/logic/fuzzy.lux | 4 +- stdlib/test/test/lux/math/random.lux | 14 +- stdlib/test/test/lux/type/implicit.lux | 2 +- stdlib/test/test/lux/type/object/interface.lux | 2 +- stdlib/test/test/lux/world/blob.lux | 2 +- 179 files changed, 5148 insertions(+), 5151 deletions(-) delete mode 100644 stdlib/source/lux/data/coll/array.lux delete mode 100644 stdlib/source/lux/data/coll/bits.lux delete mode 100644 stdlib/source/lux/data/coll/dictionary.lux delete mode 100644 stdlib/source/lux/data/coll/dictionary/ordered.lux delete mode 100644 stdlib/source/lux/data/coll/dictionary/plist.lux delete mode 100644 stdlib/source/lux/data/coll/list.lux delete mode 100644 stdlib/source/lux/data/coll/queue.lux delete mode 100644 stdlib/source/lux/data/coll/queue/priority.lux delete mode 100644 stdlib/source/lux/data/coll/row.lux delete mode 100644 stdlib/source/lux/data/coll/sequence.lux delete mode 100644 stdlib/source/lux/data/coll/set.lux delete mode 100644 stdlib/source/lux/data/coll/set/ordered.lux delete mode 100644 stdlib/source/lux/data/coll/stack.lux delete mode 100644 stdlib/source/lux/data/coll/tree/finger.lux delete mode 100644 stdlib/source/lux/data/coll/tree/rose.lux delete mode 100644 stdlib/source/lux/data/coll/tree/rose/parser.lux delete mode 100644 stdlib/source/lux/data/coll/tree/rose/zipper.lux create mode 100644 stdlib/source/lux/data/collection/array.lux create mode 100644 stdlib/source/lux/data/collection/bits.lux create mode 100644 stdlib/source/lux/data/collection/dictionary.lux create mode 100644 stdlib/source/lux/data/collection/dictionary/ordered.lux create mode 100644 stdlib/source/lux/data/collection/dictionary/plist.lux create mode 100644 stdlib/source/lux/data/collection/list.lux create mode 100644 stdlib/source/lux/data/collection/queue.lux create mode 100644 stdlib/source/lux/data/collection/queue/priority.lux create mode 100644 stdlib/source/lux/data/collection/row.lux create mode 100644 stdlib/source/lux/data/collection/sequence.lux create mode 100644 stdlib/source/lux/data/collection/set.lux create mode 100644 stdlib/source/lux/data/collection/set/ordered.lux create mode 100644 stdlib/source/lux/data/collection/stack.lux create mode 100644 stdlib/source/lux/data/collection/tree/finger.lux create mode 100644 stdlib/source/lux/data/collection/tree/rose.lux create mode 100644 stdlib/source/lux/data/collection/tree/rose/parser.lux create mode 100644 stdlib/source/lux/data/collection/tree/rose/zipper.lux delete mode 100644 stdlib/test/test/lux/data/coll/array.lux delete mode 100644 stdlib/test/test/lux/data/coll/bits.lux delete mode 100644 stdlib/test/test/lux/data/coll/dictionary.lux delete mode 100644 stdlib/test/test/lux/data/coll/dictionary/ordered.lux delete mode 100644 stdlib/test/test/lux/data/coll/list.lux delete mode 100644 stdlib/test/test/lux/data/coll/queue.lux delete mode 100644 stdlib/test/test/lux/data/coll/queue/priority.lux delete mode 100644 stdlib/test/test/lux/data/coll/row.lux delete mode 100644 stdlib/test/test/lux/data/coll/sequence.lux delete mode 100644 stdlib/test/test/lux/data/coll/set.lux delete mode 100644 stdlib/test/test/lux/data/coll/set/ordered.lux delete mode 100644 stdlib/test/test/lux/data/coll/stack.lux delete mode 100644 stdlib/test/test/lux/data/coll/tree/rose.lux delete mode 100644 stdlib/test/test/lux/data/coll/tree/rose/zipper.lux create mode 100644 stdlib/test/test/lux/data/collection/array.lux create mode 100644 stdlib/test/test/lux/data/collection/bits.lux create mode 100644 stdlib/test/test/lux/data/collection/dictionary.lux create mode 100644 stdlib/test/test/lux/data/collection/dictionary/ordered.lux create mode 100644 stdlib/test/test/lux/data/collection/list.lux create mode 100644 stdlib/test/test/lux/data/collection/queue.lux create mode 100644 stdlib/test/test/lux/data/collection/queue/priority.lux create mode 100644 stdlib/test/test/lux/data/collection/row.lux create mode 100644 stdlib/test/test/lux/data/collection/sequence.lux create mode 100644 stdlib/test/test/lux/data/collection/set.lux create mode 100644 stdlib/test/test/lux/data/collection/set/ordered.lux create mode 100644 stdlib/test/test/lux/data/collection/stack.lux create mode 100644 stdlib/test/test/lux/data/collection/tree/rose.lux create mode 100644 stdlib/test/test/lux/data/collection/tree/rose/zipper.lux (limited to 'stdlib') diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 138d965c4..71cdbe716 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -4948,7 +4948,7 @@ lux (lux (control (monad #as M #refer #all)) (data (text #open (\"text/\" Monoid)) - (coll (list #open (\"list/\" Monad))) + (collection (list #open (\"list/\" Monad))) maybe (ident #open (\"ident/\" Codec))) meta @@ -4959,7 +4959,7 @@ lux (lux (control [\"M\" monad #*]) (data [text \"text/\" Monoid] - (coll [list \"list/\" Monad]) + (collection [list \"list/\" Monad]) maybe [ident \"ident/\" Codec]) meta diff --git a/stdlib/source/lux/cli.lux b/stdlib/source/lux/cli.lux index c2e8e2c0f..ac04ce673 100644 --- a/stdlib/source/lux/cli.lux +++ b/stdlib/source/lux/cli.lux @@ -2,7 +2,7 @@ lux (lux (control monad ["p" parser]) - (data (coll [list "list/" Monoid Monad]) + (data (collection [list "list/" Monoid Monad]) [text "text/" Equivalence] text/format ["E" error]) diff --git a/stdlib/source/lux/concurrency/actor.lux b/stdlib/source/lux/concurrency/actor.lux index ad3bccfdc..187fe54eb 100644 --- a/stdlib/source/lux/concurrency/actor.lux +++ b/stdlib/source/lux/concurrency/actor.lux @@ -7,7 +7,7 @@ (data [product] ["e" error] text/format - (coll [list "list/" Monoid Monad Fold])) + (collection [list "list/" Monoid Monad Fold])) [macro #+ with-gensyms Monad] (macro [code] ["s" syntax #+ syntax: Syntax] diff --git a/stdlib/source/lux/concurrency/frp.lux b/stdlib/source/lux/concurrency/frp.lux index dda469f62..8a1cff374 100644 --- a/stdlib/source/lux/concurrency/frp.lux +++ b/stdlib/source/lux/concurrency/frp.lux @@ -4,7 +4,7 @@ [apply #+ Apply] [monad #+ do Monad]) [io #+ IO io] - (data (coll [list "list/" Monoid])) + (data (collection [list "list/" Monoid])) (type abstract)) (// [atom #+ Atom atom] [promise #+ Promise])) diff --git a/stdlib/source/lux/concurrency/stm.lux b/stdlib/source/lux/concurrency/stm.lux index eddaabf2b..26bcf4c36 100644 --- a/stdlib/source/lux/concurrency/stm.lux +++ b/stdlib/source/lux/concurrency/stm.lux @@ -6,7 +6,7 @@ [io #+ IO io] (data [product] [maybe] - (coll [list "list/" Functor Fold])) + (collection [list "list/" Functor Fold])) (concurrency [atom #+ Atom atom] [promise #+ Promise promise] [frp "frp/" Functor]) diff --git a/stdlib/source/lux/control/comonad.lux b/stdlib/source/lux/control/comonad.lux index f60a34c74..557cd3b7b 100644 --- a/stdlib/source/lux/control/comonad.lux +++ b/stdlib/source/lux/control/comonad.lux @@ -1,7 +1,7 @@ (.module: lux - ["F" //functor] - (lux/data/coll [list "list/" Fold])) + (lux (data (collection [list "list/" Fold]))) + ["F" //functor]) ## [Signatures] (signature: #export (CoMonad w) diff --git a/stdlib/source/lux/control/concatenative.lux b/stdlib/source/lux/control/concatenative.lux index fb1e903b2..75c69baf9 100644 --- a/stdlib/source/lux/control/concatenative.lux +++ b/stdlib/source/lux/control/concatenative.lux @@ -8,7 +8,7 @@ (data [text] text/format [maybe "maybe/" Monad] - (coll [list "list/" Fold Functor])) + (collection [list "list/" Fold Functor])) [macro #+ with-gensyms Monad] (macro [code] ["s" syntax #+ syntax:] diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux index 80ddeed35..bf6859dcd 100644 --- a/stdlib/source/lux/control/exception.lux +++ b/stdlib/source/lux/control/exception.lux @@ -6,7 +6,7 @@ [maybe] [product] [text "text/" Monoid] - (coll [list "list/" Functor Fold])) + (collection [list "list/" Functor Fold])) [macro] (macro [code] ["s" syntax #+ syntax: Syntax] diff --git a/stdlib/source/lux/control/monad/indexed.lux b/stdlib/source/lux/control/monad/indexed.lux index 455334760..4967a016a 100644 --- a/stdlib/source/lux/control/monad/indexed.lux +++ b/stdlib/source/lux/control/monad/indexed.lux @@ -2,7 +2,7 @@ lux (lux (control [monad] ["p" parser]) - (data (coll [list "list/" Functor Fold])) + (data (collection [list "list/" Functor Fold])) [macro] (macro ["s" syntax #+ Syntax syntax:]))) diff --git a/stdlib/source/lux/control/parser.lux b/stdlib/source/lux/control/parser.lux index 1ad76a50a..6bdc5877c 100644 --- a/stdlib/source/lux/control/parser.lux +++ b/stdlib/source/lux/control/parser.lux @@ -4,7 +4,7 @@ [apply #+ Apply] [monad #+ do Monad] [codec]) - (data (coll [list "list/" Functor Monoid]) + (data (collection [list "list/" Functor Monoid]) [product] ["e" error #+ Error]))) diff --git a/stdlib/source/lux/control/pipe.lux b/stdlib/source/lux/control/pipe.lux index de058307b..aae6a7db5 100644 --- a/stdlib/source/lux/control/pipe.lux +++ b/stdlib/source/lux/control/pipe.lux @@ -3,7 +3,7 @@ (lux (control [monad #+ do] ["p" parser]) (data ["e" error] - (coll [list #+ "list/" Fold Monad])) + (collection [list #+ "list/" Fold Monad])) [macro #+ with-gensyms] (macro ["s" syntax #+ syntax: Syntax] [code]) diff --git a/stdlib/source/lux/control/predicate.lux b/stdlib/source/lux/control/predicate.lux index d7abc4139..e9ddf5ff4 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])) + (data (collection [set #+ Set])) [function])) (type: #export (Predicate a) diff --git a/stdlib/source/lux/control/region.lux b/stdlib/source/lux/control/region.lux index d35495d93..09db5b5a0 100644 --- a/stdlib/source/lux/control/region.lux +++ b/stdlib/source/lux/control/region.lux @@ -6,7 +6,7 @@ ["ex" exception #+ Exception exception:]) (data ["e" error #+ Error] text/format - (coll [list "list/" Fold])))) + (collection [list "list/" Fold])))) (type: (Cleaner r m) (-> r (m (Error Any)))) diff --git a/stdlib/source/lux/data/coll/array.lux b/stdlib/source/lux/data/coll/array.lux deleted file mode 100644 index 842acec39..000000000 --- a/stdlib/source/lux/data/coll/array.lux +++ /dev/null @@ -1,211 +0,0 @@ -(.module: - lux - (lux (control [monoid #+ Monoid] - [functor #+ Functor] - [equivalence #+ Equivalence] - fold) - (data (coll [list "list/" Fold]) - [product]) - )) - -(def: #export (new size) - (All [a] (-> Nat (Array a))) - ("lux array new" size)) - -(def: #export (size xs) - (All [a] (-> (Array a) Nat)) - ("lux array size" xs)) - -(def: #export (read i xs) - (All [a] - (-> Nat (Array a) (Maybe a))) - ("lux array get" xs i)) - -(def: #export (write i x xs) - (All [a] - (-> Nat a (Array a) (Array a))) - ("lux array put" xs i x)) - -(def: #export (delete i xs) - (All [a] - (-> Nat (Array a) (Array a))) - ("lux array remove" xs i)) - -(def: #export (copy length src-start src-array dest-start dest-array) - (All [a] - (-> Nat Nat (Array a) Nat (Array a) - (Array a))) - (if (n/= +0 length) - dest-array - (list/fold (function (_ offset target) - (case (read (n/+ offset src-start) src-array) - #.None - target - - (#.Some value) - (write (n/+ offset dest-start) value target))) - dest-array - (list.n/range +0 (dec length))))) - -(def: #export (occupied array) - {#.doc "Finds out how many cells in an array are occupied."} - (All [a] (-> (Array a) Nat)) - (list/fold (function (_ idx count) - (case (read idx array) - #.None - count - - (#.Some _) - (inc count))) - +0 - (list.indices (size array)))) - -(def: #export (vacant array) - {#.doc "Finds out how many cells in an array are vacant."} - (All [a] (-> (Array a) Nat)) - (n/- (occupied array) (size array))) - -(def: #export (filter p xs) - (All [a] - (-> (-> a Bool) (Array a) (Array a))) - (list/fold (function (_ idx xs') - (case (read idx xs) - #.None - xs' - - (#.Some x) - (if (p x) - xs' - (delete idx xs')))) - xs - (list.indices (size xs)))) - -(def: #export (find p xs) - (All [a] - (-> (-> a Bool) (Array a) (Maybe a))) - (let [arr-size (size xs)] - (loop [idx +0] - (if (n/< arr-size idx) - (case (read idx xs) - #.None - (recur (inc idx)) - - (#.Some x) - (if (p x) - (#.Some x) - (recur (inc idx)))) - #.None)))) - -(def: #export (find+ p xs) - {#.doc "Just like 'find', but with access to the index of each value."} - (All [a] - (-> (-> Nat a Bool) (Array a) (Maybe [Nat a]))) - (let [arr-size (size xs)] - (loop [idx +0] - (if (n/< arr-size idx) - (case (read idx xs) - #.None - (recur (inc idx)) - - (#.Some x) - (if (p idx x) - (#.Some [idx x]) - (recur (inc idx)))) - #.None)))) - -(def: #export (clone xs) - (All [a] (-> (Array a) (Array a))) - (let [arr-size (size xs)] - (list/fold (function (_ idx ys) - (case (read idx xs) - #.None - ys - - (#.Some x) - (write idx x ys))) - (new arr-size) - (list.indices arr-size)))) - -(def: #export (from-list xs) - (All [a] (-> (List a) (Array a))) - (product.right (list/fold (function (_ x [idx arr]) - [(inc idx) (write idx x arr)]) - [+0 (new (list.size xs))] - xs))) - -(def: underflow Nat (dec +0)) - -(def: #export (to-list array) - (All [a] (-> (Array a) (List a))) - (loop [idx (dec (size array)) - output #.Nil] - (if (n/= underflow idx) - output - (recur (dec idx) - (case (read idx array) - (#.Some head) - (#.Cons head output) - - #.None - output))))) - -(structure: #export (Equivalence Equivalence) - (All [a] (-> (Equivalence a) (Equivalence (Array a)))) - (def: (= xs ys) - (let [sxs (size xs) - sxy (size ys)] - (and (n/= sxy sxs) - (list/fold (function (_ idx prev) - (and prev - (case [(read idx xs) (read idx ys)] - [#.None #.None] - true - - [(#.Some x) (#.Some y)] - (:: Equivalence = x y) - - _ - false))) - true - (list.n/range +0 (dec sxs))))) - )) - -(structure: #export Monoid (All [a] (Monoid (Array a))) - (def: identity (new +0)) - - (def: (compose xs ys) - (let [sxs (size xs) - sxy (size ys)] - (|> (new (n/+ sxy sxs)) - (copy sxs +0 xs +0) - (copy sxy +0 ys sxs))))) - -(structure: #export _ (Functor Array) - (def: (map f ma) - (let [arr-size (size ma)] - (if (n/= +0 arr-size) - (new arr-size) - (list/fold (function (_ idx mb) - (case (read idx ma) - #.None - mb - - (#.Some x) - (write idx (f x) mb))) - (new arr-size) - (list.n/range +0 (dec arr-size))) - )))) - -(structure: #export _ (Fold Array) - (def: (fold f init xs) - (let [arr-size (size xs)] - (loop [so-far init - idx +0] - (if (n/< arr-size idx) - (case (read idx xs) - #.None - (recur so-far (inc idx)) - - (#.Some value) - (recur (f value so-far) (inc idx))) - so-far))))) diff --git a/stdlib/source/lux/data/coll/bits.lux b/stdlib/source/lux/data/coll/bits.lux deleted file mode 100644 index 426f830d2..000000000 --- a/stdlib/source/lux/data/coll/bits.lux +++ /dev/null @@ -1,164 +0,0 @@ -(.module: - [lux #- not and or] - (lux (control [equivalence #+ Equivalence] - pipe) - (data [maybe] - [bit] - (coll [array "array/" Fold]) - text/format))) - -(type: #export Chunk I64) - -(def: #export chunk-size bit.width) - -(type: #export Bits - (Array Chunk)) - -(def: empty-chunk Chunk (.i64 +0)) - -(def: #export empty - Bits - (array.new +0)) - -(def: #export (size bits) - (-> Bits Nat) - (array/fold (function (_ chunk total) - (|> chunk bit.count (n/+ total))) - +0 - bits)) - -(def: #export (capacity bits) - (-> Bits Nat) - (|> bits array.size (n/* chunk-size))) - -(def: #export empty? - (-> Bits Bool) - (|>> size (n/= +0))) - -(def: #export (get index bits) - (-> Nat Bits Bool) - (let [[chunk-index bit-index] (n//% chunk-size index)] - (.and (n/< (array.size bits) chunk-index) - (|> (array.read chunk-index bits) - (maybe.default empty-chunk) - (bit.set? bit-index))))) - -(def: (chunk idx bits) - (-> Nat Bits Chunk) - (if (n/< (array.size bits) idx) - (|> bits (array.read idx) (maybe.default empty-chunk)) - empty-chunk)) - -(do-template [ ] - [(def: #export ( index input) - (-> Nat Bits Bits) - (let [[chunk-index bit-index] (n//% chunk-size index)] - (loop [size|output (n/max (inc chunk-index) - (array.size input)) - output ..empty] - (let [idx|output (dec size|output)] - (if (n/> +0 size|output) - (case (|> (..chunk idx|output input) - (cond> [(new> (n/= chunk-index idx|output))] - [( bit-index)] - - ## else - []) - .nat) - +0 - ## TODO: Remove 'no-op' once new-luxc is the official compiler. - (let [no-op (recur (dec size|output) output)] - no-op) - - chunk - (|> (if (is? ..empty output) - (: Bits (array.new size|output)) - output) - (array.write idx|output (.i64 chunk)) - (recur (dec size|output)))) - output)))))] - - [set bit.set] - [clear bit.clear] - [flip bit.flip] - ) - -(def: #export (intersects? reference sample) - (-> Bits Bits Bool) - (let [chunks (n/min (array.size reference) - (array.size sample))] - (loop [idx +0] - (if (n/< chunks idx) - (.or (|> (..chunk idx sample) - (bit.and (..chunk idx reference)) - ("lux i64 =" empty-chunk) - .not) - (recur (inc idx))) - false)))) - -(def: #export (not input) - (-> Bits Bits) - (case (array.size input) - +0 - ..empty - - size|output - (loop [size|output size|output - output ..empty] - (let [idx (dec size|output)] - (case (|> input (..chunk idx) bit.not .nat) - +0 - (recur (dec size|output) output) - - chunk - (if (n/> +0 size|output) - (|> (if (is? ..empty output) - (: Bits (array.new size|output)) - output) - (array.write idx (.i64 chunk)) - (recur (dec size|output))) - output)))))) - -(do-template [ ] - [(def: #export ( param subject) - (-> Bits Bits Bits) - (case (n/max (array.size param) - (array.size subject)) - +0 - ..empty - - size|output - (loop [size|output size|output - output ..empty] - (let [idx (dec size|output)] - (if (n/> +0 size|output) - (case (|> (..chunk idx subject) - ( (..chunk idx param)) - .nat) - +0 - (recur (dec size|output) output) - - chunk - (|> (if (is? ..empty output) - (: Bits (array.new size|output)) - output) - (array.write idx (.i64 chunk)) - (recur (dec size|output)))) - output)))))] - - [and bit.and] - [or bit.or] - [xor bit.xor] - ) - -(structure: #export _ (Equivalence Bits) - (def: (= reference sample) - (let [size (n/max (array.size reference) - (array.size sample))] - (loop [idx +0] - (if (n/< size idx) - (.and ("lux i64 =" - (..chunk idx reference) - (..chunk idx sample)) - (recur (inc idx))) - true))))) diff --git a/stdlib/source/lux/data/coll/dictionary.lux b/stdlib/source/lux/data/coll/dictionary.lux deleted file mode 100644 index e971228bb..000000000 --- a/stdlib/source/lux/data/coll/dictionary.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/dictionary/ordered.lux b/stdlib/source/lux/data/coll/dictionary/ordered.lux deleted file mode 100644 index 3cea300f7..000000000 --- a/stdlib/source/lux/data/coll/dictionary/ordered.lux +++ /dev/null @@ -1,569 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do Monad] - equivalence - [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 (Dictionary k v) - {#order (Order k) - #root (Maybe (Node k v))}) - -(def: #export (new Order) - (All [k v] (-> (Order k) (Dictionary 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 (Dictionary 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 (Dictionary 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] (-> (Dictionary 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] (-> (Dictionary k v) Nat)) - (loop [node (get@ #root dict)] - (case node - #.None - +0 - - (#.Some node) - (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 (Dictionary k v) (Dictionary 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 (Dictionary k v) (Dictionary 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 (update key transform dict) - (All [k v] (-> k (-> v v) (Dictionary k v) (Maybe (Dictionary k v)))) - (do maybe.Monad - [old (get key dict)] - (wrap (put key (transform old) dict)))) - -(def: #export (from-list Order list) - (All [k v] (-> (Order k) (List [k v]) (Dictionary k v))) - (L/fold (function (_ [key value] dict) - (put key value dict)) - (new Order) - list)) - -(do-template [ ] - [(def: #export ( dict) - (All [k v] (-> (Dictionary 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')] - ) - -(structure: #export (Equivalence Equivalence) (All [k v] (-> (Equivalence v) (Equivalence (Dictionary k v)))) - (def: (= reference sample) - (let [Equivalence (:: sample eq)] - (loop [entriesR (entries reference) - entriesS (entries sample)] - (case [entriesR entriesS] - [#.Nil #.Nil] - true - - [(#.Cons [keyR valueR] entriesR') (#.Cons [keyS valueS] entriesS')] - (and (:: Equivalence = keyR keyS) - (:: Equivalence = valueR valueS) - (recur entriesR' entriesS')) - - _ - false))))) diff --git a/stdlib/source/lux/data/coll/dictionary/plist.lux b/stdlib/source/lux/data/coll/dictionary/plist.lux deleted file mode 100644 index c483a3287..000000000 --- a/stdlib/source/lux/data/coll/dictionary/plist.lux +++ /dev/null @@ -1,62 +0,0 @@ -(.module: - lux - (lux (data [text "text/" Equivalence]))) - -(type: #export (PList a) - (List [Text a])) - -(def: #export (get key properties) - (All [a] (-> Text (PList a) (Maybe a))) - (case properties - #.Nil - #.None - - (#.Cons [k' v'] properties') - (if (text/= key k') - (#.Some v') - (get key properties')))) - -(def: #export (contains? key properties) - (All [a] (-> Text (PList a) Bool)) - (case (get key properties) - (#.Some _) - true - - #.None - false)) - -(def: #export (put key val properties) - (All [a] (-> Text a (PList a) (PList a))) - (case properties - #.Nil - (list [key val]) - - (#.Cons [k' v'] properties') - (if (text/= key k') - (#.Cons [key val] - properties') - (#.Cons [k' v'] - (put key val properties'))))) - -(def: #export (update key f properties) - (All [a] (-> Text (-> a a) (PList a) (PList a))) - (case properties - #.Nil - #.Nil - - (#.Cons [k' v'] properties') - (if (text/= key k') - (#.Cons [k' (f v')] properties') - (#.Cons [k' v'] (update key f properties'))))) - -(def: #export (remove key properties) - (All [a] (-> Text (PList a) (PList a))) - (case properties - #.Nil - properties - - (#.Cons [k' v'] properties') - (if (text/= key k') - properties' - (#.Cons [k' v'] - (remove key properties'))))) diff --git a/stdlib/source/lux/data/coll/list.lux b/stdlib/source/lux/data/coll/list.lux deleted file mode 100644 index 74ef2e5cc..000000000 --- a/stdlib/source/lux/data/coll/list.lux +++ /dev/null @@ -1,554 +0,0 @@ -(.module: - lux - (lux (control [monoid #+ Monoid] - [functor #+ Functor] - [apply #+ Apply] - [monad #+ do Monad] - [equivalence #+ Equivalence] - [fold]) - (data [number "nat/" Codec] - bool - [product]))) - -## [Types] -## (type: (List a) -## #Nil -## (#Cons a (List a))) - -## [Functions] -(structure: #export _ (fold.Fold List) - (def: (fold f init xs) - (case xs - #.Nil - init - - (#.Cons [x xs']) - (fold f (f x init) xs')))) - -(open: Fold) - -(def: #export (reverse xs) - (All [a] - (-> (List a) (List a))) - (fold (function (_ head tail) (#.Cons head tail)) - #.Nil - xs)) - -(def: #export (filter p xs) - (All [a] - (-> (-> a Bool) (List a) (List a))) - (case xs - #.Nil - #.Nil - - (#.Cons [x xs']) - (if (p x) - (#.Cons [x (filter p xs')]) - (filter p xs')))) - -(def: #export (partition p xs) - {#.doc "Divide the list into all elements that satisfy a predicate, and all elements that do not."} - (All [a] (-> (-> a Bool) (List a) [(List a) (List a)])) - [(filter p xs) (filter (complement p) xs)]) - -(def: #export (as-pairs xs) - {#.doc "Cut the list into pairs of 2. - - Caveat emptor: If the list has an uneven number of elements, the last one will be skipped."} - (All [a] (-> (List a) (List [a a]))) - (case xs - (^ (#.Cons [x1 (#.Cons [x2 xs'])])) - (#.Cons [[x1 x2] (as-pairs xs')]) - - _ - #.Nil)) - -(do-template [ ] - [(def: #export ( n xs) - (All [a] - (-> Nat (List a) (List a))) - (if (n/> +0 n) - (case xs - #.Nil - #.Nil - - (#.Cons [x xs']) - ) - ))] - - [take (#.Cons [x (take (dec n) xs')]) #.Nil] - [drop (drop (dec n) xs') xs] - ) - -(do-template [ ] - [(def: #export ( p xs) - (All [a] - (-> (-> a Bool) (List a) (List a))) - (case xs - #.Nil - #.Nil - - (#.Cons [x xs']) - (if (p x) - - )))] - - [take-while (#.Cons [x (take-while p xs')]) #.Nil] - [drop-while (drop-while p xs') xs] - ) - -(def: #export (split n xs) - (All [a] - (-> Nat (List a) [(List a) (List a)])) - (if (n/> +0 n) - (case xs - #.Nil - [#.Nil #.Nil] - - (#.Cons [x xs']) - (let [[tail rest] (split (dec n) xs')] - [(#.Cons [x tail]) rest])) - [#.Nil xs])) - -(def: (split-with' p ys xs) - (All [a] - (-> (-> a Bool) (List a) (List a) [(List a) (List a)])) - (case xs - #.Nil - [ys xs] - - (#.Cons [x xs']) - (if (p x) - (split-with' p (#.Cons [x ys]) xs') - [ys xs]))) - -(def: #export (split-with p xs) - {#.doc "Segment the list by using a predicate to tell when to cut."} - (All [a] - (-> (-> a Bool) (List a) [(List a) (List a)])) - (let [[ys' xs'] (split-with' p #.Nil xs)] - [(reverse ys') xs'])) - -(def: #export (split-all n xs) - {#.doc "Segment the list in chunks of size n."} - (All [a] (-> Nat (List a) (List (List a)))) - (case xs - #.Nil - (list) - - _ - (let [[pre post] (split n xs)] - (#.Cons pre (split-all n post))))) - -(def: #export (repeat n x) - {#.doc "A list of the value x, repeated n times."} - (All [a] - (-> Nat a (List a))) - (if (n/> +0 n) - (#.Cons [x (repeat (dec n) x)]) - #.Nil)) - -(def: (iterate' f x) - (All [a] - (-> (-> a (Maybe a)) a (List a))) - (case (f x) - (#.Some x') - (list& x (iterate' f x')) - - #.None - (list))) - -(def: #export (iterate f x) - {#.doc "Generates a list element by element until the function returns #.None."} - (All [a] - (-> (-> a (Maybe a)) a (List a))) - (case (f x) - (#.Some x') - (list& x (iterate' f x')) - - #.None - (list x))) - -(def: #export (find p xs) - {#.doc "Returns the first value in the list for which the predicate is true."} - (All [a] - (-> (-> a Bool) (List a) (Maybe a))) - (case xs - #.Nil - #.None - - (#.Cons [x xs']) - (if (p x) - (#.Some x) - (find p xs')))) - -(def: #export (search check xs) - (All [a b] - (-> (-> a (Maybe b)) (List a) (Maybe b))) - (case xs - #.Nil - #.None - - (#.Cons [x xs']) - (case (check x) - (#.Some output) - (#.Some output) - - #.None - (search check xs')))) - -(def: #export (search-all check xs) - (All [a b] - (-> (-> a (Maybe b)) (List a) (List b))) - (case xs - #.Nil - #.None - - (#.Cons [x xs']) - (case (check x) - (#.Some output) - (#.Cons output (search-all check xs')) - - #.None - (search-all check xs')))) - -(def: #export (interpose sep xs) - {#.doc "Puts a value between every two elements in the list."} - (All [a] - (-> a (List a) (List a))) - (case xs - #.Nil - xs - - (#.Cons [x #.Nil]) - xs - - (#.Cons [x xs']) - (#.Cons [x (#.Cons [sep (interpose sep xs')])]))) - -(def: #export (size list) - (All [a] (-> (List a) Nat)) - (fold (function (_ _ acc) (n/+ +1 acc)) +0 list)) - -(do-template [ ] - [(def: #export ( p xs) - (All [a] - (-> (-> a Bool) (List a) Bool)) - (loop [xs xs] - (case xs - #.Nil - - - (#.Cons x xs') - (case (p x) - - (recur xs') - - output - output))))] - - [every? true and] - [any? false or] - ) - -(def: #export (nth i xs) - {#.doc "Fetches the element at the specified index."} - (All [a] - (-> Nat (List a) (Maybe a))) - (case xs - #.Nil - #.None - - (#.Cons [x xs']) - (if (n/= +0 i) - (#.Some x) - (nth (dec i) xs')))) - -## [Structures] -(structure: #export (Equivalence Equivalence) - (All [a] (-> (Equivalence a) (Equivalence (List a)))) - (def: (= xs ys) - (case [xs ys] - [#.Nil #.Nil] - true - - [(#.Cons x xs') (#.Cons y ys')] - (and (:: Equivalence = x y) - (= xs' ys')) - - [_ _] - false - ))) - -(structure: #export Monoid (All [a] - (Monoid (List a))) - (def: identity #.Nil) - (def: (compose xs ys) - (case xs - #.Nil ys - (#.Cons x xs') (#.Cons x (compose xs' ys))))) - -(open: Monoid) - -(structure: #export _ (Functor List) - (def: (map f ma) - (case ma - #.Nil #.Nil - (#.Cons a ma') (#.Cons (f a) (map f ma'))))) - -(open: Functor) - -(structure: #export _ (Apply List) - (def: functor Functor) - - (def: (apply ff fa) - (case ff - #.Nil - #.Nil - - (#.Cons f ff') - (compose (map f fa) (apply ff' fa))))) - -(structure: #export _ (Monad List) - (def: functor Functor) - - (def: (wrap a) - (#.Cons a #.Nil)) - - (def: join (|>> reverse (fold compose identity)))) - -## [Functions] -(def: #export (sort < xs) - (All [a] (-> (-> a a Bool) (List a) (List a))) - (case xs - #.Nil - (list) - - (#.Cons x xs') - (let [[pre post] (fold (function (_ x' [pre post]) - (if (< x x') - [(#.Cons x' pre) post] - [pre (#.Cons x' post)])) - [(list) (list)] - xs')] - ($_ compose (sort < pre) (list x) (sort < post))))) - -(do-template [ ] - [(def: #export ( from to) - {#.doc "Generates an inclusive interval of values [from, to]."} - (-> (List )) - (cond ( to from) - (list& from ( (inc from) to)) - - ( to from) - (list& from ( (dec from) to)) - - ## (= to from) - (list from)))] - - [i/range Int i/< i/>] - [n/range Nat n/< n/>] - ) - -(def: #export (empty? xs) - (All [a] (-> (List a) Bool)) - (case xs - #.Nil true - _ false)) - -(def: #export (member? eq xs x) - (All [a] (-> (Equivalence a) (List a) a Bool)) - (case xs - #.Nil false - (#.Cons x' xs') (or (:: eq = x x') - (member? eq xs' x)))) - -(do-template [ ] - [(def: #export ( xs) - {#.doc } - (All [a] (-> (List a) (Maybe ))) - (case xs - #.Nil - #.None - - (#.Cons x xs') - (#.Some )))] - - [head a x "Returns the first element of a list."] - [tail (List a) xs' "For a list of size N, returns the N-1 elements after the first one."] - ) - -## [Syntax] -(def: (symbol$ name) - (-> Text Code) - [["" +0 +0] (#.Symbol "" name)]) - -(macro: #export (zip tokens state) - {#.doc (doc "Create list zippers with the specified number of input lists." - (def: #export zip2 (zip +2)) - (def: #export zip3 (zip +3)) - ((zip +3) xs ys zs))} - (case tokens - (^ (list [_ (#.Nat num-lists)])) - (if (n/> +0 num-lists) - (let [(^open) Functor - indices (n/range +0 (dec num-lists)) - type-vars (: (List Code) (map (|>> nat/encode symbol$) indices)) - zip-type (` (All [(~+ type-vars)] - (-> (~+ (map (: (-> Code Code) (function (_ var) (` (List (~ var))))) - type-vars)) - (List [(~+ type-vars)])))) - vars+lists (|> indices - (map inc) - (map (function (_ idx) - (let [base (nat/encode idx)] - [(symbol$ base) - (symbol$ ("lux text concat" base "'"))])))) - pattern (` [(~+ (map (function (_ [v vs]) (` (#.Cons (~ v) (~ vs)))) - vars+lists))]) - g!step (symbol$ "\tstep\t") - g!blank (symbol$ "\t_\t") - list-vars (map product.right vars+lists) - code (` (: (~ zip-type) - (function ((~ g!step) (~+ list-vars)) - (case [(~+ list-vars)] - (~ pattern) - (#.Cons [(~+ (map product.left vars+lists))] - ((~ g!step) (~+ list-vars))) - - (~ g!blank) - #.Nil))))] - (#.Right [state (list code)])) - (#.Left "Cannot zip 0 lists.")) - - _ - (#.Left "Wrong syntax for zip"))) - -(def: #export zip2 (zip +2)) -(def: #export zip3 (zip +3)) - -(macro: #export (zip-with tokens state) - {#.doc (doc "Create list zippers with the specified number of input lists." - (def: #export zip2-with (zip-with +2)) - (def: #export zip3-with (zip-with +3)) - ((zip-with +2) i/+ xs ys))} - (case tokens - (^ (list [_ (#.Nat num-lists)])) - (if (n/> +0 num-lists) - (let [(^open) Functor - indices (n/range +0 (dec num-lists)) - g!return-type (symbol$ "\treturn-type\t") - g!func (symbol$ "\tfunc\t") - type-vars (: (List Code) (map (|>> nat/encode symbol$) indices)) - zip-type (` (All [(~+ type-vars) (~ g!return-type)] - (-> (-> (~+ type-vars) (~ g!return-type)) - (~+ (map (: (-> Code Code) (function (_ var) (` (List (~ var))))) - type-vars)) - (List (~ g!return-type))))) - vars+lists (|> indices - (map inc) - (map (function (_ idx) - (let [base (nat/encode idx)] - [(symbol$ base) - (symbol$ ("lux text concat" base "'"))])))) - pattern (` [(~+ (map (function (_ [v vs]) (` (#.Cons (~ v) (~ vs)))) - vars+lists))]) - g!step (symbol$ "\tstep\t") - g!blank (symbol$ "\t_\t") - list-vars (map product.right vars+lists) - code (` (: (~ zip-type) - (function ((~ g!step) (~ g!func) (~+ list-vars)) - (case [(~+ list-vars)] - (~ pattern) - (#.Cons ((~ g!func) (~+ (map product.left vars+lists))) - ((~ g!step) (~ g!func) (~+ list-vars))) - - (~ g!blank) - #.Nil))))] - (#.Right [state (list code)])) - (#.Left "Cannot zip-with 0 lists.")) - - _ - (#.Left "Wrong syntax for zip-with"))) - -(def: #export zip2-with (zip-with +2)) -(def: #export zip3-with (zip-with +3)) - -(def: #export (last xs) - (All [a] (-> (List a) (Maybe a))) - (case xs - #.Nil - #.None - - (#.Cons x #.Nil) - (#.Some x) - - (#.Cons x xs') - (last xs'))) - -(def: #export (inits xs) - {#.doc "For a list of size N, returns the first N-1 elements. - - Empty lists will result in a #.None value being returned instead."} - (All [a] (-> (List a) (Maybe (List a)))) - (case xs - #.Nil - #.None - - (#.Cons x #.Nil) - (#.Some #.Nil) - - (#.Cons x xs') - (case (inits xs') - #.None - (undefined) - - (#.Some tail) - (#.Some (#.Cons x tail))) - )) - -(def: #export (concat xss) - (All [a] (-> (List (List a)) (List a))) - (:: Monad join xss)) - -(structure: #export (ListT Monad) - (All [M] (-> (Monad M) (Monad (All [a] (M (List a)))))) - - (def: functor (functor.compose (get@ #monad.functor Monad) Functor)) - - (def: wrap (|>> (:: Monad wrap) (:: Monad wrap))) - - (def: (join MlMla) - (do Monad - [lMla MlMla - ## TODO: Remove this version ASAP and use one below. - lla (: (($ +0) (List (List ($ +1)))) - (monad.seq @ lMla)) - ## lla (monad.seq @ lMla) - ] - (wrap (concat lla))))) - -(def: #export (lift Monad) - (All [M a] (-> (Monad M) (-> (M a) (M (List a))))) - (monad.lift Monad (:: Monad wrap))) - -(def: (enumerate' idx xs) - (All [a] (-> Nat (List a) (List [Nat a]))) - (case xs - #.Nil - #.Nil - - (#.Cons x xs') - (#.Cons [idx x] (enumerate' (inc idx) xs')))) - -(def: #export (enumerate xs) - {#.doc "Pairs every element in the list with its index, starting at 0."} - (All [a] (-> (List a) (List [Nat a]))) - (enumerate' +0 xs)) - -(def: #export (indices size) - {#.doc "Produces all the valid indices for a given size."} - (All [a] (-> Nat (List Nat))) - (if (n/= +0 size) - (list) - (|> size dec (n/range +0)))) diff --git a/stdlib/source/lux/data/coll/queue.lux b/stdlib/source/lux/data/coll/queue.lux deleted file mode 100644 index 3b144a52a..000000000 --- a/stdlib/source/lux/data/coll/queue.lux +++ /dev/null @@ -1,78 +0,0 @@ -(.module: - lux - (lux (control [equivalence #+ Equivalence] - ["F" functor]) - (data (coll [list "L/" Monoid Functor])))) - -(type: #export (Queue a) - {#front (List a) - #rear (List a)}) - -(def: #export empty - Queue - {#front (list) - #rear (list)}) - -(def: #export (from-list entries) - (All [a] (-> (List a) (Queue a))) - {#front entries - #rear (list)}) - -(def: #export (to-list queue) - (All [a] (-> (Queue a) (List a))) - (let [(^slots [#front #rear]) queue] - (L/compose front (list.reverse rear)))) - -(def: #export peek - (All [a] (-> (Queue a) (Maybe a))) - (|>> (get@ #front) list.head)) - -(def: #export (size queue) - (All [a] (-> (Queue a) Nat)) - (let [(^slots [#front #rear]) queue] - (n/+ (list.size front) - (list.size rear)))) - -(def: #export empty? - (All [a] (-> (Queue a) Bool)) - (|>> (get@ #front) list.empty?)) - -(def: #export (member? Equivalence queue member) - (All [a] (-> (Equivalence a) (Queue a) a Bool)) - (let [(^slots [#front #rear]) queue] - (or (list.member? Equivalence front member) - (list.member? Equivalence rear member)))) - -(def: #export (pop queue) - (All [a] (-> (Queue a) (Queue a))) - (case (get@ #front queue) - (^ (list)) ## Empty... - queue - - (^ (list _)) ## Front has dried up... - (|> queue - (set@ #front (list.reverse (get@ #rear queue))) - (set@ #rear (list))) - - (^ (list& _ front')) ## Consume front! - (|> queue - (set@ #front front')))) - -(def: #export (push val queue) - (All [a] (-> a (Queue a) (Queue a))) - (case (get@ #front queue) - #.Nil - (set@ #front (list val) queue) - - _ - (update@ #rear (|>> (#.Cons val)) queue))) - -(structure: #export (Equivalence Equivalence) - (All [a] (-> (Equivalence a) (Equivalence (Queue a)))) - (def: (= qx qy) - (:: (list.Equivalence Equivalence) = (to-list qx) (to-list qy)))) - -(structure: #export _ (F.Functor Queue) - (def: (map f fa) - {#front (|> fa (get@ #front) (L/map f)) - #rear (|> fa (get@ #rear) (L/map f))})) diff --git a/stdlib/source/lux/data/coll/queue/priority.lux b/stdlib/source/lux/data/coll/queue/priority.lux deleted file mode 100644 index 443a54908..000000000 --- a/stdlib/source/lux/data/coll/queue/priority.lux +++ /dev/null @@ -1,102 +0,0 @@ -(.module: - lux - (lux (control [equivalence #+ Equivalence] - [monad #+ do Monad]) - (data (coll (tree [finger #+ Tree])) - [number "nat/" Interval] - [maybe]))) - -(type: #export Priority Nat) - -(type: #export (Queue a) - (Maybe (Tree Priority a))) - -(def: #export max Priority nat/top) -(def: #export min Priority nat/bottom) - -(def: #export empty - Queue - #.None) - -(def: #export (peek queue) - (All [a] (-> (Queue a) (Maybe a))) - (do maybe.Monad - [fingers queue] - (wrap (maybe.assume (finger.search (n/= (finger.tag fingers)) fingers))))) - -(def: #export (size queue) - (All [a] (-> (Queue a) Nat)) - (case queue - #.None - +0 - - (#.Some fingers) - (loop [node (get@ #finger.node fingers)] - (case node - (#finger.Leaf _ _) - +1 - - (#finger.Branch _ left right) - (n/+ (recur left) (recur right)))))) - -(def: #export (member? Equivalence queue member) - (All [a] (-> (Equivalence a) (Queue a) a Bool)) - (case queue - #.None - false - - (#.Some fingers) - (loop [node (get@ #finger.node fingers)] - (case node - (#finger.Leaf _ reference) - (:: Equivalence = reference member) - - (#finger.Branch _ left right) - (or (recur left) - (recur right)))))) - -(def: #export (pop queue) - (All [a] (-> (Queue a) (Queue a))) - (do maybe.Monad - [fingers queue - #let [highest-priority (finger.tag fingers)] - node' (loop [node (get@ #finger.node fingers)] - (case node - (#finger.Leaf priority reference) - (if (n/= highest-priority priority) - #.None - (#.Some node)) - - (#finger.Branch priority left right) - (if (n/= highest-priority (finger.tag (set@ #finger.node left fingers))) - (case (recur left) - #.None - (#.Some right) - - (#.Some =left) - (|> (finger.branch (set@ #finger.node =left fingers) - (set@ #finger.node right fingers)) - (get@ #finger.node) - #.Some)) - (case (recur right) - #.None - (#.Some left) - - (#.Some =right) - (|> (finger.branch (set@ #finger.node left fingers) - (set@ #finger.node =right fingers)) - (get@ #finger.node) - #.Some)) - )))] - (wrap (set@ #finger.node node' fingers)))) - -(def: #export (push priority value queue) - (All [a] (-> Priority a (Queue a) (Queue a))) - (let [addition {#finger.monoid number.Max@Monoid - #finger.node (#finger.Leaf priority value)}] - (case queue - #.None - (#.Some addition) - - (#.Some fingers) - (#.Some (finger.branch fingers addition))))) diff --git a/stdlib/source/lux/data/coll/row.lux b/stdlib/source/lux/data/coll/row.lux deleted file mode 100644 index 1d4dc648c..000000000 --- a/stdlib/source/lux/data/coll/row.lux +++ /dev/null @@ -1,437 +0,0 @@ -(.module: - lux - (lux (control [functor #+ Functor] - [apply #+ Apply] - [monad #+ do Monad] - [equivalence #+ Equivalence] - monoid - fold - ["p" parser]) - (data [maybe] - (coll [list "list/" Fold Functor Monoid] - [array "array/" Functor Fold]) - [bit] - [product]) - [macro #+ with-gensyms] - (macro [code] - ["s" syntax #+ syntax: Syntax]) - )) - -## [Utils] -(type: (Node a) - (#Base (Array a)) - (#Hierarchy (Array (Node a)))) - -(type: (Base a) (Array a)) -(type: (Hierarchy a) (Array (Node a))) - -(type: Level Nat) - -(type: Index Nat) - -(def: branching-exponent - Nat - +5) - -(def: root-level - Level - +0) - -(do-template [ ] - [(def: - (-> Level Level) - ( branching-exponent))] - - [level-up n/+] - [level-down n/-] - ) - -(def: full-node-size - Nat - (bit.left-shift branching-exponent +1)) - -(def: branch-idx-mask - Nat - (dec full-node-size)) - -(def: branch-idx - (-> Index Index) - (bit.and branch-idx-mask)) - -(def: (new-hierarchy _) - (All [a] (-> Any (Hierarchy a))) - (array.new full-node-size)) - -(def: (tail-off vec-size) - (-> Nat Nat) - (if (n/< full-node-size vec-size) - +0 - (|> (dec vec-size) - (bit.logical-right-shift branching-exponent) - (bit.left-shift branching-exponent)))) - -(def: (new-path level tail) - (All [a] (-> Level (Base a) (Node a))) - (if (n/= +0 level) - (#Base tail) - (|> (new-hierarchy []) - (array.write +0 (new-path (level-down level) tail)) - #Hierarchy))) - -(def: (new-tail singleton) - (All [a] (-> a (Base a))) - (|> (array.new +1) - (array.write +0 singleton))) - -(def: (push-tail size level tail parent) - (All [a] (-> Nat Level (Base a) (Hierarchy a) (Hierarchy a))) - (let [sub-idx (branch-idx (bit.logical-right-shift level (dec size))) - ## If we're currently on a bottom node - sub-node (if (n/= branching-exponent level) - ## Just add the tail to it - (#Base tail) - ## Otherwise, check whether there's a vacant spot - (case (array.read sub-idx parent) - ## If so, set the path to the tail - #.None - (new-path (level-down level) tail) - ## If not, push the tail onto the sub-node. - (#.Some (#Hierarchy sub-node)) - (#Hierarchy (push-tail size (level-down level) tail sub-node)) - - _ - (undefined)) - )] - (|> (array.clone parent) - (array.write sub-idx sub-node)))) - -(def: (expand-tail val tail) - (All [a] (-> a (Base a) (Base a))) - (let [tail-size (array.size tail)] - (|> (array.new (inc tail-size)) - (array.copy tail-size +0 tail +0) - (array.write tail-size val)))) - -(def: (put' level idx val hierarchy) - (All [a] (-> Level Index a (Hierarchy a) (Hierarchy a))) - (let [sub-idx (branch-idx (bit.logical-right-shift level idx))] - (case (array.read sub-idx hierarchy) - (#.Some (#Hierarchy sub-node)) - (|> (array.clone hierarchy) - (array.write sub-idx (#Hierarchy (put' (level-down level) idx val sub-node)))) - - (^multi (#.Some (#Base base)) - (n/= +0 (level-down level))) - (|> (array.clone hierarchy) - (array.write sub-idx (|> (array.clone base) - (array.write (branch-idx idx) val) - #Base))) - - _ - (undefined)))) - -(def: (pop-tail size level hierarchy) - (All [a] (-> Nat Level (Hierarchy a) (Maybe (Hierarchy a)))) - (let [sub-idx (branch-idx (bit.logical-right-shift level (n/- +2 size)))] - (cond (n/= +0 sub-idx) - #.None - - (n/> branching-exponent level) - (do maybe.Monad - [base|hierarchy (array.read sub-idx hierarchy) - sub (case base|hierarchy - (#Hierarchy sub) - (pop-tail size (level-down level) sub) - - (#Base _) - (undefined))] - (|> (array.clone hierarchy) - (array.write sub-idx (#Hierarchy sub)) - #.Some)) - - ## Else... - (|> (array.clone hierarchy) - (array.delete sub-idx) - #.Some) - ))) - -(def: (to-list' node) - (All [a] (-> (Node a) (List a))) - (case node - (#Base base) - (array.to-list base) - - (#Hierarchy hierarchy) - (|> hierarchy - array.to-list - list.reverse - (list/fold (function (_ sub acc) (list/compose (to-list' sub) acc)) - #.Nil)))) - -## [Types] -(type: #export (Row a) - {#level Level - #size Nat - #root (Hierarchy a) - #tail (Base a)}) - -## [Exports] -(def: #export empty - Row - {#level (level-up root-level) - #size +0 - #root (array.new full-node-size) - #tail (array.new +0)}) - -(def: #export (size row) - (All [a] (-> (Row a) Nat)) - (get@ #size row)) - -(def: #export (add val vec) - (All [a] (-> a (Row a) (Row a))) - ## Check if there is room in the tail. - (let [vec-size (get@ #size vec)] - (if (|> vec-size (n/- (tail-off vec-size)) (n/< full-node-size)) - ## If so, append to it. - (|> vec - (update@ #size inc) - (update@ #tail (expand-tail val))) - ## Otherwise, push tail into the tree - ## -------------------------------------------------------- - ## Will the root experience an overflow with this addition? - (|> (if (n/> (bit.left-shift (get@ #level vec) +1) - (bit.logical-right-shift branching-exponent vec-size)) - ## If so, a brand-new root must be established, that is - ## 1-level taller. - (|> vec - (set@ #root (|> (: (Hierarchy ($ +0)) - (new-hierarchy [])) - ## TODO: Remove version above once new-luxc becomes the standard compiler. - ## (new-hierarchy []) - (array.write +0 (#Hierarchy (get@ #root vec))) - (array.write +1 (new-path (get@ #level vec) (get@ #tail vec))))) - (update@ #level level-up)) - ## Otherwise, just push the current tail onto the root. - (|> vec - (update@ #root (push-tail vec-size (get@ #level vec) (get@ #tail vec))))) - ## Finally, update the size of the row and grow a new - ## tail with the new element as it's sole member. - (update@ #size inc) - (set@ #tail (new-tail val))) - ))) - -(def: (base-for idx vec) - (All [a] (-> Index (Row a) (Maybe (Base a)))) - (let [vec-size (get@ #size vec)] - (if (and (n/>= +0 idx) - (n/< vec-size idx)) - (if (n/>= (tail-off vec-size) idx) - (#.Some (get@ #tail vec)) - (loop [level (get@ #level vec) - hierarchy (get@ #root vec)] - (case [(n/> branching-exponent level) - (array.read (branch-idx (bit.logical-right-shift level idx)) hierarchy)] - [true (#.Some (#Hierarchy sub))] - (recur (level-down level) sub) - - [false (#.Some (#Base base))] - (#.Some base) - - [_ #.None] - #.None - - _ - (error! "Incorrect row structure.")))) - #.None))) - -(def: #export (nth idx vec) - (All [a] (-> Nat (Row a) (Maybe a))) - (do maybe.Monad - [base (base-for idx vec)] - (array.read (branch-idx idx) base))) - -(def: #export (put idx val vec) - (All [a] (-> Nat a (Row a) (Row a))) - (let [vec-size (get@ #size vec)] - (if (and (n/>= +0 idx) - (n/< vec-size idx)) - (if (n/>= (tail-off vec-size) idx) - (|> vec - ## (update@ #tail (|>> array.clone (array.write (branch-idx idx) val))) - ## TODO: Remove once new-luxc becomes the standard compiler. - (update@ #tail (: (-> (Base ($ +0)) (Base ($ +0))) - (|>> array.clone (array.write (branch-idx idx) val)))) - ) - (|> vec - (update@ #root (put' (get@ #level vec) idx val)))) - vec))) - -(def: #export (update idx f vec) - (All [a] (-> Nat (-> a a) (Row a) (Row a))) - (case (nth idx vec) - (#.Some val) - (put idx (f val) vec) - - #.None - vec)) - -(def: #export (pop vec) - (All [a] (-> (Row a) (Row a))) - (case (get@ #size vec) - +0 - empty - - +1 - empty - - vec-size - (if (|> vec-size (n/- (tail-off vec-size)) (n/> +1)) - (let [old-tail (get@ #tail vec) - new-tail-size (dec (array.size old-tail))] - (|> vec - (update@ #size dec) - (set@ #tail (|> (array.new new-tail-size) - (array.copy new-tail-size +0 old-tail +0))))) - (maybe.assume - (do maybe.Monad - [new-tail (base-for (n/- +2 vec-size) vec) - #let [[level' root'] (let [init-level (get@ #level vec)] - (loop [level init-level - root (maybe.default (new-hierarchy []) - (pop-tail vec-size init-level (get@ #root vec)))] - (if (n/> branching-exponent level) - (case [(array.read +1 root) (array.read +0 root)] - [#.None (#.Some (#Hierarchy sub-node))] - (recur (level-down level) sub-node) - - ## [#.None (#.Some (#Base _))] - ## (undefined) - - _ - [level root]) - [level root])))]] - (wrap (|> vec - (update@ #size dec) - (set@ #level level') - (set@ #root root') - (set@ #tail new-tail)))))) - )) - -(def: #export (to-list vec) - (All [a] (-> (Row a) (List a))) - (list/compose (to-list' (#Hierarchy (get@ #root vec))) - (to-list' (#Base (get@ #tail vec))))) - -(def: #export (from-list list) - (All [a] (-> (List a) (Row a))) - (list/fold add - empty - list)) - -(def: #export (member? a/Equivalence vec val) - (All [a] (-> (Equivalence a) (Row a) a Bool)) - (list.member? a/Equivalence (to-list vec) val)) - -(def: #export empty? - (All [a] (-> (Row a) Bool)) - (|>> (get@ #size) (n/= +0))) - -## [Syntax] -(syntax: #export (row {elems (p.some s.any)}) - {#.doc (doc "Row literals." - (row 10 20 30 40))} - (wrap (list (` (from-list (list (~+ elems))))))) - -## [Structures] -(structure: #export (Equivalence Equivalence) (All [a] (-> (Equivalence a) (Equivalence (Node a)))) - (def: (= v1 v2) - (case [v1 v2] - [(#Base b1) (#Base b2)] - (:: (array.Equivalence Equivalence) = b1 b2) - - [(#Hierarchy h1) (#Hierarchy h2)] - (:: (array.Equivalence (Equivalence Equivalence)) = h1 h2) - - _ - false))) - -(structure: #export (Equivalence Equivalence) (All [a] (-> (Equivalence a) (Equivalence (Row a)))) - (def: (= v1 v2) - (and (n/= (get@ #size v1) (get@ #size v2)) - (let [(^open "Node/") (Equivalence Equivalence)] - (and (Node/= (#Base (get@ #tail v1)) - (#Base (get@ #tail v2))) - (Node/= (#Hierarchy (get@ #root v1)) - (#Hierarchy (get@ #root v2)))))))) - -(structure: _ (Fold Node) - (def: (fold f init xs) - (case xs - (#Base base) - (array/fold f init base) - - (#Hierarchy hierarchy) - (array/fold (function (_ node init') (fold f init' node)) - init - hierarchy)) - )) - -(structure: #export _ (Fold Row) - (def: (fold f init xs) - (let [(^open) Fold] - (fold f - (fold f - init - (#Hierarchy (get@ #root xs))) - (#Base (get@ #tail xs)))) - )) - -(structure: #export Monoid (All [a] (Monoid (Row a))) - (def: identity empty) - (def: (compose xs ys) - (list/fold add xs (to-list ys)))) - -(structure: _ (Functor Node) - (def: (map f xs) - (case xs - (#Base base) - (#Base (array/map f base)) - - (#Hierarchy hierarchy) - (#Hierarchy (array/map (map f) hierarchy))) - )) - -(structure: #export _ (Functor Row) - (def: (map f xs) - {#level (get@ #level xs) - #size (get@ #size xs) - #root (|> xs (get@ #root) (array/map (:: Functor map f))) - #tail (|> xs (get@ #tail) (array/map f)) - })) - -(structure: #export _ (Apply Row) - (def: functor Functor) - - (def: (apply ff fa) - (let [(^open) Functor - (^open) Fold - (^open) Monoid - results (map (function (_ f) (map f fa)) - ff)] - (fold compose identity results)))) - -(structure: #export _ (Monad Row) - (def: functor Functor) - - (def: wrap (|>> row)) - - (def: join - (let [(^open) Fold - (^open) Monoid] - (fold (function (_ post pre) (compose pre post)) identity)))) - -(def: #export (reverse xs) - (All [a] (-> (Row a) (Row a))) - (let [(^open) Fold - (^open) Monoid] - (fold add identity xs))) diff --git a/stdlib/source/lux/data/coll/sequence.lux b/stdlib/source/lux/data/coll/sequence.lux deleted file mode 100644 index ab8f1d625..000000000 --- a/stdlib/source/lux/data/coll/sequence.lux +++ /dev/null @@ -1,146 +0,0 @@ -(.module: - lux - (lux (control functor - monad - comonad - [continuation #+ pending Cont] - ["p" parser]) - [macro #+ with-gensyms] - (macro [code] - ["s" syntax #+ syntax: Syntax]) - (data (coll [list "List/" Monad]) - bool))) - -## [Types] -(type: #export (Sequence a) - {#.doc "An infinite sequence of values."} - (Cont [a (Sequence a)])) - -## [Utils] -(def: (cycle' x xs init full) - (All [a] - (-> a (List a) a (List a) (Sequence a))) - (case xs - #.Nil (pending [x (cycle' init full init full)]) - (#.Cons x' xs') (pending [x (cycle' x' xs' init full)]))) - -## [Functions] -(def: #export (iterate f x) - {#.doc "Create a sequence by applying a function to a value, and to its result, on and on..."} - (All [a] - (-> (-> a a) a (Sequence a))) - (pending [x (iterate f (f x))])) - -(def: #export (repeat x) - {#.doc "Repeat a value forever."} - (All [a] - (-> a (Sequence a))) - (pending [x (repeat x)])) - -(def: #export (cycle xs) - {#.doc "Go over the elements of a list forever. - - The list should not be empty."} - (All [a] - (-> (List a) (Maybe (Sequence a)))) - (case xs - #.Nil #.None - (#.Cons x xs') (#.Some (cycle' x xs' x xs')))) - -(do-template [ ] - [(def: #export ( s) - (All [a] (-> (Sequence a) )) - (let [[h t] (continuation.run s)] - ))] - - [head a h] - [tail (Sequence a) t]) - -(def: #export (nth idx s) - (All [a] (-> Nat (Sequence a) a)) - (let [[h t] (continuation.run s)] - (if (n/> +0 idx) - (nth (dec idx) t) - h))) - -(do-template [ ] - [(def: #export ( pred xs) - (All [a] - (-> (Sequence a) (List a))) - (let [[x xs'] (continuation.run xs)] - (if - (list& x ( xs')) - (list)))) - - (def: #export ( pred xs) - (All [a] - (-> (Sequence a) (Sequence a))) - (let [[x xs'] (continuation.run xs)] - (if - ( xs') - xs))) - - (def: #export ( pred xs) - (All [a] - (-> (Sequence a) [(List a) (Sequence a)])) - (let [[x xs'] (continuation.run xs)] - (if - (let [[tail next] ( xs')] - [(#.Cons [x tail]) next]) - [(list) xs])))] - - [take-while drop-while split-while (-> a Bool) (pred x) pred] - [take drop split Nat (n/> +0 pred) (dec pred)] - ) - -(def: #export (unfold step init) - {#.doc "A stateful way of infinitely calculating the values of a sequence."} - (All [a b] - (-> (-> a [a b]) a (Sequence b))) - (let [[next x] (step init)] - (pending [x (unfold step next)]))) - -(def: #export (filter p xs) - (All [a] (-> (-> a Bool) (Sequence a) (Sequence a))) - (let [[x xs'] (continuation.run xs)] - (if (p x) - (pending [x (filter p xs')]) - (filter p xs')))) - -(def: #export (partition p xs) - {#.doc "Split a sequence in two based on a predicate. - - The left side contains all entries for which the predicate is true. - - The right side contains all entries for which the predicate is false."} - (All [a] (-> (-> a Bool) (Sequence a) [(Sequence a) (Sequence a)])) - [(filter p xs) (filter (complement p) xs)]) - -## [Structures] -(structure: #export _ (Functor Sequence) - (def: (map f fa) - (let [[h t] (continuation.run fa)] - (pending [(f h) (map f t)])))) - -(structure: #export _ (CoMonad Sequence) - (def: functor Functor) - (def: unwrap head) - (def: (split wa) - (let [[head tail] (continuation.run wa)] - (pending [wa (split tail)])))) - -## [Pattern-matching] -(syntax: #export (^sequence& {patterns (s.form (p.many s.any))} - body - {branches (p.some s.any)}) - {#.doc (doc "Allows destructuring of sequences in pattern-matching expressions." - "Caveat emptor: Only use it for destructuring, and not for testing values within the sequences." - (let [(^sequence& x y z _tail) (some-sequence-func 1 2 3)] - (func x y z)))} - (with-gensyms [g!sequence] - (let [body+ (` (let [(~+ (List/join (List/map (function (_ pattern) - (list (` [(~ pattern) (~ g!sequence)]) - (` ((~! continuation.run) (~ g!sequence))))) - patterns)))] - (~ body)))] - (wrap (list& g!sequence body+ branches))))) diff --git a/stdlib/source/lux/data/coll/set.lux b/stdlib/source/lux/data/coll/set.lux deleted file mode 100644 index 929040ad0..000000000 --- a/stdlib/source/lux/data/coll/set.lux +++ /dev/null @@ -1,81 +0,0 @@ -(.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/ordered.lux b/stdlib/source/lux/data/coll/set/ordered.lux deleted file mode 100644 index 2ad835849..000000000 --- a/stdlib/source/lux/data/coll/set/ordered.lux +++ /dev/null @@ -1,86 +0,0 @@ -(.module: - lux - (lux (control [equivalence #+ Equivalence] - [order #+ Order]) - (data (coll [list "list/" Fold] - (dictionary ["//" ordered]))) - (type abstract))) - -(abstract: #export (Set a) - {} - - (//.Dictionary a a) - - (def: #export new - (All [a] (-> (Order a) (Set a))) - (|>> //.new :abstraction)) - - (def: #export (member? set elem) - (All [a] (-> (Set a) a Bool)) - (|> set :representation (//.contains? elem))) - - (do-template [ ] - [(def: #export - (All [a] (-> (Set a) (Maybe a))) - (|>> :representation ))] - - [min //.min] - [max //.max] - ) - - (do-template [ ] - [(def: #export - (-> (Set Any) Nat) - (|>> :representation ))] - - [size //.size] - [depth //.depth] - ) - - (def: #export (add elem set) - (All [a] (-> a (Set a) (Set a))) - (|> set :representation (//.put elem elem) :abstraction)) - - (def: #export (remove elem set) - (All [a] (-> a (Set a) (Set a))) - (|> set :representation (//.remove elem) :abstraction)) - - (def: #export to-list - (All [a] (-> (Set a) (List a))) - (|>> :representation //.keys)) - - (def: #export (from-list Order list) - (All [a] (-> (Order a) (List a) (Set a))) - (list/fold add (new Order) list)) - - (def: #export (union left right) - (All [a] (-> (Set a) (Set a) (Set a))) - (list/fold ..add right (..to-list left))) - - (def: #export (intersection left right) - (All [a] (-> (Set a) (Set a) (Set a))) - (|> (..to-list right) - (list.filter (..member? left)) - (..from-list (get@ #//.order (:representation right))))) - - (def: #export (difference param subject) - (All [a] (-> (Set a) (Set a) (Set a))) - (|> (..to-list subject) - (list.filter (|>> (..member? param) not)) - (..from-list (get@ #//.order (:representation subject))))) - - (structure: #export Equivalence (All [a] (Equivalence (Set a))) - (def: (= reference sample) - (:: (list.Equivalence (:: (:representation sample) eq)) - = (..to-list reference) (..to-list sample)))) - ) - -(def: #export (sub? super sub) - (All [a] (-> (Set a) (Set a) Bool)) - (|> sub - ..to-list - (list.every? (..member? super)))) - -(def: #export (super? sub super) - (All [a] (-> (Set a) (Set a) Bool)) - (sub? super sub)) diff --git a/stdlib/source/lux/data/coll/stack.lux b/stdlib/source/lux/data/coll/stack.lux deleted file mode 100644 index 8f93bdb69..000000000 --- a/stdlib/source/lux/data/coll/stack.lux +++ /dev/null @@ -1,42 +0,0 @@ -(.module: - lux - (lux (data (coll [list])))) - -## [Types] -(type: #export (Stack a) - (List a)) - -## [Values] -(def: #export empty - Stack - (list)) - -(def: #export (size stack) - (All [a] (-> (Stack a) Nat)) - (list.size stack)) - -(def: #export (empty? stack) - (All [a] (-> (Stack a) Bool)) - (list.empty? stack)) - -(def: #export (peek stack) - (All [a] (-> (Stack a) (Maybe a))) - (case stack - #.Nil - #.None - - (#.Cons value _) - (#.Some value))) - -(def: #export (pop stack) - (All [a] (-> (Stack a) (Stack a))) - (case stack - #.Nil - #.Nil - - (#.Cons _ stack') - stack')) - -(def: #export (push value stack) - (All [a] (-> a (Stack a) (Stack a))) - (#.Cons value stack)) diff --git a/stdlib/source/lux/data/coll/tree/finger.lux b/stdlib/source/lux/data/coll/tree/finger.lux deleted file mode 100644 index ea1ff0eee..000000000 --- a/stdlib/source/lux/data/coll/tree/finger.lux +++ /dev/null @@ -1,61 +0,0 @@ -(.module: - lux - (lux (control ["m" monoid]) - (data text/format))) - -(type: #export (Node m a) - (#Leaf m a) - (#Branch m (Node m a) (Node m a))) - -(type: #export (Tree m a) - {#monoid (m.Monoid m) - #node (Node m a)}) - -(def: #export (tag tree) - (All [m a] (-> (Tree m a) m)) - (case (get@ #node tree) - (^or (#Leaf tag _) (#Branch tag _ _)) - tag)) - -(def: #export (value tree) - (All [m a] (-> (Tree m a) a)) - (case (get@ #node tree) - (#Leaf tag value) - value - - (#Branch tag left right) - (value (set@ #node left tree)))) - -(def: #export (branch left right) - (All [m a] (-> (Tree m a) (Tree m a) (Tree m a))) - (let [Monoid (get@ #monoid right)] - {#monoid Monoid - #node (#Branch (:: Monoid compose (tag left) (tag right)) - (get@ #node left) - (get@ #node right))})) - -(def: #export (search pred tree) - (All [m a] (-> (-> m Bool) (Tree m a) (Maybe a))) - (let [tag/compose (get@ [#monoid #m.compose] tree)] - (if (pred (tag tree)) - (loop [_tag (get@ [#monoid #m.identity] tree) - _node (get@ #node tree)] - (case _node - (#Leaf _ value) - (#.Some value) - - (#Branch _ left right) - (let [shifted-tag (tag/compose _tag (tag (set@ #node left tree)))] - (if (pred shifted-tag) - (recur _tag left) - (recur shifted-tag right))))) - #.None))) - -(def: #export (found? pred tree) - (All [m a] (-> (-> m Bool) (Tree m a) Bool)) - (case (search pred tree) - (#.Some _) - true - - #.None - false)) diff --git a/stdlib/source/lux/data/coll/tree/rose.lux b/stdlib/source/lux/data/coll/tree/rose.lux deleted file mode 100644 index 1fb5fc85a..000000000 --- a/stdlib/source/lux/data/coll/tree/rose.lux +++ /dev/null @@ -1,73 +0,0 @@ -(.module: - lux - (lux (control functor - [monad #+ do Monad] - equivalence - ["p" parser] - fold) - (data (coll [list "L/" Monad Fold])) - [macro] - (macro [code] - ["s" syntax #+ syntax: Syntax]))) - -## [Types] -(type: #export (Tree a) - {#value a - #children (List (Tree a))}) - -## [Values] -(def: #export (flatten tree) - (All [a] (-> (Tree a) (List a))) - (#.Cons (get@ #value tree) - (L/join (L/map flatten (get@ #children tree))))) - -(def: #export (leaf value) - (All [a] (-> a (Tree a))) - {#value value - #children (list)}) - -(def: #export (branch value children) - (All [a] (-> a (List (Tree a)) (Tree a))) - {#value value - #children children}) - -## [Syntax] -(type: #rec Tree-Code - [Code (List Tree-Code)]) - -(def: tree^ - (Syntax Tree-Code) - (|> (|>> p.some s.record (p.seq s.any)) - p.rec - p.some - s.record - (p.seq s.any) - s.tuple)) - -(syntax: #export (tree {root tree^}) - {#.doc (doc "Tree literals." - (tree Int [10 {20 {} - 30 {} - 40 {}}]))} - (wrap (list (` (~ (loop [[value children] root] - (` {#value (~ value) - #children (list (~+ (L/map recur children)))}))))))) - -## [Structs] -(structure: #export (Equivalence Equivalence) (All [a] (-> (Equivalence a) (Equivalence (Tree a)))) - (def: (= tx ty) - (and (:: Equivalence = (get@ #value tx) (get@ #value ty)) - (:: (list.Equivalence (Equivalence Equivalence)) = (get@ #children tx) (get@ #children ty))))) - -(structure: #export _ (Functor Tree) - (def: (map f fa) - {#value (f (get@ #value fa)) - #children (L/map (map f) - (get@ #children fa))})) - -(structure: #export _ (Fold Tree) - (def: (fold f init tree) - (L/fold (function (_ tree' init') (fold f init' tree')) - (f (get@ #value tree) - init) - (get@ #children tree)))) diff --git a/stdlib/source/lux/data/coll/tree/rose/parser.lux b/stdlib/source/lux/data/coll/tree/rose/parser.lux deleted file mode 100644 index 3e3535649..000000000 --- a/stdlib/source/lux/data/coll/tree/rose/parser.lux +++ /dev/null @@ -1,50 +0,0 @@ -(.module: - lux - (lux (control ["p" parser] - ["ex" exception #+ exception:]) - (data ["E" error])) - [// #+ Tree] - (// [zipper #+ Zipper])) - -(type: #export (Parser t a) - (p.Parser (Zipper t) a)) - -(def: #export (run-zipper zipper parser) - (All [t a] (-> (Zipper t) (Parser t a) (E.Error a))) - (case (p.run zipper parser) - (#E.Success [zipper output]) - (#E.Success output) - - (#E.Error error) - (#E.Error error))) - -(def: #export (run tree parser) - (All [t a] (-> (Tree t) (Parser t a) (E.Error a))) - (run-zipper (zipper.zip tree) parser)) - -(def: #export value - (All [t] (Parser t t)) - (function (_ zipper) - (#E.Success [zipper (zipper.value zipper)]))) - -(exception: #export cannot-move-further) - -(do-template [ ] - [(def: #export - (All [t] (Parser t [])) - (function (_ zipper) - (let [next ( zipper)] - (if (is? zipper next) - (ex.throw cannot-move-further []) - (#E.Success [next []])))))] - - [up zipper.up] - [down zipper.down] - [left zipper.left] - [right zipper.right] - [root zipper.root] - [rightmost zipper.rightmost] - [leftmost zipper.leftmost] - [next zipper.next] - [prev zipper.prev] - ) diff --git a/stdlib/source/lux/data/coll/tree/rose/zipper.lux b/stdlib/source/lux/data/coll/tree/rose/zipper.lux deleted file mode 100644 index ba47b9f0a..000000000 --- a/stdlib/source/lux/data/coll/tree/rose/zipper.lux +++ /dev/null @@ -1,235 +0,0 @@ -(.module: - lux - (lux (control functor - comonad) - (data (coll [list "L/" Monad Fold Monoid] - (tree [rose #+ Tree "T/" Functor]) - [stack #+ Stack]) - [maybe "M/" Monad]) - [macro] - (macro [code] - ["s" syntax #+ syntax: Syntax]))) - -## Adapted from the clojure.zip namespace in the Clojure standard library. - -## [Types] -(type: #export (Zipper a) - {#.doc "Tree zippers, for easy navigation and editing over trees."} - {#parent (Maybe (Zipper a)) - #lefts (Stack (Tree a)) - #rights (Stack (Tree a)) - #node (Tree a)}) - -## [Values] -(def: #export (zip tree) - (All [a] (-> (Tree a) (Zipper a))) - {#parent #.None - #lefts stack.empty - #rights stack.empty - #node tree}) - -(def: #export (unzip zipper) - (All [a] (-> (Zipper a) (Tree a))) - (get@ #node zipper)) - -(def: #export (value zipper) - (All [a] (-> (Zipper a) a)) - (|> zipper (get@ [#node #rose.value]))) - -(def: #export (children zipper) - (All [a] (-> (Zipper a) (List (Tree a)))) - (|> zipper (get@ [#node #rose.children]))) - -(def: #export (branch? zipper) - (All [a] (-> (Zipper a) Bool)) - (|> zipper children list.empty? not)) - -(def: #export (leaf? zipper) - (All [a] (-> (Zipper a) Bool)) - (|> zipper branch? not)) - -(def: #export (end? zipper) - (All [a] (-> (Zipper a) Bool)) - (and (list.empty? (get@ #rights zipper)) - (list.empty? (children zipper)))) - -(def: #export (root? zipper) - (All [a] (-> (Zipper a) Bool)) - (case (get@ #parent zipper) - #.None - true - - _ - false)) - -(def: #export (down zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (case (children zipper) - #.Nil - zipper - - (#.Cons chead ctail) - {#parent (#.Some zipper) - #lefts stack.empty - #rights ctail - #node chead})) - -(def: #export (up zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (case (get@ #parent zipper) - #.None - zipper - - (#.Some parent) - (|> parent - ## TODO: Remove once new-luxc becomes the standard compiler. - (update@ #node (: (-> (Tree ($ +0)) (Tree ($ +0))) - (function (_ node) - (set@ #rose.children (L/compose (list.reverse (get@ #lefts zipper)) - (#.Cons (get@ #node zipper) - (get@ #rights zipper))) - node)))) - ## (update@ #node (function (_ node) - ## (set@ #rose.children (L/compose (list.reverse (get@ #lefts zipper)) - ## (#.Cons (get@ #node zipper) - ## (get@ #rights zipper))) - ## node))) - ))) - -(def: #export (root zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (loop [zipper zipper] - (case (get@ #parent zipper) - #.None zipper - (#.Some _) (recur (up zipper))))) - -(do-template [ ] - [(def: #export ( zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (case (get@ zipper) - #.Nil - zipper - - (#.Cons next side') - (|> zipper - (update@ (function (_ op-side) - (#.Cons (get@ #node zipper) op-side))) - (set@ side') - (set@ #node next)))) - - (def: #export ( zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (L/fold (function (_ _) ) zipper (get@ zipper)))] - - [right rightmost #rights #lefts] - [left leftmost #lefts #rights] - ) - -(do-template [ ] - [(def: #export ( zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (case (get@ zipper) - #.Nil - ( zipper) - - _ - ( zipper)))] - - [next #rights right down] - [prev #lefts left up] - ) - -(def: #export (set value zipper) - (All [a] (-> a (Zipper a) (Zipper a))) - (set@ [#node #rose.value] value zipper)) - -(def: #export (update f zipper) - (All [a] (-> (-> a a) (Zipper a) (Zipper a))) - (update@ [#node #rose.value] f zipper)) - -(def: #export (prepend-child value zipper) - (All [a] (-> a (Zipper a) (Zipper a))) - (update@ [#node #rose.children] - (function (_ children) - ## TODO: Remove once new-luxc becomes the standard compiler. - (list& (: (Tree ($ +0)) - (rose.tree [value {}])) - children) - ## (list& (rose.tree [value {}]) - ## children) - ) - zipper)) - -(def: #export (append-child value zipper) - (All [a] (-> a (Zipper a) (Zipper a))) - (update@ [#node #rose.children] - (function (_ children) - (L/compose children - ## TODO: Remove once new-luxc becomes the standard compiler. - (list (: (Tree ($ +0)) - (rose.tree [value {}]))) - ## (list (rose.tree [value {}])) - )) - zipper)) - -(def: #export (remove zipper) - (All [a] (-> (Zipper a) (Maybe (Zipper a)))) - (case (get@ #lefts zipper) - #.Nil - (case (get@ #parent zipper) - #.None - #.None - - (#.Some next) - (#.Some (|> next - (update@ [#node #rose.children] (|>> list.tail (maybe.default (list))))))) - - (#.Cons next side) - (#.Some (|> zipper - (set@ #lefts side) - (set@ #node next))))) - -(do-template [ ] - [(def: #export ( value zipper) - (All [a] (-> a (Zipper a) (Maybe (Zipper a)))) - (case (get@ #parent zipper) - #.None - #.None - - _ - (#.Some (|> zipper - (update@ (function (_ side) - ## TODO: Remove once new-luxc becomes the standard compiler. - (#.Cons (: (Tree ($ +0)) - (rose.tree [value {}])) - side) - ## (#.Cons (rose.tree [value {}]) - ## side) - ))))))] - - [insert-left #lefts] - [insert-right #rights] - ) - -(structure: #export _ (Functor Zipper) - (def: (map f fa) - {#parent (|> fa (get@ #parent) (M/map (map f))) - #lefts (|> fa (get@ #lefts) (L/map (T/map f))) - #rights (|> fa (get@ #rights) (L/map (T/map f))) - #node (T/map f (get@ #node fa))})) - -## TODO: Add again once new-luxc becomes the standard compiler. -## (structure: #export _ (CoMonad Zipper) -## (def: functor Functor) - -## (def: unwrap (get@ [#node #rose.value])) - -## (def: (split wa) -## (let [tree-splitter (function (tree-splitter tree) -## {#rose.value (zip tree) -## #rose.children (L/map tree-splitter -## (get@ #rose.children tree))})] -## {#parent (|> wa (get@ #parent) (M/map split)) -## #lefts (|> wa (get@ #lefts) (L/map tree-splitter)) -## #rights (|> wa (get@ #rights) (L/map tree-splitter)) -## #node (|> fa (get@ #node) tree-splitter)}))) diff --git a/stdlib/source/lux/data/collection/array.lux b/stdlib/source/lux/data/collection/array.lux new file mode 100644 index 000000000..46d5a9572 --- /dev/null +++ b/stdlib/source/lux/data/collection/array.lux @@ -0,0 +1,211 @@ +(.module: + lux + (lux (control [monoid #+ Monoid] + [functor #+ Functor] + [equivalence #+ Equivalence] + fold) + (data (collection [list "list/" Fold]) + [product]) + )) + +(def: #export (new size) + (All [a] (-> Nat (Array a))) + ("lux array new" size)) + +(def: #export (size xs) + (All [a] (-> (Array a) Nat)) + ("lux array size" xs)) + +(def: #export (read i xs) + (All [a] + (-> Nat (Array a) (Maybe a))) + ("lux array get" xs i)) + +(def: #export (write i x xs) + (All [a] + (-> Nat a (Array a) (Array a))) + ("lux array put" xs i x)) + +(def: #export (delete i xs) + (All [a] + (-> Nat (Array a) (Array a))) + ("lux array remove" xs i)) + +(def: #export (copy length src-start src-array dest-start dest-array) + (All [a] + (-> Nat Nat (Array a) Nat (Array a) + (Array a))) + (if (n/= +0 length) + dest-array + (list/fold (function (_ offset target) + (case (read (n/+ offset src-start) src-array) + #.None + target + + (#.Some value) + (write (n/+ offset dest-start) value target))) + dest-array + (list.n/range +0 (dec length))))) + +(def: #export (occupied array) + {#.doc "Finds out how many cells in an array are occupied."} + (All [a] (-> (Array a) Nat)) + (list/fold (function (_ idx count) + (case (read idx array) + #.None + count + + (#.Some _) + (inc count))) + +0 + (list.indices (size array)))) + +(def: #export (vacant array) + {#.doc "Finds out how many cells in an array are vacant."} + (All [a] (-> (Array a) Nat)) + (n/- (occupied array) (size array))) + +(def: #export (filter p xs) + (All [a] + (-> (-> a Bool) (Array a) (Array a))) + (list/fold (function (_ idx xs') + (case (read idx xs) + #.None + xs' + + (#.Some x) + (if (p x) + xs' + (delete idx xs')))) + xs + (list.indices (size xs)))) + +(def: #export (find p xs) + (All [a] + (-> (-> a Bool) (Array a) (Maybe a))) + (let [arr-size (size xs)] + (loop [idx +0] + (if (n/< arr-size idx) + (case (read idx xs) + #.None + (recur (inc idx)) + + (#.Some x) + (if (p x) + (#.Some x) + (recur (inc idx)))) + #.None)))) + +(def: #export (find+ p xs) + {#.doc "Just like 'find', but with access to the index of each value."} + (All [a] + (-> (-> Nat a Bool) (Array a) (Maybe [Nat a]))) + (let [arr-size (size xs)] + (loop [idx +0] + (if (n/< arr-size idx) + (case (read idx xs) + #.None + (recur (inc idx)) + + (#.Some x) + (if (p idx x) + (#.Some [idx x]) + (recur (inc idx)))) + #.None)))) + +(def: #export (clone xs) + (All [a] (-> (Array a) (Array a))) + (let [arr-size (size xs)] + (list/fold (function (_ idx ys) + (case (read idx xs) + #.None + ys + + (#.Some x) + (write idx x ys))) + (new arr-size) + (list.indices arr-size)))) + +(def: #export (from-list xs) + (All [a] (-> (List a) (Array a))) + (product.right (list/fold (function (_ x [idx arr]) + [(inc idx) (write idx x arr)]) + [+0 (new (list.size xs))] + xs))) + +(def: underflow Nat (dec +0)) + +(def: #export (to-list array) + (All [a] (-> (Array a) (List a))) + (loop [idx (dec (size array)) + output #.Nil] + (if (n/= underflow idx) + output + (recur (dec idx) + (case (read idx array) + (#.Some head) + (#.Cons head output) + + #.None + output))))) + +(structure: #export (Equivalence Equivalence) + (All [a] (-> (Equivalence a) (Equivalence (Array a)))) + (def: (= xs ys) + (let [sxs (size xs) + sxy (size ys)] + (and (n/= sxy sxs) + (list/fold (function (_ idx prev) + (and prev + (case [(read idx xs) (read idx ys)] + [#.None #.None] + true + + [(#.Some x) (#.Some y)] + (:: Equivalence = x y) + + _ + false))) + true + (list.n/range +0 (dec sxs))))) + )) + +(structure: #export Monoid (All [a] (Monoid (Array a))) + (def: identity (new +0)) + + (def: (compose xs ys) + (let [sxs (size xs) + sxy (size ys)] + (|> (new (n/+ sxy sxs)) + (copy sxs +0 xs +0) + (copy sxy +0 ys sxs))))) + +(structure: #export _ (Functor Array) + (def: (map f ma) + (let [arr-size (size ma)] + (if (n/= +0 arr-size) + (new arr-size) + (list/fold (function (_ idx mb) + (case (read idx ma) + #.None + mb + + (#.Some x) + (write idx (f x) mb))) + (new arr-size) + (list.n/range +0 (dec arr-size))) + )))) + +(structure: #export _ (Fold Array) + (def: (fold f init xs) + (let [arr-size (size xs)] + (loop [so-far init + idx +0] + (if (n/< arr-size idx) + (case (read idx xs) + #.None + (recur so-far (inc idx)) + + (#.Some value) + (recur (f value so-far) (inc idx))) + so-far))))) diff --git a/stdlib/source/lux/data/collection/bits.lux b/stdlib/source/lux/data/collection/bits.lux new file mode 100644 index 000000000..a7be3a240 --- /dev/null +++ b/stdlib/source/lux/data/collection/bits.lux @@ -0,0 +1,164 @@ +(.module: + [lux #- not and or] + (lux (control [equivalence #+ Equivalence] + pipe) + (data [maybe] + [bit] + (collection [array "array/" Fold]) + text/format))) + +(type: #export Chunk I64) + +(def: #export chunk-size bit.width) + +(type: #export Bits + (Array Chunk)) + +(def: empty-chunk Chunk (.i64 +0)) + +(def: #export empty + Bits + (array.new +0)) + +(def: #export (size bits) + (-> Bits Nat) + (array/fold (function (_ chunk total) + (|> chunk bit.count (n/+ total))) + +0 + bits)) + +(def: #export (capacity bits) + (-> Bits Nat) + (|> bits array.size (n/* chunk-size))) + +(def: #export empty? + (-> Bits Bool) + (|>> size (n/= +0))) + +(def: #export (get index bits) + (-> Nat Bits Bool) + (let [[chunk-index bit-index] (n//% chunk-size index)] + (.and (n/< (array.size bits) chunk-index) + (|> (array.read chunk-index bits) + (maybe.default empty-chunk) + (bit.set? bit-index))))) + +(def: (chunk idx bits) + (-> Nat Bits Chunk) + (if (n/< (array.size bits) idx) + (|> bits (array.read idx) (maybe.default empty-chunk)) + empty-chunk)) + +(do-template [ ] + [(def: #export ( index input) + (-> Nat Bits Bits) + (let [[chunk-index bit-index] (n//% chunk-size index)] + (loop [size|output (n/max (inc chunk-index) + (array.size input)) + output ..empty] + (let [idx|output (dec size|output)] + (if (n/> +0 size|output) + (case (|> (..chunk idx|output input) + (cond> [(new> (n/= chunk-index idx|output))] + [( bit-index)] + + ## else + []) + .nat) + +0 + ## TODO: Remove 'no-op' once new-luxc is the official compiler. + (let [no-op (recur (dec size|output) output)] + no-op) + + chunk + (|> (if (is? ..empty output) + (: Bits (array.new size|output)) + output) + (array.write idx|output (.i64 chunk)) + (recur (dec size|output)))) + output)))))] + + [set bit.set] + [clear bit.clear] + [flip bit.flip] + ) + +(def: #export (intersects? reference sample) + (-> Bits Bits Bool) + (let [chunks (n/min (array.size reference) + (array.size sample))] + (loop [idx +0] + (if (n/< chunks idx) + (.or (|> (..chunk idx sample) + (bit.and (..chunk idx reference)) + ("lux i64 =" empty-chunk) + .not) + (recur (inc idx))) + false)))) + +(def: #export (not input) + (-> Bits Bits) + (case (array.size input) + +0 + ..empty + + size|output + (loop [size|output size|output + output ..empty] + (let [idx (dec size|output)] + (case (|> input (..chunk idx) bit.not .nat) + +0 + (recur (dec size|output) output) + + chunk + (if (n/> +0 size|output) + (|> (if (is? ..empty output) + (: Bits (array.new size|output)) + output) + (array.write idx (.i64 chunk)) + (recur (dec size|output))) + output)))))) + +(do-template [ ] + [(def: #export ( param subject) + (-> Bits Bits Bits) + (case (n/max (array.size param) + (array.size subject)) + +0 + ..empty + + size|output + (loop [size|output size|output + output ..empty] + (let [idx (dec size|output)] + (if (n/> +0 size|output) + (case (|> (..chunk idx subject) + ( (..chunk idx param)) + .nat) + +0 + (recur (dec size|output) output) + + chunk + (|> (if (is? ..empty output) + (: Bits (array.new size|output)) + output) + (array.write idx (.i64 chunk)) + (recur (dec size|output)))) + output)))))] + + [and bit.and] + [or bit.or] + [xor bit.xor] + ) + +(structure: #export _ (Equivalence Bits) + (def: (= reference sample) + (let [size (n/max (array.size reference) + (array.size sample))] + (loop [idx +0] + (if (n/< size idx) + (.and ("lux i64 =" + (..chunk idx reference) + (..chunk idx sample)) + (recur (inc idx))) + true))))) diff --git a/stdlib/source/lux/data/collection/dictionary.lux b/stdlib/source/lux/data/collection/dictionary.lux new file mode 100644 index 000000000..368a77469 --- /dev/null +++ b/stdlib/source/lux/data/collection/dictionary.lux @@ -0,0 +1,685 @@ +(.module: + lux + (lux (control hash + [equivalence #+ Equivalence]) + (data [maybe] + (collection [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/collection/dictionary/ordered.lux b/stdlib/source/lux/data/collection/dictionary/ordered.lux new file mode 100644 index 000000000..478b75a2a --- /dev/null +++ b/stdlib/source/lux/data/collection/dictionary/ordered.lux @@ -0,0 +1,569 @@ +(.module: + lux + (lux (control [monad #+ do Monad] + equivalence + [order #+ Order]) + (data (collection [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 (Dictionary k v) + {#order (Order k) + #root (Maybe (Node k v))}) + +(def: #export (new Order) + (All [k v] (-> (Order k) (Dictionary 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 (Dictionary 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 (Dictionary 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] (-> (Dictionary 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] (-> (Dictionary k v) Nat)) + (loop [node (get@ #root dict)] + (case node + #.None + +0 + + (#.Some node) + (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 (Dictionary k v) (Dictionary 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 (Dictionary k v) (Dictionary 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 (update key transform dict) + (All [k v] (-> k (-> v v) (Dictionary k v) (Maybe (Dictionary k v)))) + (do maybe.Monad + [old (get key dict)] + (wrap (put key (transform old) dict)))) + +(def: #export (from-list Order list) + (All [k v] (-> (Order k) (List [k v]) (Dictionary k v))) + (L/fold (function (_ [key value] dict) + (put key value dict)) + (new Order) + list)) + +(do-template [ ] + [(def: #export ( dict) + (All [k v] (-> (Dictionary 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')] + ) + +(structure: #export (Equivalence Equivalence) (All [k v] (-> (Equivalence v) (Equivalence (Dictionary k v)))) + (def: (= reference sample) + (let [Equivalence (:: sample eq)] + (loop [entriesR (entries reference) + entriesS (entries sample)] + (case [entriesR entriesS] + [#.Nil #.Nil] + true + + [(#.Cons [keyR valueR] entriesR') (#.Cons [keyS valueS] entriesS')] + (and (:: Equivalence = keyR keyS) + (:: Equivalence = valueR valueS) + (recur entriesR' entriesS')) + + _ + false))))) diff --git a/stdlib/source/lux/data/collection/dictionary/plist.lux b/stdlib/source/lux/data/collection/dictionary/plist.lux new file mode 100644 index 000000000..c483a3287 --- /dev/null +++ b/stdlib/source/lux/data/collection/dictionary/plist.lux @@ -0,0 +1,62 @@ +(.module: + lux + (lux (data [text "text/" Equivalence]))) + +(type: #export (PList a) + (List [Text a])) + +(def: #export (get key properties) + (All [a] (-> Text (PList a) (Maybe a))) + (case properties + #.Nil + #.None + + (#.Cons [k' v'] properties') + (if (text/= key k') + (#.Some v') + (get key properties')))) + +(def: #export (contains? key properties) + (All [a] (-> Text (PList a) Bool)) + (case (get key properties) + (#.Some _) + true + + #.None + false)) + +(def: #export (put key val properties) + (All [a] (-> Text a (PList a) (PList a))) + (case properties + #.Nil + (list [key val]) + + (#.Cons [k' v'] properties') + (if (text/= key k') + (#.Cons [key val] + properties') + (#.Cons [k' v'] + (put key val properties'))))) + +(def: #export (update key f properties) + (All [a] (-> Text (-> a a) (PList a) (PList a))) + (case properties + #.Nil + #.Nil + + (#.Cons [k' v'] properties') + (if (text/= key k') + (#.Cons [k' (f v')] properties') + (#.Cons [k' v'] (update key f properties'))))) + +(def: #export (remove key properties) + (All [a] (-> Text (PList a) (PList a))) + (case properties + #.Nil + properties + + (#.Cons [k' v'] properties') + (if (text/= key k') + properties' + (#.Cons [k' v'] + (remove key properties'))))) diff --git a/stdlib/source/lux/data/collection/list.lux b/stdlib/source/lux/data/collection/list.lux new file mode 100644 index 000000000..74ef2e5cc --- /dev/null +++ b/stdlib/source/lux/data/collection/list.lux @@ -0,0 +1,554 @@ +(.module: + lux + (lux (control [monoid #+ Monoid] + [functor #+ Functor] + [apply #+ Apply] + [monad #+ do Monad] + [equivalence #+ Equivalence] + [fold]) + (data [number "nat/" Codec] + bool + [product]))) + +## [Types] +## (type: (List a) +## #Nil +## (#Cons a (List a))) + +## [Functions] +(structure: #export _ (fold.Fold List) + (def: (fold f init xs) + (case xs + #.Nil + init + + (#.Cons [x xs']) + (fold f (f x init) xs')))) + +(open: Fold) + +(def: #export (reverse xs) + (All [a] + (-> (List a) (List a))) + (fold (function (_ head tail) (#.Cons head tail)) + #.Nil + xs)) + +(def: #export (filter p xs) + (All [a] + (-> (-> a Bool) (List a) (List a))) + (case xs + #.Nil + #.Nil + + (#.Cons [x xs']) + (if (p x) + (#.Cons [x (filter p xs')]) + (filter p xs')))) + +(def: #export (partition p xs) + {#.doc "Divide the list into all elements that satisfy a predicate, and all elements that do not."} + (All [a] (-> (-> a Bool) (List a) [(List a) (List a)])) + [(filter p xs) (filter (complement p) xs)]) + +(def: #export (as-pairs xs) + {#.doc "Cut the list into pairs of 2. + + Caveat emptor: If the list has an uneven number of elements, the last one will be skipped."} + (All [a] (-> (List a) (List [a a]))) + (case xs + (^ (#.Cons [x1 (#.Cons [x2 xs'])])) + (#.Cons [[x1 x2] (as-pairs xs')]) + + _ + #.Nil)) + +(do-template [ ] + [(def: #export ( n xs) + (All [a] + (-> Nat (List a) (List a))) + (if (n/> +0 n) + (case xs + #.Nil + #.Nil + + (#.Cons [x xs']) + ) + ))] + + [take (#.Cons [x (take (dec n) xs')]) #.Nil] + [drop (drop (dec n) xs') xs] + ) + +(do-template [ ] + [(def: #export ( p xs) + (All [a] + (-> (-> a Bool) (List a) (List a))) + (case xs + #.Nil + #.Nil + + (#.Cons [x xs']) + (if (p x) + + )))] + + [take-while (#.Cons [x (take-while p xs')]) #.Nil] + [drop-while (drop-while p xs') xs] + ) + +(def: #export (split n xs) + (All [a] + (-> Nat (List a) [(List a) (List a)])) + (if (n/> +0 n) + (case xs + #.Nil + [#.Nil #.Nil] + + (#.Cons [x xs']) + (let [[tail rest] (split (dec n) xs')] + [(#.Cons [x tail]) rest])) + [#.Nil xs])) + +(def: (split-with' p ys xs) + (All [a] + (-> (-> a Bool) (List a) (List a) [(List a) (List a)])) + (case xs + #.Nil + [ys xs] + + (#.Cons [x xs']) + (if (p x) + (split-with' p (#.Cons [x ys]) xs') + [ys xs]))) + +(def: #export (split-with p xs) + {#.doc "Segment the list by using a predicate to tell when to cut."} + (All [a] + (-> (-> a Bool) (List a) [(List a) (List a)])) + (let [[ys' xs'] (split-with' p #.Nil xs)] + [(reverse ys') xs'])) + +(def: #export (split-all n xs) + {#.doc "Segment the list in chunks of size n."} + (All [a] (-> Nat (List a) (List (List a)))) + (case xs + #.Nil + (list) + + _ + (let [[pre post] (split n xs)] + (#.Cons pre (split-all n post))))) + +(def: #export (repeat n x) + {#.doc "A list of the value x, repeated n times."} + (All [a] + (-> Nat a (List a))) + (if (n/> +0 n) + (#.Cons [x (repeat (dec n) x)]) + #.Nil)) + +(def: (iterate' f x) + (All [a] + (-> (-> a (Maybe a)) a (List a))) + (case (f x) + (#.Some x') + (list& x (iterate' f x')) + + #.None + (list))) + +(def: #export (iterate f x) + {#.doc "Generates a list element by element until the function returns #.None."} + (All [a] + (-> (-> a (Maybe a)) a (List a))) + (case (f x) + (#.Some x') + (list& x (iterate' f x')) + + #.None + (list x))) + +(def: #export (find p xs) + {#.doc "Returns the first value in the list for which the predicate is true."} + (All [a] + (-> (-> a Bool) (List a) (Maybe a))) + (case xs + #.Nil + #.None + + (#.Cons [x xs']) + (if (p x) + (#.Some x) + (find p xs')))) + +(def: #export (search check xs) + (All [a b] + (-> (-> a (Maybe b)) (List a) (Maybe b))) + (case xs + #.Nil + #.None + + (#.Cons [x xs']) + (case (check x) + (#.Some output) + (#.Some output) + + #.None + (search check xs')))) + +(def: #export (search-all check xs) + (All [a b] + (-> (-> a (Maybe b)) (List a) (List b))) + (case xs + #.Nil + #.None + + (#.Cons [x xs']) + (case (check x) + (#.Some output) + (#.Cons output (search-all check xs')) + + #.None + (search-all check xs')))) + +(def: #export (interpose sep xs) + {#.doc "Puts a value between every two elements in the list."} + (All [a] + (-> a (List a) (List a))) + (case xs + #.Nil + xs + + (#.Cons [x #.Nil]) + xs + + (#.Cons [x xs']) + (#.Cons [x (#.Cons [sep (interpose sep xs')])]))) + +(def: #export (size list) + (All [a] (-> (List a) Nat)) + (fold (function (_ _ acc) (n/+ +1 acc)) +0 list)) + +(do-template [ ] + [(def: #export ( p xs) + (All [a] + (-> (-> a Bool) (List a) Bool)) + (loop [xs xs] + (case xs + #.Nil + + + (#.Cons x xs') + (case (p x) + + (recur xs') + + output + output))))] + + [every? true and] + [any? false or] + ) + +(def: #export (nth i xs) + {#.doc "Fetches the element at the specified index."} + (All [a] + (-> Nat (List a) (Maybe a))) + (case xs + #.Nil + #.None + + (#.Cons [x xs']) + (if (n/= +0 i) + (#.Some x) + (nth (dec i) xs')))) + +## [Structures] +(structure: #export (Equivalence Equivalence) + (All [a] (-> (Equivalence a) (Equivalence (List a)))) + (def: (= xs ys) + (case [xs ys] + [#.Nil #.Nil] + true + + [(#.Cons x xs') (#.Cons y ys')] + (and (:: Equivalence = x y) + (= xs' ys')) + + [_ _] + false + ))) + +(structure: #export Monoid (All [a] + (Monoid (List a))) + (def: identity #.Nil) + (def: (compose xs ys) + (case xs + #.Nil ys + (#.Cons x xs') (#.Cons x (compose xs' ys))))) + +(open: Monoid) + +(structure: #export _ (Functor List) + (def: (map f ma) + (case ma + #.Nil #.Nil + (#.Cons a ma') (#.Cons (f a) (map f ma'))))) + +(open: Functor) + +(structure: #export _ (Apply List) + (def: functor Functor) + + (def: (apply ff fa) + (case ff + #.Nil + #.Nil + + (#.Cons f ff') + (compose (map f fa) (apply ff' fa))))) + +(structure: #export _ (Monad List) + (def: functor Functor) + + (def: (wrap a) + (#.Cons a #.Nil)) + + (def: join (|>> reverse (fold compose identity)))) + +## [Functions] +(def: #export (sort < xs) + (All [a] (-> (-> a a Bool) (List a) (List a))) + (case xs + #.Nil + (list) + + (#.Cons x xs') + (let [[pre post] (fold (function (_ x' [pre post]) + (if (< x x') + [(#.Cons x' pre) post] + [pre (#.Cons x' post)])) + [(list) (list)] + xs')] + ($_ compose (sort < pre) (list x) (sort < post))))) + +(do-template [ ] + [(def: #export ( from to) + {#.doc "Generates an inclusive interval of values [from, to]."} + (-> (List )) + (cond ( to from) + (list& from ( (inc from) to)) + + ( to from) + (list& from ( (dec from) to)) + + ## (= to from) + (list from)))] + + [i/range Int i/< i/>] + [n/range Nat n/< n/>] + ) + +(def: #export (empty? xs) + (All [a] (-> (List a) Bool)) + (case xs + #.Nil true + _ false)) + +(def: #export (member? eq xs x) + (All [a] (-> (Equivalence a) (List a) a Bool)) + (case xs + #.Nil false + (#.Cons x' xs') (or (:: eq = x x') + (member? eq xs' x)))) + +(do-template [ ] + [(def: #export ( xs) + {#.doc } + (All [a] (-> (List a) (Maybe ))) + (case xs + #.Nil + #.None + + (#.Cons x xs') + (#.Some )))] + + [head a x "Returns the first element of a list."] + [tail (List a) xs' "For a list of size N, returns the N-1 elements after the first one."] + ) + +## [Syntax] +(def: (symbol$ name) + (-> Text Code) + [["" +0 +0] (#.Symbol "" name)]) + +(macro: #export (zip tokens state) + {#.doc (doc "Create list zippers with the specified number of input lists." + (def: #export zip2 (zip +2)) + (def: #export zip3 (zip +3)) + ((zip +3) xs ys zs))} + (case tokens + (^ (list [_ (#.Nat num-lists)])) + (if (n/> +0 num-lists) + (let [(^open) Functor + indices (n/range +0 (dec num-lists)) + type-vars (: (List Code) (map (|>> nat/encode symbol$) indices)) + zip-type (` (All [(~+ type-vars)] + (-> (~+ (map (: (-> Code Code) (function (_ var) (` (List (~ var))))) + type-vars)) + (List [(~+ type-vars)])))) + vars+lists (|> indices + (map inc) + (map (function (_ idx) + (let [base (nat/encode idx)] + [(symbol$ base) + (symbol$ ("lux text concat" base "'"))])))) + pattern (` [(~+ (map (function (_ [v vs]) (` (#.Cons (~ v) (~ vs)))) + vars+lists))]) + g!step (symbol$ "\tstep\t") + g!blank (symbol$ "\t_\t") + list-vars (map product.right vars+lists) + code (` (: (~ zip-type) + (function ((~ g!step) (~+ list-vars)) + (case [(~+ list-vars)] + (~ pattern) + (#.Cons [(~+ (map product.left vars+lists))] + ((~ g!step) (~+ list-vars))) + + (~ g!blank) + #.Nil))))] + (#.Right [state (list code)])) + (#.Left "Cannot zip 0 lists.")) + + _ + (#.Left "Wrong syntax for zip"))) + +(def: #export zip2 (zip +2)) +(def: #export zip3 (zip +3)) + +(macro: #export (zip-with tokens state) + {#.doc (doc "Create list zippers with the specified number of input lists." + (def: #export zip2-with (zip-with +2)) + (def: #export zip3-with (zip-with +3)) + ((zip-with +2) i/+ xs ys))} + (case tokens + (^ (list [_ (#.Nat num-lists)])) + (if (n/> +0 num-lists) + (let [(^open) Functor + indices (n/range +0 (dec num-lists)) + g!return-type (symbol$ "\treturn-type\t") + g!func (symbol$ "\tfunc\t") + type-vars (: (List Code) (map (|>> nat/encode symbol$) indices)) + zip-type (` (All [(~+ type-vars) (~ g!return-type)] + (-> (-> (~+ type-vars) (~ g!return-type)) + (~+ (map (: (-> Code Code) (function (_ var) (` (List (~ var))))) + type-vars)) + (List (~ g!return-type))))) + vars+lists (|> indices + (map inc) + (map (function (_ idx) + (let [base (nat/encode idx)] + [(symbol$ base) + (symbol$ ("lux text concat" base "'"))])))) + pattern (` [(~+ (map (function (_ [v vs]) (` (#.Cons (~ v) (~ vs)))) + vars+lists))]) + g!step (symbol$ "\tstep\t") + g!blank (symbol$ "\t_\t") + list-vars (map product.right vars+lists) + code (` (: (~ zip-type) + (function ((~ g!step) (~ g!func) (~+ list-vars)) + (case [(~+ list-vars)] + (~ pattern) + (#.Cons ((~ g!func) (~+ (map product.left vars+lists))) + ((~ g!step) (~ g!func) (~+ list-vars))) + + (~ g!blank) + #.Nil))))] + (#.Right [state (list code)])) + (#.Left "Cannot zip-with 0 lists.")) + + _ + (#.Left "Wrong syntax for zip-with"))) + +(def: #export zip2-with (zip-with +2)) +(def: #export zip3-with (zip-with +3)) + +(def: #export (last xs) + (All [a] (-> (List a) (Maybe a))) + (case xs + #.Nil + #.None + + (#.Cons x #.Nil) + (#.Some x) + + (#.Cons x xs') + (last xs'))) + +(def: #export (inits xs) + {#.doc "For a list of size N, returns the first N-1 elements. + + Empty lists will result in a #.None value being returned instead."} + (All [a] (-> (List a) (Maybe (List a)))) + (case xs + #.Nil + #.None + + (#.Cons x #.Nil) + (#.Some #.Nil) + + (#.Cons x xs') + (case (inits xs') + #.None + (undefined) + + (#.Some tail) + (#.Some (#.Cons x tail))) + )) + +(def: #export (concat xss) + (All [a] (-> (List (List a)) (List a))) + (:: Monad join xss)) + +(structure: #export (ListT Monad) + (All [M] (-> (Monad M) (Monad (All [a] (M (List a)))))) + + (def: functor (functor.compose (get@ #monad.functor Monad) Functor)) + + (def: wrap (|>> (:: Monad wrap) (:: Monad wrap))) + + (def: (join MlMla) + (do Monad + [lMla MlMla + ## TODO: Remove this version ASAP and use one below. + lla (: (($ +0) (List (List ($ +1)))) + (monad.seq @ lMla)) + ## lla (monad.seq @ lMla) + ] + (wrap (concat lla))))) + +(def: #export (lift Monad) + (All [M a] (-> (Monad M) (-> (M a) (M (List a))))) + (monad.lift Monad (:: Monad wrap))) + +(def: (enumerate' idx xs) + (All [a] (-> Nat (List a) (List [Nat a]))) + (case xs + #.Nil + #.Nil + + (#.Cons x xs') + (#.Cons [idx x] (enumerate' (inc idx) xs')))) + +(def: #export (enumerate xs) + {#.doc "Pairs every element in the list with its index, starting at 0."} + (All [a] (-> (List a) (List [Nat a]))) + (enumerate' +0 xs)) + +(def: #export (indices size) + {#.doc "Produces all the valid indices for a given size."} + (All [a] (-> Nat (List Nat))) + (if (n/= +0 size) + (list) + (|> size dec (n/range +0)))) diff --git a/stdlib/source/lux/data/collection/queue.lux b/stdlib/source/lux/data/collection/queue.lux new file mode 100644 index 000000000..a0206a9eb --- /dev/null +++ b/stdlib/source/lux/data/collection/queue.lux @@ -0,0 +1,78 @@ +(.module: + lux + (lux (control [equivalence #+ Equivalence] + ["F" functor]) + (data (collection [list "L/" Monoid Functor])))) + +(type: #export (Queue a) + {#front (List a) + #rear (List a)}) + +(def: #export empty + Queue + {#front (list) + #rear (list)}) + +(def: #export (from-list entries) + (All [a] (-> (List a) (Queue a))) + {#front entries + #rear (list)}) + +(def: #export (to-list queue) + (All [a] (-> (Queue a) (List a))) + (let [(^slots [#front #rear]) queue] + (L/compose front (list.reverse rear)))) + +(def: #export peek + (All [a] (-> (Queue a) (Maybe a))) + (|>> (get@ #front) list.head)) + +(def: #export (size queue) + (All [a] (-> (Queue a) Nat)) + (let [(^slots [#front #rear]) queue] + (n/+ (list.size front) + (list.size rear)))) + +(def: #export empty? + (All [a] (-> (Queue a) Bool)) + (|>> (get@ #front) list.empty?)) + +(def: #export (member? Equivalence queue member) + (All [a] (-> (Equivalence a) (Queue a) a Bool)) + (let [(^slots [#front #rear]) queue] + (or (list.member? Equivalence front member) + (list.member? Equivalence rear member)))) + +(def: #export (pop queue) + (All [a] (-> (Queue a) (Queue a))) + (case (get@ #front queue) + (^ (list)) ## Empty... + queue + + (^ (list _)) ## Front has dried up... + (|> queue + (set@ #front (list.reverse (get@ #rear queue))) + (set@ #rear (list))) + + (^ (list& _ front')) ## Consume front! + (|> queue + (set@ #front front')))) + +(def: #export (push val queue) + (All [a] (-> a (Queue a) (Queue a))) + (case (get@ #front queue) + #.Nil + (set@ #front (list val) queue) + + _ + (update@ #rear (|>> (#.Cons val)) queue))) + +(structure: #export (Equivalence Equivalence) + (All [a] (-> (Equivalence a) (Equivalence (Queue a)))) + (def: (= qx qy) + (:: (list.Equivalence Equivalence) = (to-list qx) (to-list qy)))) + +(structure: #export _ (F.Functor Queue) + (def: (map f fa) + {#front (|> fa (get@ #front) (L/map f)) + #rear (|> fa (get@ #rear) (L/map f))})) diff --git a/stdlib/source/lux/data/collection/queue/priority.lux b/stdlib/source/lux/data/collection/queue/priority.lux new file mode 100644 index 000000000..d697b91c7 --- /dev/null +++ b/stdlib/source/lux/data/collection/queue/priority.lux @@ -0,0 +1,102 @@ +(.module: + lux + (lux (control [equivalence #+ Equivalence] + [monad #+ do Monad]) + (data (collection (tree [finger #+ Tree])) + [number "nat/" Interval] + [maybe]))) + +(type: #export Priority Nat) + +(type: #export (Queue a) + (Maybe (Tree Priority a))) + +(def: #export max Priority nat/top) +(def: #export min Priority nat/bottom) + +(def: #export empty + Queue + #.None) + +(def: #export (peek queue) + (All [a] (-> (Queue a) (Maybe a))) + (do maybe.Monad + [fingers queue] + (wrap (maybe.assume (finger.search (n/= (finger.tag fingers)) fingers))))) + +(def: #export (size queue) + (All [a] (-> (Queue a) Nat)) + (case queue + #.None + +0 + + (#.Some fingers) + (loop [node (get@ #finger.node fingers)] + (case node + (#finger.Leaf _ _) + +1 + + (#finger.Branch _ left right) + (n/+ (recur left) (recur right)))))) + +(def: #export (member? Equivalence queue member) + (All [a] (-> (Equivalence a) (Queue a) a Bool)) + (case queue + #.None + false + + (#.Some fingers) + (loop [node (get@ #finger.node fingers)] + (case node + (#finger.Leaf _ reference) + (:: Equivalence = reference member) + + (#finger.Branch _ left right) + (or (recur left) + (recur right)))))) + +(def: #export (pop queue) + (All [a] (-> (Queue a) (Queue a))) + (do maybe.Monad + [fingers queue + #let [highest-priority (finger.tag fingers)] + node' (loop [node (get@ #finger.node fingers)] + (case node + (#finger.Leaf priority reference) + (if (n/= highest-priority priority) + #.None + (#.Some node)) + + (#finger.Branch priority left right) + (if (n/= highest-priority (finger.tag (set@ #finger.node left fingers))) + (case (recur left) + #.None + (#.Some right) + + (#.Some =left) + (|> (finger.branch (set@ #finger.node =left fingers) + (set@ #finger.node right fingers)) + (get@ #finger.node) + #.Some)) + (case (recur right) + #.None + (#.Some left) + + (#.Some =right) + (|> (finger.branch (set@ #finger.node left fingers) + (set@ #finger.node =right fingers)) + (get@ #finger.node) + #.Some)) + )))] + (wrap (set@ #finger.node node' fingers)))) + +(def: #export (push priority value queue) + (All [a] (-> Priority a (Queue a) (Queue a))) + (let [addition {#finger.monoid number.Max@Monoid + #finger.node (#finger.Leaf priority value)}] + (case queue + #.None + (#.Some addition) + + (#.Some fingers) + (#.Some (finger.branch fingers addition))))) diff --git a/stdlib/source/lux/data/collection/row.lux b/stdlib/source/lux/data/collection/row.lux new file mode 100644 index 000000000..ca38f4961 --- /dev/null +++ b/stdlib/source/lux/data/collection/row.lux @@ -0,0 +1,437 @@ +(.module: + lux + (lux (control [functor #+ Functor] + [apply #+ Apply] + [monad #+ do Monad] + [equivalence #+ Equivalence] + monoid + fold + ["p" parser]) + (data [maybe] + (collection [list "list/" Fold Functor Monoid] + [array "array/" Functor Fold]) + [bit] + [product]) + [macro #+ with-gensyms] + (macro [code] + ["s" syntax #+ syntax: Syntax]) + )) + +## [Utils] +(type: (Node a) + (#Base (Array a)) + (#Hierarchy (Array (Node a)))) + +(type: (Base a) (Array a)) +(type: (Hierarchy a) (Array (Node a))) + +(type: Level Nat) + +(type: Index Nat) + +(def: branching-exponent + Nat + +5) + +(def: root-level + Level + +0) + +(do-template [ ] + [(def: + (-> Level Level) + ( branching-exponent))] + + [level-up n/+] + [level-down n/-] + ) + +(def: full-node-size + Nat + (bit.left-shift branching-exponent +1)) + +(def: branch-idx-mask + Nat + (dec full-node-size)) + +(def: branch-idx + (-> Index Index) + (bit.and branch-idx-mask)) + +(def: (new-hierarchy _) + (All [a] (-> Any (Hierarchy a))) + (array.new full-node-size)) + +(def: (tail-off vec-size) + (-> Nat Nat) + (if (n/< full-node-size vec-size) + +0 + (|> (dec vec-size) + (bit.logical-right-shift branching-exponent) + (bit.left-shift branching-exponent)))) + +(def: (new-path level tail) + (All [a] (-> Level (Base a) (Node a))) + (if (n/= +0 level) + (#Base tail) + (|> (new-hierarchy []) + (array.write +0 (new-path (level-down level) tail)) + #Hierarchy))) + +(def: (new-tail singleton) + (All [a] (-> a (Base a))) + (|> (array.new +1) + (array.write +0 singleton))) + +(def: (push-tail size level tail parent) + (All [a] (-> Nat Level (Base a) (Hierarchy a) (Hierarchy a))) + (let [sub-idx (branch-idx (bit.logical-right-shift level (dec size))) + ## If we're currently on a bottom node + sub-node (if (n/= branching-exponent level) + ## Just add the tail to it + (#Base tail) + ## Otherwise, check whether there's a vacant spot + (case (array.read sub-idx parent) + ## If so, set the path to the tail + #.None + (new-path (level-down level) tail) + ## If not, push the tail onto the sub-node. + (#.Some (#Hierarchy sub-node)) + (#Hierarchy (push-tail size (level-down level) tail sub-node)) + + _ + (undefined)) + )] + (|> (array.clone parent) + (array.write sub-idx sub-node)))) + +(def: (expand-tail val tail) + (All [a] (-> a (Base a) (Base a))) + (let [tail-size (array.size tail)] + (|> (array.new (inc tail-size)) + (array.copy tail-size +0 tail +0) + (array.write tail-size val)))) + +(def: (put' level idx val hierarchy) + (All [a] (-> Level Index a (Hierarchy a) (Hierarchy a))) + (let [sub-idx (branch-idx (bit.logical-right-shift level idx))] + (case (array.read sub-idx hierarchy) + (#.Some (#Hierarchy sub-node)) + (|> (array.clone hierarchy) + (array.write sub-idx (#Hierarchy (put' (level-down level) idx val sub-node)))) + + (^multi (#.Some (#Base base)) + (n/= +0 (level-down level))) + (|> (array.clone hierarchy) + (array.write sub-idx (|> (array.clone base) + (array.write (branch-idx idx) val) + #Base))) + + _ + (undefined)))) + +(def: (pop-tail size level hierarchy) + (All [a] (-> Nat Level (Hierarchy a) (Maybe (Hierarchy a)))) + (let [sub-idx (branch-idx (bit.logical-right-shift level (n/- +2 size)))] + (cond (n/= +0 sub-idx) + #.None + + (n/> branching-exponent level) + (do maybe.Monad + [base|hierarchy (array.read sub-idx hierarchy) + sub (case base|hierarchy + (#Hierarchy sub) + (pop-tail size (level-down level) sub) + + (#Base _) + (undefined))] + (|> (array.clone hierarchy) + (array.write sub-idx (#Hierarchy sub)) + #.Some)) + + ## Else... + (|> (array.clone hierarchy) + (array.delete sub-idx) + #.Some) + ))) + +(def: (to-list' node) + (All [a] (-> (Node a) (List a))) + (case node + (#Base base) + (array.to-list base) + + (#Hierarchy hierarchy) + (|> hierarchy + array.to-list + list.reverse + (list/fold (function (_ sub acc) (list/compose (to-list' sub) acc)) + #.Nil)))) + +## [Types] +(type: #export (Row a) + {#level Level + #size Nat + #root (Hierarchy a) + #tail (Base a)}) + +## [Exports] +(def: #export empty + Row + {#level (level-up root-level) + #size +0 + #root (array.new full-node-size) + #tail (array.new +0)}) + +(def: #export (size row) + (All [a] (-> (Row a) Nat)) + (get@ #size row)) + +(def: #export (add val vec) + (All [a] (-> a (Row a) (Row a))) + ## Check if there is room in the tail. + (let [vec-size (get@ #size vec)] + (if (|> vec-size (n/- (tail-off vec-size)) (n/< full-node-size)) + ## If so, append to it. + (|> vec + (update@ #size inc) + (update@ #tail (expand-tail val))) + ## Otherwise, push tail into the tree + ## -------------------------------------------------------- + ## Will the root experience an overflow with this addition? + (|> (if (n/> (bit.left-shift (get@ #level vec) +1) + (bit.logical-right-shift branching-exponent vec-size)) + ## If so, a brand-new root must be established, that is + ## 1-level taller. + (|> vec + (set@ #root (|> (: (Hierarchy ($ +0)) + (new-hierarchy [])) + ## TODO: Remove version above once new-luxc becomes the standard compiler. + ## (new-hierarchy []) + (array.write +0 (#Hierarchy (get@ #root vec))) + (array.write +1 (new-path (get@ #level vec) (get@ #tail vec))))) + (update@ #level level-up)) + ## Otherwise, just push the current tail onto the root. + (|> vec + (update@ #root (push-tail vec-size (get@ #level vec) (get@ #tail vec))))) + ## Finally, update the size of the row and grow a new + ## tail with the new element as it's sole member. + (update@ #size inc) + (set@ #tail (new-tail val))) + ))) + +(def: (base-for idx vec) + (All [a] (-> Index (Row a) (Maybe (Base a)))) + (let [vec-size (get@ #size vec)] + (if (and (n/>= +0 idx) + (n/< vec-size idx)) + (if (n/>= (tail-off vec-size) idx) + (#.Some (get@ #tail vec)) + (loop [level (get@ #level vec) + hierarchy (get@ #root vec)] + (case [(n/> branching-exponent level) + (array.read (branch-idx (bit.logical-right-shift level idx)) hierarchy)] + [true (#.Some (#Hierarchy sub))] + (recur (level-down level) sub) + + [false (#.Some (#Base base))] + (#.Some base) + + [_ #.None] + #.None + + _ + (error! "Incorrect row structure.")))) + #.None))) + +(def: #export (nth idx vec) + (All [a] (-> Nat (Row a) (Maybe a))) + (do maybe.Monad + [base (base-for idx vec)] + (array.read (branch-idx idx) base))) + +(def: #export (put idx val vec) + (All [a] (-> Nat a (Row a) (Row a))) + (let [vec-size (get@ #size vec)] + (if (and (n/>= +0 idx) + (n/< vec-size idx)) + (if (n/>= (tail-off vec-size) idx) + (|> vec + ## (update@ #tail (|>> array.clone (array.write (branch-idx idx) val))) + ## TODO: Remove once new-luxc becomes the standard compiler. + (update@ #tail (: (-> (Base ($ +0)) (Base ($ +0))) + (|>> array.clone (array.write (branch-idx idx) val)))) + ) + (|> vec + (update@ #root (put' (get@ #level vec) idx val)))) + vec))) + +(def: #export (update idx f vec) + (All [a] (-> Nat (-> a a) (Row a) (Row a))) + (case (nth idx vec) + (#.Some val) + (put idx (f val) vec) + + #.None + vec)) + +(def: #export (pop vec) + (All [a] (-> (Row a) (Row a))) + (case (get@ #size vec) + +0 + empty + + +1 + empty + + vec-size + (if (|> vec-size (n/- (tail-off vec-size)) (n/> +1)) + (let [old-tail (get@ #tail vec) + new-tail-size (dec (array.size old-tail))] + (|> vec + (update@ #size dec) + (set@ #tail (|> (array.new new-tail-size) + (array.copy new-tail-size +0 old-tail +0))))) + (maybe.assume + (do maybe.Monad + [new-tail (base-for (n/- +2 vec-size) vec) + #let [[level' root'] (let [init-level (get@ #level vec)] + (loop [level init-level + root (maybe.default (new-hierarchy []) + (pop-tail vec-size init-level (get@ #root vec)))] + (if (n/> branching-exponent level) + (case [(array.read +1 root) (array.read +0 root)] + [#.None (#.Some (#Hierarchy sub-node))] + (recur (level-down level) sub-node) + + ## [#.None (#.Some (#Base _))] + ## (undefined) + + _ + [level root]) + [level root])))]] + (wrap (|> vec + (update@ #size dec) + (set@ #level level') + (set@ #root root') + (set@ #tail new-tail)))))) + )) + +(def: #export (to-list vec) + (All [a] (-> (Row a) (List a))) + (list/compose (to-list' (#Hierarchy (get@ #root vec))) + (to-list' (#Base (get@ #tail vec))))) + +(def: #export (from-list list) + (All [a] (-> (List a) (Row a))) + (list/fold add + empty + list)) + +(def: #export (member? a/Equivalence vec val) + (All [a] (-> (Equivalence a) (Row a) a Bool)) + (list.member? a/Equivalence (to-list vec) val)) + +(def: #export empty? + (All [a] (-> (Row a) Bool)) + (|>> (get@ #size) (n/= +0))) + +## [Syntax] +(syntax: #export (row {elems (p.some s.any)}) + {#.doc (doc "Row literals." + (row 10 20 30 40))} + (wrap (list (` (from-list (list (~+ elems))))))) + +## [Structures] +(structure: #export (Equivalence Equivalence) (All [a] (-> (Equivalence a) (Equivalence (Node a)))) + (def: (= v1 v2) + (case [v1 v2] + [(#Base b1) (#Base b2)] + (:: (array.Equivalence Equivalence) = b1 b2) + + [(#Hierarchy h1) (#Hierarchy h2)] + (:: (array.Equivalence (Equivalence Equivalence)) = h1 h2) + + _ + false))) + +(structure: #export (Equivalence Equivalence) (All [a] (-> (Equivalence a) (Equivalence (Row a)))) + (def: (= v1 v2) + (and (n/= (get@ #size v1) (get@ #size v2)) + (let [(^open "Node/") (Equivalence Equivalence)] + (and (Node/= (#Base (get@ #tail v1)) + (#Base (get@ #tail v2))) + (Node/= (#Hierarchy (get@ #root v1)) + (#Hierarchy (get@ #root v2)))))))) + +(structure: _ (Fold Node) + (def: (fold f init xs) + (case xs + (#Base base) + (array/fold f init base) + + (#Hierarchy hierarchy) + (array/fold (function (_ node init') (fold f init' node)) + init + hierarchy)) + )) + +(structure: #export _ (Fold Row) + (def: (fold f init xs) + (let [(^open) Fold] + (fold f + (fold f + init + (#Hierarchy (get@ #root xs))) + (#Base (get@ #tail xs)))) + )) + +(structure: #export Monoid (All [a] (Monoid (Row a))) + (def: identity empty) + (def: (compose xs ys) + (list/fold add xs (to-list ys)))) + +(structure: _ (Functor Node) + (def: (map f xs) + (case xs + (#Base base) + (#Base (array/map f base)) + + (#Hierarchy hierarchy) + (#Hierarchy (array/map (map f) hierarchy))) + )) + +(structure: #export _ (Functor Row) + (def: (map f xs) + {#level (get@ #level xs) + #size (get@ #size xs) + #root (|> xs (get@ #root) (array/map (:: Functor map f))) + #tail (|> xs (get@ #tail) (array/map f)) + })) + +(structure: #export _ (Apply Row) + (def: functor Functor) + + (def: (apply ff fa) + (let [(^open) Functor + (^open) Fold + (^open) Monoid + results (map (function (_ f) (map f fa)) + ff)] + (fold compose identity results)))) + +(structure: #export _ (Monad Row) + (def: functor Functor) + + (def: wrap (|>> row)) + + (def: join + (let [(^open) Fold + (^open) Monoid] + (fold (function (_ post pre) (compose pre post)) identity)))) + +(def: #export (reverse xs) + (All [a] (-> (Row a) (Row a))) + (let [(^open) Fold + (^open) Monoid] + (fold add identity xs))) diff --git a/stdlib/source/lux/data/collection/sequence.lux b/stdlib/source/lux/data/collection/sequence.lux new file mode 100644 index 000000000..1776855c5 --- /dev/null +++ b/stdlib/source/lux/data/collection/sequence.lux @@ -0,0 +1,146 @@ +(.module: + lux + (lux (control functor + monad + comonad + [continuation #+ pending Cont] + ["p" parser]) + [macro #+ with-gensyms] + (macro [code] + ["s" syntax #+ syntax: Syntax]) + (data (collection [list "List/" Monad]) + bool))) + +## [Types] +(type: #export (Sequence a) + {#.doc "An infinite sequence of values."} + (Cont [a (Sequence a)])) + +## [Utils] +(def: (cycle' x xs init full) + (All [a] + (-> a (List a) a (List a) (Sequence a))) + (case xs + #.Nil (pending [x (cycle' init full init full)]) + (#.Cons x' xs') (pending [x (cycle' x' xs' init full)]))) + +## [Functions] +(def: #export (iterate f x) + {#.doc "Create a sequence by applying a function to a value, and to its result, on and on..."} + (All [a] + (-> (-> a a) a (Sequence a))) + (pending [x (iterate f (f x))])) + +(def: #export (repeat x) + {#.doc "Repeat a value forever."} + (All [a] + (-> a (Sequence a))) + (pending [x (repeat x)])) + +(def: #export (cycle xs) + {#.doc "Go over the elements of a list forever. + + The list should not be empty."} + (All [a] + (-> (List a) (Maybe (Sequence a)))) + (case xs + #.Nil #.None + (#.Cons x xs') (#.Some (cycle' x xs' x xs')))) + +(do-template [ ] + [(def: #export ( s) + (All [a] (-> (Sequence a) )) + (let [[h t] (continuation.run s)] + ))] + + [head a h] + [tail (Sequence a) t]) + +(def: #export (nth idx s) + (All [a] (-> Nat (Sequence a) a)) + (let [[h t] (continuation.run s)] + (if (n/> +0 idx) + (nth (dec idx) t) + h))) + +(do-template [ ] + [(def: #export ( pred xs) + (All [a] + (-> (Sequence a) (List a))) + (let [[x xs'] (continuation.run xs)] + (if + (list& x ( xs')) + (list)))) + + (def: #export ( pred xs) + (All [a] + (-> (Sequence a) (Sequence a))) + (let [[x xs'] (continuation.run xs)] + (if + ( xs') + xs))) + + (def: #export ( pred xs) + (All [a] + (-> (Sequence a) [(List a) (Sequence a)])) + (let [[x xs'] (continuation.run xs)] + (if + (let [[tail next] ( xs')] + [(#.Cons [x tail]) next]) + [(list) xs])))] + + [take-while drop-while split-while (-> a Bool) (pred x) pred] + [take drop split Nat (n/> +0 pred) (dec pred)] + ) + +(def: #export (unfold step init) + {#.doc "A stateful way of infinitely calculating the values of a sequence."} + (All [a b] + (-> (-> a [a b]) a (Sequence b))) + (let [[next x] (step init)] + (pending [x (unfold step next)]))) + +(def: #export (filter p xs) + (All [a] (-> (-> a Bool) (Sequence a) (Sequence a))) + (let [[x xs'] (continuation.run xs)] + (if (p x) + (pending [x (filter p xs')]) + (filter p xs')))) + +(def: #export (partition p xs) + {#.doc "Split a sequence in two based on a predicate. + + The left side contains all entries for which the predicate is true. + + The right side contains all entries for which the predicate is false."} + (All [a] (-> (-> a Bool) (Sequence a) [(Sequence a) (Sequence a)])) + [(filter p xs) (filter (complement p) xs)]) + +## [Structures] +(structure: #export _ (Functor Sequence) + (def: (map f fa) + (let [[h t] (continuation.run fa)] + (pending [(f h) (map f t)])))) + +(structure: #export _ (CoMonad Sequence) + (def: functor Functor) + (def: unwrap head) + (def: (split wa) + (let [[head tail] (continuation.run wa)] + (pending [wa (split tail)])))) + +## [Pattern-matching] +(syntax: #export (^sequence& {patterns (s.form (p.many s.any))} + body + {branches (p.some s.any)}) + {#.doc (doc "Allows destructuring of sequences in pattern-matching expressions." + "Caveat emptor: Only use it for destructuring, and not for testing values within the sequences." + (let [(^sequence& x y z _tail) (some-sequence-func 1 2 3)] + (func x y z)))} + (with-gensyms [g!sequence] + (let [body+ (` (let [(~+ (List/join (List/map (function (_ pattern) + (list (` [(~ pattern) (~ g!sequence)]) + (` ((~! continuation.run) (~ g!sequence))))) + patterns)))] + (~ body)))] + (wrap (list& g!sequence body+ branches))))) diff --git a/stdlib/source/lux/data/collection/set.lux b/stdlib/source/lux/data/collection/set.lux new file mode 100644 index 000000000..10b7600ca --- /dev/null +++ b/stdlib/source/lux/data/collection/set.lux @@ -0,0 +1,81 @@ +(.module: + lux + (lux (control [equivalence #+ Equivalence] + [hash #+ Hash]) + (data (collection ["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/collection/set/ordered.lux b/stdlib/source/lux/data/collection/set/ordered.lux new file mode 100644 index 000000000..f947d0b11 --- /dev/null +++ b/stdlib/source/lux/data/collection/set/ordered.lux @@ -0,0 +1,86 @@ +(.module: + lux + (lux (control [equivalence #+ Equivalence] + [order #+ Order]) + (data (collection [list "list/" Fold] + (dictionary ["//" ordered]))) + (type abstract))) + +(abstract: #export (Set a) + {} + + (//.Dictionary a a) + + (def: #export new + (All [a] (-> (Order a) (Set a))) + (|>> //.new :abstraction)) + + (def: #export (member? set elem) + (All [a] (-> (Set a) a Bool)) + (|> set :representation (//.contains? elem))) + + (do-template [ ] + [(def: #export + (All [a] (-> (Set a) (Maybe a))) + (|>> :representation ))] + + [min //.min] + [max //.max] + ) + + (do-template [ ] + [(def: #export + (-> (Set Any) Nat) + (|>> :representation ))] + + [size //.size] + [depth //.depth] + ) + + (def: #export (add elem set) + (All [a] (-> a (Set a) (Set a))) + (|> set :representation (//.put elem elem) :abstraction)) + + (def: #export (remove elem set) + (All [a] (-> a (Set a) (Set a))) + (|> set :representation (//.remove elem) :abstraction)) + + (def: #export to-list + (All [a] (-> (Set a) (List a))) + (|>> :representation //.keys)) + + (def: #export (from-list Order list) + (All [a] (-> (Order a) (List a) (Set a))) + (list/fold add (new Order) list)) + + (def: #export (union left right) + (All [a] (-> (Set a) (Set a) (Set a))) + (list/fold ..add right (..to-list left))) + + (def: #export (intersection left right) + (All [a] (-> (Set a) (Set a) (Set a))) + (|> (..to-list right) + (list.filter (..member? left)) + (..from-list (get@ #//.order (:representation right))))) + + (def: #export (difference param subject) + (All [a] (-> (Set a) (Set a) (Set a))) + (|> (..to-list subject) + (list.filter (|>> (..member? param) not)) + (..from-list (get@ #//.order (:representation subject))))) + + (structure: #export Equivalence (All [a] (Equivalence (Set a))) + (def: (= reference sample) + (:: (list.Equivalence (:: (:representation sample) eq)) + = (..to-list reference) (..to-list sample)))) + ) + +(def: #export (sub? super sub) + (All [a] (-> (Set a) (Set a) Bool)) + (|> sub + ..to-list + (list.every? (..member? super)))) + +(def: #export (super? sub super) + (All [a] (-> (Set a) (Set a) Bool)) + (sub? super sub)) diff --git a/stdlib/source/lux/data/collection/stack.lux b/stdlib/source/lux/data/collection/stack.lux new file mode 100644 index 000000000..c0e1af182 --- /dev/null +++ b/stdlib/source/lux/data/collection/stack.lux @@ -0,0 +1,42 @@ +(.module: + lux + (lux (data (collection [list])))) + +## [Types] +(type: #export (Stack a) + (List a)) + +## [Values] +(def: #export empty + Stack + (list)) + +(def: #export (size stack) + (All [a] (-> (Stack a) Nat)) + (list.size stack)) + +(def: #export (empty? stack) + (All [a] (-> (Stack a) Bool)) + (list.empty? stack)) + +(def: #export (peek stack) + (All [a] (-> (Stack a) (Maybe a))) + (case stack + #.Nil + #.None + + (#.Cons value _) + (#.Some value))) + +(def: #export (pop stack) + (All [a] (-> (Stack a) (Stack a))) + (case stack + #.Nil + #.Nil + + (#.Cons _ stack') + stack')) + +(def: #export (push value stack) + (All [a] (-> a (Stack a) (Stack a))) + (#.Cons value stack)) diff --git a/stdlib/source/lux/data/collection/tree/finger.lux b/stdlib/source/lux/data/collection/tree/finger.lux new file mode 100644 index 000000000..ea1ff0eee --- /dev/null +++ b/stdlib/source/lux/data/collection/tree/finger.lux @@ -0,0 +1,61 @@ +(.module: + lux + (lux (control ["m" monoid]) + (data text/format))) + +(type: #export (Node m a) + (#Leaf m a) + (#Branch m (Node m a) (Node m a))) + +(type: #export (Tree m a) + {#monoid (m.Monoid m) + #node (Node m a)}) + +(def: #export (tag tree) + (All [m a] (-> (Tree m a) m)) + (case (get@ #node tree) + (^or (#Leaf tag _) (#Branch tag _ _)) + tag)) + +(def: #export (value tree) + (All [m a] (-> (Tree m a) a)) + (case (get@ #node tree) + (#Leaf tag value) + value + + (#Branch tag left right) + (value (set@ #node left tree)))) + +(def: #export (branch left right) + (All [m a] (-> (Tree m a) (Tree m a) (Tree m a))) + (let [Monoid (get@ #monoid right)] + {#monoid Monoid + #node (#Branch (:: Monoid compose (tag left) (tag right)) + (get@ #node left) + (get@ #node right))})) + +(def: #export (search pred tree) + (All [m a] (-> (-> m Bool) (Tree m a) (Maybe a))) + (let [tag/compose (get@ [#monoid #m.compose] tree)] + (if (pred (tag tree)) + (loop [_tag (get@ [#monoid #m.identity] tree) + _node (get@ #node tree)] + (case _node + (#Leaf _ value) + (#.Some value) + + (#Branch _ left right) + (let [shifted-tag (tag/compose _tag (tag (set@ #node left tree)))] + (if (pred shifted-tag) + (recur _tag left) + (recur shifted-tag right))))) + #.None))) + +(def: #export (found? pred tree) + (All [m a] (-> (-> m Bool) (Tree m a) Bool)) + (case (search pred tree) + (#.Some _) + true + + #.None + false)) diff --git a/stdlib/source/lux/data/collection/tree/rose.lux b/stdlib/source/lux/data/collection/tree/rose.lux new file mode 100644 index 000000000..9eae689d3 --- /dev/null +++ b/stdlib/source/lux/data/collection/tree/rose.lux @@ -0,0 +1,73 @@ +(.module: + lux + (lux (control functor + [monad #+ do Monad] + equivalence + ["p" parser] + fold) + (data (collection [list "L/" Monad Fold])) + [macro] + (macro [code] + ["s" syntax #+ syntax: Syntax]))) + +## [Types] +(type: #export (Tree a) + {#value a + #children (List (Tree a))}) + +## [Values] +(def: #export (flatten tree) + (All [a] (-> (Tree a) (List a))) + (#.Cons (get@ #value tree) + (L/join (L/map flatten (get@ #children tree))))) + +(def: #export (leaf value) + (All [a] (-> a (Tree a))) + {#value value + #children (list)}) + +(def: #export (branch value children) + (All [a] (-> a (List (Tree a)) (Tree a))) + {#value value + #children children}) + +## [Syntax] +(type: #rec Tree-Code + [Code (List Tree-Code)]) + +(def: tree^ + (Syntax Tree-Code) + (|> (|>> p.some s.record (p.seq s.any)) + p.rec + p.some + s.record + (p.seq s.any) + s.tuple)) + +(syntax: #export (tree {root tree^}) + {#.doc (doc "Tree literals." + (tree Int [10 {20 {} + 30 {} + 40 {}}]))} + (wrap (list (` (~ (loop [[value children] root] + (` {#value (~ value) + #children (list (~+ (L/map recur children)))}))))))) + +## [Structs] +(structure: #export (Equivalence Equivalence) (All [a] (-> (Equivalence a) (Equivalence (Tree a)))) + (def: (= tx ty) + (and (:: Equivalence = (get@ #value tx) (get@ #value ty)) + (:: (list.Equivalence (Equivalence Equivalence)) = (get@ #children tx) (get@ #children ty))))) + +(structure: #export _ (Functor Tree) + (def: (map f fa) + {#value (f (get@ #value fa)) + #children (L/map (map f) + (get@ #children fa))})) + +(structure: #export _ (Fold Tree) + (def: (fold f init tree) + (L/fold (function (_ tree' init') (fold f init' tree')) + (f (get@ #value tree) + init) + (get@ #children tree)))) diff --git a/stdlib/source/lux/data/collection/tree/rose/parser.lux b/stdlib/source/lux/data/collection/tree/rose/parser.lux new file mode 100644 index 000000000..3e3535649 --- /dev/null +++ b/stdlib/source/lux/data/collection/tree/rose/parser.lux @@ -0,0 +1,50 @@ +(.module: + lux + (lux (control ["p" parser] + ["ex" exception #+ exception:]) + (data ["E" error])) + [// #+ Tree] + (// [zipper #+ Zipper])) + +(type: #export (Parser t a) + (p.Parser (Zipper t) a)) + +(def: #export (run-zipper zipper parser) + (All [t a] (-> (Zipper t) (Parser t a) (E.Error a))) + (case (p.run zipper parser) + (#E.Success [zipper output]) + (#E.Success output) + + (#E.Error error) + (#E.Error error))) + +(def: #export (run tree parser) + (All [t a] (-> (Tree t) (Parser t a) (E.Error a))) + (run-zipper (zipper.zip tree) parser)) + +(def: #export value + (All [t] (Parser t t)) + (function (_ zipper) + (#E.Success [zipper (zipper.value zipper)]))) + +(exception: #export cannot-move-further) + +(do-template [ ] + [(def: #export + (All [t] (Parser t [])) + (function (_ zipper) + (let [next ( zipper)] + (if (is? zipper next) + (ex.throw cannot-move-further []) + (#E.Success [next []])))))] + + [up zipper.up] + [down zipper.down] + [left zipper.left] + [right zipper.right] + [root zipper.root] + [rightmost zipper.rightmost] + [leftmost zipper.leftmost] + [next zipper.next] + [prev zipper.prev] + ) diff --git a/stdlib/source/lux/data/collection/tree/rose/zipper.lux b/stdlib/source/lux/data/collection/tree/rose/zipper.lux new file mode 100644 index 000000000..4a85c68c6 --- /dev/null +++ b/stdlib/source/lux/data/collection/tree/rose/zipper.lux @@ -0,0 +1,235 @@ +(.module: + lux + (lux (control functor + comonad) + (data (collection [list "L/" Monad Fold Monoid] + (tree [rose #+ Tree "T/" Functor]) + [stack #+ Stack]) + [maybe "M/" Monad]) + [macro] + (macro [code] + ["s" syntax #+ syntax: Syntax]))) + +## Adapted from the clojure.zip namespace in the Clojure standard library. + +## [Types] +(type: #export (Zipper a) + {#.doc "Tree zippers, for easy navigation and editing over trees."} + {#parent (Maybe (Zipper a)) + #lefts (Stack (Tree a)) + #rights (Stack (Tree a)) + #node (Tree a)}) + +## [Values] +(def: #export (zip tree) + (All [a] (-> (Tree a) (Zipper a))) + {#parent #.None + #lefts stack.empty + #rights stack.empty + #node tree}) + +(def: #export (unzip zipper) + (All [a] (-> (Zipper a) (Tree a))) + (get@ #node zipper)) + +(def: #export (value zipper) + (All [a] (-> (Zipper a) a)) + (|> zipper (get@ [#node #rose.value]))) + +(def: #export (children zipper) + (All [a] (-> (Zipper a) (List (Tree a)))) + (|> zipper (get@ [#node #rose.children]))) + +(def: #export (branch? zipper) + (All [a] (-> (Zipper a) Bool)) + (|> zipper children list.empty? not)) + +(def: #export (leaf? zipper) + (All [a] (-> (Zipper a) Bool)) + (|> zipper branch? not)) + +(def: #export (end? zipper) + (All [a] (-> (Zipper a) Bool)) + (and (list.empty? (get@ #rights zipper)) + (list.empty? (children zipper)))) + +(def: #export (root? zipper) + (All [a] (-> (Zipper a) Bool)) + (case (get@ #parent zipper) + #.None + true + + _ + false)) + +(def: #export (down zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (children zipper) + #.Nil + zipper + + (#.Cons chead ctail) + {#parent (#.Some zipper) + #lefts stack.empty + #rights ctail + #node chead})) + +(def: #export (up zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (get@ #parent zipper) + #.None + zipper + + (#.Some parent) + (|> parent + ## TODO: Remove once new-luxc becomes the standard compiler. + (update@ #node (: (-> (Tree ($ +0)) (Tree ($ +0))) + (function (_ node) + (set@ #rose.children (L/compose (list.reverse (get@ #lefts zipper)) + (#.Cons (get@ #node zipper) + (get@ #rights zipper))) + node)))) + ## (update@ #node (function (_ node) + ## (set@ #rose.children (L/compose (list.reverse (get@ #lefts zipper)) + ## (#.Cons (get@ #node zipper) + ## (get@ #rights zipper))) + ## node))) + ))) + +(def: #export (root zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (loop [zipper zipper] + (case (get@ #parent zipper) + #.None zipper + (#.Some _) (recur (up zipper))))) + +(do-template [ ] + [(def: #export ( zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (get@ zipper) + #.Nil + zipper + + (#.Cons next side') + (|> zipper + (update@ (function (_ op-side) + (#.Cons (get@ #node zipper) op-side))) + (set@ side') + (set@ #node next)))) + + (def: #export ( zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (L/fold (function (_ _) ) zipper (get@ zipper)))] + + [right rightmost #rights #lefts] + [left leftmost #lefts #rights] + ) + +(do-template [ ] + [(def: #export ( zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (get@ zipper) + #.Nil + ( zipper) + + _ + ( zipper)))] + + [next #rights right down] + [prev #lefts left up] + ) + +(def: #export (set value zipper) + (All [a] (-> a (Zipper a) (Zipper a))) + (set@ [#node #rose.value] value zipper)) + +(def: #export (update f zipper) + (All [a] (-> (-> a a) (Zipper a) (Zipper a))) + (update@ [#node #rose.value] f zipper)) + +(def: #export (prepend-child value zipper) + (All [a] (-> a (Zipper a) (Zipper a))) + (update@ [#node #rose.children] + (function (_ children) + ## TODO: Remove once new-luxc becomes the standard compiler. + (list& (: (Tree ($ +0)) + (rose.tree [value {}])) + children) + ## (list& (rose.tree [value {}]) + ## children) + ) + zipper)) + +(def: #export (append-child value zipper) + (All [a] (-> a (Zipper a) (Zipper a))) + (update@ [#node #rose.children] + (function (_ children) + (L/compose children + ## TODO: Remove once new-luxc becomes the standard compiler. + (list (: (Tree ($ +0)) + (rose.tree [value {}]))) + ## (list (rose.tree [value {}])) + )) + zipper)) + +(def: #export (remove zipper) + (All [a] (-> (Zipper a) (Maybe (Zipper a)))) + (case (get@ #lefts zipper) + #.Nil + (case (get@ #parent zipper) + #.None + #.None + + (#.Some next) + (#.Some (|> next + (update@ [#node #rose.children] (|>> list.tail (maybe.default (list))))))) + + (#.Cons next side) + (#.Some (|> zipper + (set@ #lefts side) + (set@ #node next))))) + +(do-template [ ] + [(def: #export ( value zipper) + (All [a] (-> a (Zipper a) (Maybe (Zipper a)))) + (case (get@ #parent zipper) + #.None + #.None + + _ + (#.Some (|> zipper + (update@ (function (_ side) + ## TODO: Remove once new-luxc becomes the standard compiler. + (#.Cons (: (Tree ($ +0)) + (rose.tree [value {}])) + side) + ## (#.Cons (rose.tree [value {}]) + ## side) + ))))))] + + [insert-left #lefts] + [insert-right #rights] + ) + +(structure: #export _ (Functor Zipper) + (def: (map f fa) + {#parent (|> fa (get@ #parent) (M/map (map f))) + #lefts (|> fa (get@ #lefts) (L/map (T/map f))) + #rights (|> fa (get@ #rights) (L/map (T/map f))) + #node (T/map f (get@ #node fa))})) + +## TODO: Add again once new-luxc becomes the standard compiler. +## (structure: #export _ (CoMonad Zipper) +## (def: functor Functor) + +## (def: unwrap (get@ [#node #rose.value])) + +## (def: (split wa) +## (let [tree-splitter (function (tree-splitter tree) +## {#rose.value (zip tree) +## #rose.children (L/map tree-splitter +## (get@ #rose.children tree))})] +## {#parent (|> wa (get@ #parent) (M/map split)) +## #lefts (|> wa (get@ #lefts) (L/map tree-splitter)) +## #rights (|> wa (get@ #rights) (L/map tree-splitter)) +## #node (|> fa (get@ #node) tree-splitter)}))) diff --git a/stdlib/source/lux/data/color.lux b/stdlib/source/lux/data/color.lux index 7a23be703..bf11c378a 100644 --- a/stdlib/source/lux/data/color.lux +++ b/stdlib/source/lux/data/color.lux @@ -1,7 +1,7 @@ (.module: lux (lux (control ["eq" equivalence]) - (data (coll [list "L/" Functor])) + (data (collection [list "L/" Functor])) [math] (type abstract))) diff --git a/stdlib/source/lux/data/format/context.lux b/stdlib/source/lux/data/format/context.lux index f9874f6d2..0a4d8bd92 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" dictionary #+ Dictionary])))) + (collection ["dict" dictionary #+ Dictionary])))) (exception: #export (unknown-property {property Text}) property) diff --git a/stdlib/source/lux/data/format/css.lux b/stdlib/source/lux/data/format/css.lux index d76242045..685bd9d6d 100644 --- a/stdlib/source/lux/data/format/css.lux +++ b/stdlib/source/lux/data/format/css.lux @@ -4,7 +4,7 @@ [number] [text] text/format - (coll [list "L/" Functor Monoid])))) + (collection [list "L/" Functor Monoid])))) (type: #export Selector Text) diff --git a/stdlib/source/lux/data/format/html.lux b/stdlib/source/lux/data/format/html.lux index ef2e0abf0..891800e8a 100644 --- a/stdlib/source/lux/data/format/html.lux +++ b/stdlib/source/lux/data/format/html.lux @@ -2,7 +2,7 @@ [lux #- comment] (lux (data [text] text/format - (coll [list "L/" Functor])))) + (collection [list "L/" Functor])))) (type: #export Attributes {#.doc "Attributes for an HTML tag."} diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux index c3069c939..392e16c3b 100644 --- a/stdlib/source/lux/data/format/json.lux +++ b/stdlib/source/lux/data/format/json.lux @@ -14,9 +14,9 @@ ["e" error] [sum] [product] - (coll [list "list/" Fold Monad] - [row #+ Row row "row/" Monad] - ["dict" dictionary #+ Dictionary])) + (collection [list "list/" Fold Monad] + [row #+ Row row "row/" Monad] + ["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 dd389c55b..a966b1bfa 100644 --- a/stdlib/source/lux/data/format/xml.lux +++ b/stdlib/source/lux/data/format/xml.lux @@ -12,8 +12,8 @@ [product] [maybe "m/" Monad] [ident "ident/" Equivalence Codec] - (coll [list "list/" Monad] - ["d" dictionary])))) + (collection [list "list/" Monad] + ["d" dictionary])))) (type: #export Tag Ident) (type: #export Attrs (d.Dictionary Ident Text)) diff --git a/stdlib/source/lux/data/number/complex.lux b/stdlib/source/lux/data/number/complex.lux index 91a10fd59..3c92e181d 100644 --- a/stdlib/source/lux/data/number/complex.lux +++ b/stdlib/source/lux/data/number/complex.lux @@ -9,7 +9,7 @@ (data [number "frac/" Number "f/" Codec] [text "text/" Monoid] [maybe] - (coll [list "L/" Monad])) + (collection [list "L/" Monad])) [macro] (macro [code] ["s" syntax #+ syntax: Syntax]))) diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux index d09b713c9..1e1a660d7 100644 --- a/stdlib/source/lux/data/text.lux +++ b/stdlib/source/lux/data/text.lux @@ -6,7 +6,7 @@ [monad #+ do Monad] [codec #+ Codec] hash) - (data (coll [list]) + (data (collection [list]) [maybe]))) ## [Functions] diff --git a/stdlib/source/lux/data/text/buffer.lux b/stdlib/source/lux/data/text/buffer.lux index 423a1ba3c..0641ba215 100644 --- a/stdlib/source/lux/data/text/buffer.lux +++ b/stdlib/source/lux/data/text/buffer.lux @@ -2,7 +2,7 @@ lux (lux (data [product] text/format - (coll [row #+ Row "row/" Fold])) + (collection [row #+ Row "row/" Fold])) (lang ["_" host]) (type abstract) [host #+ import:]) diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux index 847e4ac4f..26fca323d 100644 --- a/stdlib/source/lux/data/text/format.lux +++ b/stdlib/source/lux/data/text/format.lux @@ -6,7 +6,7 @@ [number] [text] [ident] - (coll [list "list/" Monad]) + (collection [list "list/" Monad]) (format [xml] [json])) (time [instant] diff --git a/stdlib/source/lux/data/text/lexer.lux b/stdlib/source/lux/data/text/lexer.lux index 84495a6a8..9f8bbb664 100644 --- a/stdlib/source/lux/data/text/lexer.lux +++ b/stdlib/source/lux/data/text/lexer.lux @@ -6,7 +6,7 @@ [product] [maybe] ["e" error] - (coll [list])) + (collection [list])) (macro [code]))) (type: Offset Nat) diff --git a/stdlib/source/lux/data/text/regex.lux b/stdlib/source/lux/data/text/regex.lux index cf0d69475..f0e471ef4 100644 --- a/stdlib/source/lux/data/text/regex.lux +++ b/stdlib/source/lux/data/text/regex.lux @@ -9,7 +9,7 @@ [product] ["e" error] [maybe] - (coll [list "list/" Fold Monad])) + (collection [list "list/" Fold Monad])) [macro #+ with-gensyms] (macro [code] ["s" syntax #+ syntax:]))) diff --git a/stdlib/source/lux/data/text/unicode.lux b/stdlib/source/lux/data/text/unicode.lux index e00f23e84..8a88e1184 100644 --- a/stdlib/source/lux/data/text/unicode.lux +++ b/stdlib/source/lux/data/text/unicode.lux @@ -3,8 +3,8 @@ (lux (control [interval #+ Interval] [monoid #+ Monoid]) (data [number #+ hex "nat/" Interval] - (coll [list] - (tree [finger #+ Tree]))) + (collection [list] + (tree [finger #+ Tree]))) (type abstract))) (type: #export Char Nat) diff --git a/stdlib/source/lux/host.js.lux b/stdlib/source/lux/host.js.lux index 876ab0c38..a0d1d0c3f 100644 --- a/stdlib/source/lux/host.js.lux +++ b/stdlib/source/lux/host.js.lux @@ -2,7 +2,7 @@ lux (lux (control monad ["p" parser]) - (data (coll [list #* "L/" Fold])) + (data (collection [list #* "L/" Fold])) [macro #+ with-gensyms] (macro [code] ["s" syntax #+ syntax: Syntax]) diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux index 108ab2db9..43a78472b 100644 --- a/stdlib/source/lux/host.jvm.lux +++ b/stdlib/source/lux/host.jvm.lux @@ -5,7 +5,7 @@ ["p" parser]) [io #+ IO Monad io] function - (data (coll [list "list/" Monad Fold Monoid]) + (data (collection [list "list/" Monad Fold Monoid]) number [maybe] [product] diff --git a/stdlib/source/lux/io.lux b/stdlib/source/lux/io.lux index 7579a1463..ca9b80467 100644 --- a/stdlib/source/lux/io.lux +++ b/stdlib/source/lux/io.lux @@ -5,7 +5,7 @@ [monad #+ do Monad] ["ex" exception #+ Exception]) (data ["e" error #+ Error] - (coll [list])))) + (collection [list])))) (type: #export (IO a) {#.doc "A type that represents synchronous, effectful computations that may interact with the outside world."} diff --git a/stdlib/source/lux/lang/compiler/analysis.lux b/stdlib/source/lux/lang/compiler/analysis.lux index c9e9b8be1..87a4cbe4f 100644 --- a/stdlib/source/lux/lang/compiler/analysis.lux +++ b/stdlib/source/lux/lang/compiler/analysis.lux @@ -3,7 +3,7 @@ (lux (data [product] [error] [text "text/" Equivalence] - (coll [list "list/" Fold])) + (collection [list "list/" Fold])) [function]) [///reference #+ Register Variable Reference] [//]) diff --git a/stdlib/source/lux/lang/compiler/analysis/case.lux b/stdlib/source/lux/lang/compiler/analysis/case.lux index 233ac114a..fc1e83d4a 100644 --- a/stdlib/source/lux/lang/compiler/analysis/case.lux +++ b/stdlib/source/lux/lang/compiler/analysis/case.lux @@ -6,7 +6,7 @@ [error] [maybe] text/format - (coll [list "list/" Fold Monoid Functor])) + (collection [list "list/" Fold Monoid Functor])) [macro] (macro [code])) (//// [type] diff --git a/stdlib/source/lux/lang/compiler/analysis/case/coverage.lux b/stdlib/source/lux/lang/compiler/analysis/case/coverage.lux index c76f98091..70c9fa80f 100644 --- a/stdlib/source/lux/lang/compiler/analysis/case/coverage.lux +++ b/stdlib/source/lux/lang/compiler/analysis/case/coverage.lux @@ -8,8 +8,8 @@ ["e" error "error/" Monad] [maybe] text/format - (coll [list "list/" Fold] - ["dict" dictionary #+ Dictionary]))) + (collection [list "list/" Fold] + ["dict" dictionary #+ Dictionary]))) [//// "operation/" Monad] [/// #+ Pattern Variant Operation]) diff --git a/stdlib/source/lux/lang/compiler/analysis/function.lux b/stdlib/source/lux/lang/compiler/analysis/function.lux index b16b18e59..f8d8b826b 100644 --- a/stdlib/source/lux/lang/compiler/analysis/function.lux +++ b/stdlib/source/lux/lang/compiler/analysis/function.lux @@ -5,7 +5,7 @@ (data [maybe] [text] text/format - (coll [list "list/" Fold Monoid Monad])) + (collection [list "list/" Fold Monoid Monad])) [macro] (macro [code]) (lang [type] diff --git a/stdlib/source/lux/lang/compiler/analysis/inference.lux b/stdlib/source/lux/lang/compiler/analysis/inference.lux index 42ab27a6c..a89ed40f8 100644 --- a/stdlib/source/lux/lang/compiler/analysis/inference.lux +++ b/stdlib/source/lux/lang/compiler/analysis/inference.lux @@ -5,7 +5,7 @@ (data [maybe] [text] text/format - (coll [list "list/" Functor])) + (collection [list "list/" Functor])) [macro]) (//// [type] (type ["tc" check])) diff --git a/stdlib/source/lux/lang/compiler/analysis/structure.lux b/stdlib/source/lux/lang/compiler/analysis/structure.lux index dd832fe47..087ffa8c5 100644 --- a/stdlib/source/lux/lang/compiler/analysis/structure.lux +++ b/stdlib/source/lux/lang/compiler/analysis/structure.lux @@ -6,8 +6,8 @@ [number] [product] [maybe] - (coll [list "list/" Functor] - ["dict" dictionary #+ Dictionary]) + (collection [list "list/" Functor] + ["dict" dictionary #+ Dictionary]) text/format) [macro] (macro [code])) diff --git a/stdlib/source/lux/lang/compiler/default/repl/type.lux b/stdlib/source/lux/lang/compiler/default/repl/type.lux index 2fc2c74b6..b78d1785c 100644 --- a/stdlib/source/lux/lang/compiler/default/repl/type.lux +++ b/stdlib/source/lux/lang/compiler/default/repl/type.lux @@ -8,7 +8,7 @@ text/format (format [xml #+ XML] [json #+ JSON]) - (coll [list])) + (collection [list])) (time [instant #+ Instant] [duration #+ Duration] [date #+ Date]) diff --git a/stdlib/source/lux/lang/compiler/extension.lux b/stdlib/source/lux/lang/compiler/extension.lux index ce01c16ae..e23e9b511 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 ["dict" dictionary #+ Dictionary]))) + (collection ["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 b770e2f7e..9f48c79b4 100644 --- a/stdlib/source/lux/lang/compiler/extension/analysis.lux +++ b/stdlib/source/lux/lang/compiler/extension/analysis.lux @@ -1,8 +1,8 @@ (.module: lux (lux (data [text] - (coll [list "list/" Functor] - ["dict" dictionary #+ Dictionary]))) + (collection [list "list/" Functor] + ["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 1afbc13aa..62a01cee7 100644 --- a/stdlib/source/lux/lang/compiler/extension/analysis/common.lux +++ b/stdlib/source/lux/lang/compiler/extension/analysis/common.lux @@ -6,9 +6,9 @@ (concurrency [atom #+ Atom]) (data [text] text/format - (coll [list "list/" Functor] - [array] - ["dict" dictionary #+ Dictionary])) + (collection [list "list/" Functor] + [array] + ["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 4316c4a53..265836e66 100644 --- a/stdlib/source/lux/lang/compiler/extension/analysis/host.jvm.lux +++ b/stdlib/source/lux/lang/compiler/extension/analysis/host.jvm.lux @@ -10,9 +10,9 @@ [text "text/" Equivalence] (text format ["l" lexer]) - (coll [list "list/" Fold Functor Monoid] - [array] - ["dict" dictionary #+ Dictionary])) + (collection [list "list/" Fold Functor Monoid] + [array] + ["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 e4f918ef3..4e011d2ca 100644 --- a/stdlib/source/lux/lang/compiler/extension/bundle.lux +++ b/stdlib/source/lux/lang/compiler/extension/bundle.lux @@ -4,8 +4,8 @@ ["ex" exception #+ exception:]) (data [text] text/format - (coll [list "list/" Functor] - ["dict" dictionary #+ Dictionary]))) + (collection [list "list/" Functor] + ["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 d06a2b144..48073d012 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 ["dict" dictionary #+ Dictionary]))) + (collection ["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 367288981..ae05fd61c 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 ["dict" dictionary #+ Dictionary]))) + (collection ["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 4a86055e8..53c3baa65 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 ["dict" dictionary #+ Dictionary])) + (collection ["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 54919feb8..7c6b558db 100644 --- a/stdlib/source/lux/lang/compiler/meta/cache.lux +++ b/stdlib/source/lux/lang/compiler/meta/cache.lux @@ -10,9 +10,9 @@ (format [binary #+ Binary]) [text] text/format - (coll [list "list/" Functor Fold] - ["dict" dictionary #+ Dictionary] - [set #+ Set])) + (collection [list "list/" Functor Fold] + ["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 843644887..f489f04ed 100644 --- a/stdlib/source/lux/lang/compiler/meta/cache/dependency.lux +++ b/stdlib/source/lux/lang/compiler/meta/cache/dependency.lux @@ -1,8 +1,8 @@ (.module: [lux #- Module] (lux (data [text] - (coll [list "list/" Functor Fold] - ["dict" dictionary #+ Dictionary]))) + (collection [list "list/" Functor Fold] + ["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 46f376adf..36db1fe5e 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 ["dict" dictionary #+ Dictionary]))) + (collection ["dict" dictionary #+ Dictionary]))) [///reference #+ Register Variable Reference] [// #+ Operation Compiler] [//analysis #+ Environment Arity Analysis]) diff --git a/stdlib/source/lux/lang/compiler/synthesis/case.lux b/stdlib/source/lux/lang/compiler/synthesis/case.lux index bdf06f05f..5fca60a99 100644 --- a/stdlib/source/lux/lang/compiler/synthesis/case.lux +++ b/stdlib/source/lux/lang/compiler/synthesis/case.lux @@ -8,7 +8,7 @@ [text "text/" Equivalence] text/format [number "frac/" Equivalence] - (coll [list "list/" Fold Monoid]))) + (collection [list "list/" Fold Monoid]))) [///reference] [///compiler #+ Operation "operation/" Monad] [///analysis #+ Pattern Match Analysis] diff --git a/stdlib/source/lux/lang/compiler/synthesis/expression.lux b/stdlib/source/lux/lang/compiler/synthesis/expression.lux index c9e3c577a..6db9a8fd5 100644 --- a/stdlib/source/lux/lang/compiler/synthesis/expression.lux +++ b/stdlib/source/lux/lang/compiler/synthesis/expression.lux @@ -3,8 +3,8 @@ (lux (control [monad #+ do] ["ex" exception #+ exception:]) (data [maybe] - (coll [list "list/" Functor] - ["dict" dictionary #+ Dictionary]))) + (collection [list "list/" Functor] + ["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 2d2fffbf8..ae7b5c3b3 100644 --- a/stdlib/source/lux/lang/compiler/synthesis/function.lux +++ b/stdlib/source/lux/lang/compiler/synthesis/function.lux @@ -6,8 +6,8 @@ ["ex" exception #+ exception:]) (data [maybe "maybe/" Monad] [error] - (coll [list "list/" Functor Monoid Fold] - ["dict" dictionary #+ Dictionary]))) + (collection [list "list/" Functor Monoid Fold] + ["dict" dictionary #+ Dictionary]))) [///reference #+ Variable] [///compiler #+ Operation] [///analysis #+ Environment Arity Analysis] diff --git a/stdlib/source/lux/lang/compiler/synthesis/loop.lux b/stdlib/source/lux/lang/compiler/synthesis/loop.lux index eb57eb7ad..e4722ee1f 100644 --- a/stdlib/source/lux/lang/compiler/synthesis/loop.lux +++ b/stdlib/source/lux/lang/compiler/synthesis/loop.lux @@ -3,7 +3,7 @@ (lux (control [monad #+ do] ["p" parser]) (data [maybe "maybe/" Monad] - (coll [list "list/" Functor])) + (collection [list "list/" Functor])) (macro [code] [syntax])) [///] diff --git a/stdlib/source/lux/lang/compiler/translation.lux b/stdlib/source/lux/lang/compiler/translation.lux index 1400cb446..8791c8d5e 100644 --- a/stdlib/source/lux/lang/compiler/translation.lux +++ b/stdlib/source/lux/lang/compiler/translation.lux @@ -6,8 +6,8 @@ [error #+ Error] [text] text/format - (coll [row #+ Row] - ["dict" dictionary #+ Dictionary])) + (collection [row #+ Row] + ["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 70da9d5d8..39b5bdae1 100644 --- a/stdlib/source/lux/lang/compiler/translation/scheme/case.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/case.jvm.lux @@ -5,8 +5,8 @@ (data [number] [text] text/format - (coll [list "list/" Functor Fold] - [set #+ Set]))) + (collection [list "list/" Functor Fold] + [set #+ Set]))) (///// [reference #+ Register] (host ["_" scheme #+ Expression Computation Var]) [compiler #+ "operation/" Monad] @@ -93,9 +93,9 @@ (def: (pm-catch handler) (-> Expression Computation) (_.lambda [(list $alt_error) #.None] - (_.if (|> $alt_error (_.eqv?/2 pm-error)) - handler - (_.raise/1 $alt_error)))) + (_.if (|> $alt_error (_.eqv?/2 pm-error)) + handler + (_.raise/1 $alt_error)))) (def: (pattern-matching' translate pathP) (-> Translator Path (Operation Expression)) 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 c894053d2..9fa0abc55 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 ["dict" dictionary #+ Dictionary]))) + (collection ["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 e79b11c3b..11743b076 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 @@ -7,8 +7,8 @@ [text] text/format [number #+ hex] - (coll [list "list/" Functor] - ["dict" dictionary #+ Dictionary])) + (collection [list "list/" Functor] + ["dict" dictionary #+ Dictionary])) [macro #+ with-gensyms] (macro [code] ["s" syntax #+ syntax:]) diff --git a/stdlib/source/lux/lang/compiler/translation/scheme/function.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/function.jvm.lux index 4ec601257..1ac433ec4 100644 --- a/stdlib/source/lux/lang/compiler/translation/scheme/function.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/function.jvm.lux @@ -4,7 +4,7 @@ pipe) (data [product] text/format - (coll [list "list/" Functor]))) + (collection [list "list/" Functor]))) (///// [reference #+ Register Variable] [name] (host ["_" scheme #+ Expression Computation Var]) diff --git a/stdlib/source/lux/lang/compiler/translation/scheme/loop.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/loop.jvm.lux index e9ea1c3e8..f77f7cf10 100644 --- a/stdlib/source/lux/lang/compiler/translation/scheme/loop.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/loop.jvm.lux @@ -4,7 +4,7 @@ (data [product] [text] text/format - (coll [list "list/" Functor])) + (collection [list "list/" Functor])) [macro]) (///// (host ["_" scheme #+ Computation Var]) [compiler] diff --git a/stdlib/source/lux/lang/compiler/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/runtime.jvm.lux index 7ba873999..89707cdc4 100644 --- a/stdlib/source/lux/lang/compiler/translation/scheme/runtime.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/runtime.jvm.lux @@ -4,7 +4,7 @@ [monad #+ do]) (data [number #+ hex] text/format - (coll [list "list/" Monad])) + (collection [list "list/" Monad])) [function] (macro [code] ["s" syntax #+ syntax:])) diff --git a/stdlib/source/lux/lang/host/scheme.lux b/stdlib/source/lux/lang/host/scheme.lux index adc8504bb..93d1b2017 100644 --- a/stdlib/source/lux/lang/host/scheme.lux +++ b/stdlib/source/lux/lang/host/scheme.lux @@ -4,7 +4,7 @@ (data [text] text/format [number] - (coll [list "list/" Functor Fold])) + (collection [list "list/" Functor Fold])) (type abstract))) (abstract: Global' {} Any) diff --git a/stdlib/source/lux/lang/module.lux b/stdlib/source/lux/lang/module.lux index b93b5e27b..dbb1cc0ea 100644 --- a/stdlib/source/lux/lang/module.lux +++ b/stdlib/source/lux/lang/module.lux @@ -6,8 +6,8 @@ (data [text "text/" Equivalence] text/format ["e" error] - (coll [list "list/" Fold Functor] - (dictionary [plist]))) + (collection [list "list/" Fold Functor] + (dictionary [plist]))) [macro]) [//compiler] (//compiler [analysis])) diff --git a/stdlib/source/lux/lang/scope.lux b/stdlib/source/lux/lang/scope.lux index 191eb5e5d..9cb1de1c2 100644 --- a/stdlib/source/lux/lang/scope.lux +++ b/stdlib/source/lux/lang/scope.lux @@ -6,8 +6,8 @@ [maybe "maybe/" Monad] [product] ["e" error] - (coll [list "list/" Functor Fold Monoid] - (dictionary [plist]))) + (collection [list "list/" Functor Fold Monoid] + (dictionary [plist]))) [macro]) [//reference #+ Register Variable]) diff --git a/stdlib/source/lux/lang/syntax.lux b/stdlib/source/lux/lang/syntax.lux index 2822e5e31..b9214ca11 100644 --- a/stdlib/source/lux/lang/syntax.lux +++ b/stdlib/source/lux/lang/syntax.lux @@ -36,8 +36,8 @@ [text] (text ["l" lexer] format) - (coll [row #+ Row] - ["dict" dictionary #+ Dictionary])))) + (collection [row #+ Row] + ["dict" dictionary #+ Dictionary])))) (type: #export Aliases (Dictionary Text Text)) diff --git a/stdlib/source/lux/lang/type.lux b/stdlib/source/lux/lang/type.lux index 8f3c2eb77..b7e04afa4 100644 --- a/stdlib/source/lux/lang/type.lux +++ b/stdlib/source/lux/lang/type.lux @@ -7,7 +7,7 @@ [ident "ident/" Equivalence Codec] [number "nat/" Codec] [maybe] - (coll [list #+ "list/" Functor Monoid Fold])) + (collection [list #+ "list/" Functor Monoid Fold])) [macro] (macro [code] ["s" syntax #+ Syntax syntax:]) diff --git a/stdlib/source/lux/lang/type/check.lux b/stdlib/source/lux/lang/type/check.lux index fa21654b7..84b9f808d 100644 --- a/stdlib/source/lux/lang/type/check.lux +++ b/stdlib/source/lux/lang/type/check.lux @@ -8,8 +8,8 @@ [number "nat/" Codec] [maybe] [product] - (coll [list] - [set #+ Set]) + (collection [list] + [set #+ Set]) ["e" error]) (lang [type "type/" Equivalence]) )) diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux index 8aaa567ae..f55eb2392 100644 --- a/stdlib/source/lux/macro.lux +++ b/stdlib/source/lux/macro.lux @@ -9,7 +9,7 @@ [maybe] ["e" error] [text "text/" Monoid Equivalence] - (coll [list "list/" Monoid Monad]))) + (collection [list "list/" Monoid Monad]))) (/ [code])) ## (type: (Meta a) diff --git a/stdlib/source/lux/macro/code.lux b/stdlib/source/lux/macro/code.lux index 42f575a57..cb977f36e 100644 --- a/stdlib/source/lux/macro/code.lux +++ b/stdlib/source/lux/macro/code.lux @@ -5,7 +5,7 @@ number [text #+ Equivalence "text/" Monoid] ident - (coll [list #* "" Functor Fold]) + (collection [list #* "" Functor Fold]) ))) ## [Types] diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux index 429a93bde..05f800653 100644 --- a/stdlib/source/lux/macro/poly.lux +++ b/stdlib/source/lux/macro/poly.lux @@ -6,8 +6,8 @@ ["ex" exception #+ exception:]) [function] (data [text "text/" Monoid] - (coll [list "list/" Fold Monad Monoid] - ["dict" dictionary #+ Dictionary]) + (collection [list "list/" Fold Monad Monoid] + ["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 f8e178700..a01f70c74 100644 --- a/stdlib/source/lux/macro/poly/equivalence.lux +++ b/stdlib/source/lux/macro/poly/equivalence.lux @@ -5,13 +5,13 @@ ["p" parser]) (data [text "text/" Monoid] text/format - (coll [list "list/" Monad] - [row] - [array] - [queue] - [set] - ["dict" dictionary #+ Dictionary] - (tree [rose])) + (collection [list "list/" Monad] + [row] + [array] + [queue] + [set] + ["dict" dictionary #+ Dictionary] + (tree [rose])) [number "nat/" Codec] [product] [bool] diff --git a/stdlib/source/lux/macro/poly/functor.lux b/stdlib/source/lux/macro/poly/functor.lux index a0e5bb463..c7a000e61 100644 --- a/stdlib/source/lux/macro/poly/functor.lux +++ b/stdlib/source/lux/macro/poly/functor.lux @@ -5,7 +5,7 @@ ["p" parser]) (data [text] text/format - (coll [list "L/" Monad Monoid]) + (collection [list "L/" Monad Monoid]) [product]) [macro] (macro [code] diff --git a/stdlib/source/lux/macro/poly/json.lux b/stdlib/source/lux/macro/poly/json.lux index 8f7a1170e..1414bb38c 100644 --- a/stdlib/source/lux/macro/poly/json.lux +++ b/stdlib/source/lux/macro/poly/json.lux @@ -14,9 +14,9 @@ ["e" error] [sum] [product] - (coll [list "list/" Fold Monad] - [row #+ Row row "row/" Monad] - ["d" dictionary]) + (collection [list "list/" Fold Monad] + [row #+ Row row "row/" Monad] + ["d" dictionary]) (format ["//" json #+ JSON])) (time ## ["i" instant] ["du" duration] diff --git a/stdlib/source/lux/macro/syntax.lux b/stdlib/source/lux/macro/syntax.lux index 5739886ea..c333b3d8f 100644 --- a/stdlib/source/lux/macro/syntax.lux +++ b/stdlib/source/lux/macro/syntax.lux @@ -8,7 +8,7 @@ [number] [text "text/" Monoid] [ident] - (coll [list "list/" Functor]) + (collection [list "list/" Functor]) [maybe] [error #+ Error])) (// [code "code/" Equivalence])) diff --git a/stdlib/source/lux/macro/syntax/common/reader.lux b/stdlib/source/lux/macro/syntax/common/reader.lux index 0237d579a..0db5f645b 100644 --- a/stdlib/source/lux/macro/syntax/common/reader.lux +++ b/stdlib/source/lux/macro/syntax/common/reader.lux @@ -2,7 +2,7 @@ lux (lux (control monad ["p" parser "p/" Monad]) - (data (coll [list]) + (data (collection [list]) [ident "ident/" Equivalence] [product] [maybe]) diff --git a/stdlib/source/lux/macro/syntax/common/writer.lux b/stdlib/source/lux/macro/syntax/common/writer.lux index 9c304223e..06edd114a 100644 --- a/stdlib/source/lux/macro/syntax/common/writer.lux +++ b/stdlib/source/lux/macro/syntax/common/writer.lux @@ -1,7 +1,7 @@ (.module: {#.doc "Commons syntax writers."} lux - (lux (data (coll [list "list/" Functor]) + (lux (data (collection [list "list/" Functor]) [product]) (macro [code])) [//]) diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux index 0ca31a34c..66b35f320 100644 --- a/stdlib/source/lux/math.lux +++ b/stdlib/source/lux/math.lux @@ -4,7 +4,7 @@ ["p" parser "p/" Functor]) (data [product] [number] - (coll [list "L/" Fold])) + (collection [list "L/" Fold])) [macro] (macro ["s" syntax #+ syntax: Syntax] [code]))) diff --git a/stdlib/source/lux/math/logic/fuzzy.lux b/stdlib/source/lux/math/logic/fuzzy.lux index 9ee9b1685..5b31a6379 100644 --- a/stdlib/source/lux/math/logic/fuzzy.lux +++ b/stdlib/source/lux/math/logic/fuzzy.lux @@ -1,10 +1,7 @@ (.module: lux - (lux (data [number "Rev/" Interval] - (coll [list] - [set #+ Set]) - text/format) - [math]) + (lux (data (collection [list] + [set #+ Set]))) (// ["&" continuous])) (type: #export (Fuzzy a) diff --git a/stdlib/source/lux/math/random.lux b/stdlib/source/lux/math/random.lux index 218c9131b..7a1fb7225 100644 --- a/stdlib/source/lux/math/random.lux +++ b/stdlib/source/lux/math/random.lux @@ -12,14 +12,14 @@ [number #+ hex] (number ["r" ratio] ["c" complex]) - (coll [list "list/" Fold] - [array] - ["dict" dictionary #+ Dictionary] - [queue #+ Queue] - [set #+ Set] - [stack #+ Stack] - [row #+ Row] - (tree [finger #+ Tree]))) + (collection [list "list/" Fold] + [array] + ["dict" dictionary #+ Dictionary] + [queue #+ Queue] + [set #+ Set] + [stack #+ Stack] + [row #+ Row] + (tree [finger #+ Tree]))) (type [refinement #+ Refiner Refined]) )) diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux index 33ac37423..bd804cfb0 100644 --- a/stdlib/source/lux/test.lux +++ b/stdlib/source/lux/test.lux @@ -6,12 +6,12 @@ (control [monad #+ do Monad] ["p" parser]) (concurrency [promise #+ Promise]) - (data (coll [list "list/" Monad Fold]) - [product] + (data [product] [maybe] + ["e" error] [text] text/format - ["e" error]) + (collection [list "list/" Monad Fold])) [io #+ IO io] (time [instant] [duration]) diff --git a/stdlib/source/lux/time/date.lux b/stdlib/source/lux/time/date.lux index 38fc89800..fe0cff9b8 100644 --- a/stdlib/source/lux/time/date.lux +++ b/stdlib/source/lux/time/date.lux @@ -11,7 +11,7 @@ [number "int/" Codec] [text "text/" Monoid] (text ["l" lexer]) - (coll [row #+ Row row])))) + (collection [row #+ Row row])))) (type: #export Year Int) diff --git a/stdlib/source/lux/time/instant.lux b/stdlib/source/lux/time/instant.lux index 88058868b..1765c524e 100644 --- a/stdlib/source/lux/time/instant.lux +++ b/stdlib/source/lux/time/instant.lux @@ -12,8 +12,8 @@ [number "int/" Codec] ["e" error] [maybe] - (coll [list "L/" Fold Functor] - [row #+ Row row "row/" Functor Fold])) + (collection [list "L/" Fold Functor] + [row #+ Row row "row/" Functor Fold])) (type abstract)) (// [duration "duration/" Order] [date])) diff --git a/stdlib/source/lux/type/abstract.lux b/stdlib/source/lux/type/abstract.lux index d9aa8a8bb..28c90bbc8 100644 --- a/stdlib/source/lux/type/abstract.lux +++ b/stdlib/source/lux/type/abstract.lux @@ -4,7 +4,7 @@ ["p" parser]) (data [text "text/" Equivalence Monoid] [error] - (coll [list "list/" Functor Monoid])) + (collection [list "list/" Functor Monoid])) [macro #+ "meta/" Monad] (macro [code] ["s" syntax #+ syntax:] diff --git a/stdlib/source/lux/type/implicit.lux b/stdlib/source/lux/type/implicit.lux index aa0326b93..ea82200df 100644 --- a/stdlib/source/lux/type/implicit.lux +++ b/stdlib/source/lux/type/implicit.lux @@ -6,8 +6,8 @@ (data [text "text/" Equivalence] text/format [number] - (coll [list "list/" Monad Fold] - ["dict" dictionary #+ Dictionary]) + (collection [list "list/" Monad Fold] + ["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 c2eca52ce..f48ccab0a 100644 --- a/stdlib/source/lux/type/object/interface.lux +++ b/stdlib/source/lux/type/object/interface.lux @@ -7,8 +7,8 @@ [product] [maybe] [ident #+ "ident/" Equivalence] - (coll [list "list/" Functor Fold Monoid] - [set #+ Set])) + (collection [list "list/" Functor Fold Monoid] + [set #+ Set])) [macro #+ Monad "meta/" Monad] (macro [code] ["s" syntax #+ syntax:] diff --git a/stdlib/source/lux/type/object/protocol.lux b/stdlib/source/lux/type/object/protocol.lux index 3499b436a..5407b8f3f 100644 --- a/stdlib/source/lux/type/object/protocol.lux +++ b/stdlib/source/lux/type/object/protocol.lux @@ -3,7 +3,7 @@ (lux (control ["p" parser] [monad #+ do]) (data [sum] - (coll [list "list/" Functor])) + (collection [list "list/" Functor])) [macro "meta/" Monad] (macro [code] ["s" syntax #+ syntax:] diff --git a/stdlib/source/lux/type/resource.lux b/stdlib/source/lux/type/resource.lux index cf2650f74..636939a1b 100644 --- a/stdlib/source/lux/type/resource.lux +++ b/stdlib/source/lux/type/resource.lux @@ -9,10 +9,10 @@ [product] [number] text/format - (coll ["dict" dictionary #+ Dictionary] - [set] - [row #+ Row] - [list "list/" Functor Fold])) + (collection ["dict" dictionary #+ Dictionary] + [set] + [row #+ Row] + [list "list/" Functor Fold])) (concurrency [promise #+ Promise]) [macro] (macro ["s" syntax #+ Syntax syntax:]) diff --git a/stdlib/source/lux/world/env.jvm.lux b/stdlib/source/lux/world/env.jvm.lux index 39c5f9472..56d2c9bf8 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" dictionary])) + (collection ["dict" dictionary])) [io #- run] [host])) diff --git a/stdlib/source/lux/world/file.lux b/stdlib/source/lux/world/file.lux index 3e0a6c65e..de93d940a 100644 --- a/stdlib/source/lux/world/file.lux +++ b/stdlib/source/lux/world/file.lux @@ -5,7 +5,7 @@ pipe) (data [error #+ Error] text/format - (coll [array])) + (collection [array])) (time [instant #+ Instant] [duration]) (world [blob #+ Blob]) diff --git a/stdlib/source/lux/world/net/udp.jvm.lux b/stdlib/source/lux/world/net/udp.jvm.lux index a11405132..527d957c6 100644 --- a/stdlib/source/lux/world/net/udp.jvm.lux +++ b/stdlib/source/lux/world/net/udp.jvm.lux @@ -6,7 +6,7 @@ ["T" task]) (data ["e" error] [maybe] - (coll [array])) + (collection [array])) (type abstract) (world [blob #+ Blob]) [io] diff --git a/stdlib/test/test/lux/cli.lux b/stdlib/test/test/lux/cli.lux index b8bc50e9e..bd0ed72d8 100644 --- a/stdlib/test/test/lux/cli.lux +++ b/stdlib/test/test/lux/cli.lux @@ -10,7 +10,7 @@ [number] [text "text/" Equivalence] text/format - (coll [list])) + (collection [list])) ["r" math/random] ["/" cli]) lux/test) diff --git a/stdlib/test/test/lux/concurrency/atom.lux b/stdlib/test/test/lux/concurrency/atom.lux index a4856252a..b6c220b28 100644 --- a/stdlib/test/test/lux/concurrency/atom.lux +++ b/stdlib/test/test/lux/concurrency/atom.lux @@ -3,7 +3,7 @@ (lux [io] (control ["M" monad #+ do Monad]) (data [number] - (coll [list "" Functor]) + (collection [list "" Functor]) text/format) (concurrency ["&" atom]) ["r" math/random]) diff --git a/stdlib/test/test/lux/concurrency/frp.lux b/stdlib/test/test/lux/concurrency/frp.lux index 8a1e04849..7760ad806 100644 --- a/stdlib/test/test/lux/concurrency/frp.lux +++ b/stdlib/test/test/lux/concurrency/frp.lux @@ -4,7 +4,7 @@ (control [monad #+ do Monad]) (data [number] text/format - (coll [list])) + (collection [list])) (concurrency [promise #+ "promise/" Monad] [frp #+ Channel] [atom #+ Atom atom])) diff --git a/stdlib/test/test/lux/concurrency/semaphore.lux b/stdlib/test/test/lux/concurrency/semaphore.lux index 0100ee2ac..294f2c5e2 100644 --- a/stdlib/test/test/lux/concurrency/semaphore.lux +++ b/stdlib/test/test/lux/concurrency/semaphore.lux @@ -4,7 +4,7 @@ (data [maybe] [text "text/" Equivalence Monoid] text/format - (coll [list "list/" Functor])) + (collection [list "list/" Functor])) (concurrency ["/" semaphore] [promise #+ Promise] [atom #+ Atom]) diff --git a/stdlib/test/test/lux/concurrency/stm.lux b/stdlib/test/test/lux/concurrency/stm.lux index 4bebfa3e7..23dbb6850 100644 --- a/stdlib/test/test/lux/concurrency/stm.lux +++ b/stdlib/test/test/lux/concurrency/stm.lux @@ -4,7 +4,7 @@ (control ["M" monad #+ do Monad]) (data [number] [maybe] - (coll [list "" Functor "List/" Fold]) + (collection [list "" Functor "List/" Fold]) text/format) (concurrency [atom #+ Atom atom] ["&" stm] diff --git a/stdlib/test/test/lux/control/continuation.lux b/stdlib/test/test/lux/control/continuation.lux index bda63e3e1..c5fa339d0 100644 --- a/stdlib/test/test/lux/control/continuation.lux +++ b/stdlib/test/test/lux/control/continuation.lux @@ -7,7 +7,7 @@ text/format [number] [product] - (coll [list])) + (collection [list])) ["r" math/random]) lux/test) diff --git a/stdlib/test/test/lux/control/interval.lux b/stdlib/test/test/lux/control/interval.lux index 6b6e96789..99dd14b4e 100644 --- a/stdlib/test/test/lux/control/interval.lux +++ b/stdlib/test/test/lux/control/interval.lux @@ -8,8 +8,8 @@ ["r" math/random] (data text/format [number] - (coll ["S" set] - ["L" list])))) + (collection ["S" set] + ["L" list])))) (context: "Equivalence." (<| (times +100) diff --git a/stdlib/test/test/lux/control/region.lux b/stdlib/test/test/lux/control/region.lux index 48b2b1b7f..d0a2fb11d 100644 --- a/stdlib/test/test/lux/control/region.lux +++ b/stdlib/test/test/lux/control/region.lux @@ -5,7 +5,7 @@ [thread #+ Thread] ["ex" exception #+ exception:]) (data ["e" error #+ Error] - (coll [list]) + (collection [list]) text/format) ["r" math/random]) lux/test) diff --git a/stdlib/test/test/lux/data/coll/array.lux b/stdlib/test/test/lux/data/coll/array.lux deleted file mode 100644 index c29baefc3..000000000 --- a/stdlib/test/test/lux/data/coll/array.lux +++ /dev/null @@ -1,140 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do Monad] - pipe) - [io] - (data (coll ["@" array] - [list]) - [number] - [maybe]) - ["r" math/random]) - lux/test) - -(def: bounded-size - (r.Random Nat) - (|> r.nat - (:: r.Monad map (|>> (n/% +100) (n/+ +1))))) - -(context: "Arrays and their copies" - (<| (times +100) - (do @ - [size bounded-size - original (r.array size r.nat) - #let [clone (@.clone original) - copy (: (Array Nat) - (@.new size)) - manual-copy (: (Array Nat) - (@.new size))]] - ($_ seq - (test "Size function must correctly return size of array." - (n/= size (@.size original))) - (test "Cloning an array should yield and identical array, but not the same one." - (and (:: (@.Equivalence number.Equivalence) = original clone) - (not (is? original clone)))) - (test "Full-range manual copies should give the same result as cloning." - (exec (@.copy size +0 original +0 copy) - (and (:: (@.Equivalence number.Equivalence) = original copy) - (not (is? original copy))))) - (test "Array folding should go over all values." - (exec (:: @.Fold fold - (function (_ x idx) - (exec (@.write idx x manual-copy) - (inc idx))) - +0 - original) - (:: (@.Equivalence number.Equivalence) = original manual-copy))) - (test "Transformations between (full) arrays and lists shouldn't cause lose or change any values." - (|> original - @.to-list @.from-list - (:: (@.Equivalence number.Equivalence) = original))) - )))) - -(context: "Array mutation" - (<| (times +100) - (do @ - [size bounded-size - idx (:: @ map (n/% size) r.nat) - array (|> (r.array size r.nat) - (r.filter (|>> @.to-list (list.any? n/odd?)))) - #let [value (maybe.assume (@.read idx array))]] - ($_ seq - (test "Shouldn't be able to find a value in an unoccupied cell." - (case (@.read idx (@.delete idx array)) - (#.Some _) false - #.None true)) - (test "You should be able to access values put into the array." - (case (@.read idx (@.write idx value array)) - (#.Some value') (n/= value' value) - #.None false)) - (test "All cells should be occupied on a full array." - (and (n/= size (@.occupied array)) - (n/= +0 (@.vacant array)))) - (test "Filtering mutates the array to remove invalid values." - (exec (@.filter n/even? array) - (and (n/< size (@.occupied array)) - (n/> +0 (@.vacant array)) - (n/= size (n/+ (@.occupied array) - (@.vacant array)))))) - )))) - -(context: "Finding values." - (<| (times +100) - (do @ - [size bounded-size - array (|> (r.array size r.nat) - (r.filter (|>> @.to-list (list.any? n/even?))))] - ($_ seq - (test "Can find values inside arrays." - (|> (@.find n/even? array) - (case> (#.Some _) true - #.None false))) - (test "Can find values inside arrays (with access to indices)." - (|> (@.find+ (function (_ idx n) - (and (n/even? n) - (n/< size idx))) - array) - (case> (#.Some _) true - #.None false))))))) - -(context: "Functor" - (<| (times +100) - (do @ - [size bounded-size - array (r.array size r.nat)] - (let [(^open) @.Functor - (^open) (@.Equivalence number.Equivalence)] - ($_ seq - (test "Functor shouldn't alter original array." - (let [copy (map id array)] - (and (= array copy) - (not (is? array copy))))) - (test "Functor should go over all available array elements." - (let [there (map inc array) - back-again (map dec there)] - (and (not (= array there)) - (= array back-again))))))))) - -(context: "Monoid" - (<| (times +100) - (do @ - [sizeL bounded-size - sizeR bounded-size - left (r.array sizeL r.nat) - right (r.array sizeR r.nat) - #let [(^open) @.Monoid - (^open) (@.Equivalence number.Equivalence) - fusion (compose left right)]] - ($_ seq - (test "Appending two arrays should produce a new one twice as large." - (n/= (n/+ sizeL sizeR) (@.size fusion))) - (test "First elements of fused array should equal the first array." - (|> (: (Array Nat) - (@.new sizeL)) - (@.copy sizeL +0 fusion +0) - (= left))) - (test "Last elements of fused array should equal the second array." - (|> (: (Array Nat) - (@.new sizeR)) - (@.copy sizeR sizeL fusion +0) - (= right))) - )))) diff --git a/stdlib/test/test/lux/data/coll/bits.lux b/stdlib/test/test/lux/data/coll/bits.lux deleted file mode 100644 index 0fbe2edb2..000000000 --- a/stdlib/test/test/lux/data/coll/bits.lux +++ /dev/null @@ -1,80 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - [predicate]) - (data (coll ["/" bits])) - ["r" math/random]) - lux/test - (test (lux (control ["_eq" equivalence])))) - -(def: (size min max) - (-> Nat Nat (r.Random Nat)) - (|> r.nat - (:: r.Monad map (|>> (n/% max) (n/max min))))) - -(def: bits - (r.Random /.Bits) - (do r.Monad - [size (size +1 +1_000) - idx (|> r.nat (:: @ map (n/% size)))] - (wrap (|> /.empty (/.set idx))))) - -(context: "Bits." - (<| (times +100) - (do @ - [size (size +1 +1_000) - idx (|> r.nat (:: @ map (n/% size))) - sample bits] - ($_ seq - (test "Can set individual bits." - (and (|> /.empty (/.get idx) not) - (|> /.empty (/.set idx) (/.get idx)))) - (test "Can clear individual bits." - (|> /.empty (/.set idx) (/.clear idx) (/.get idx) not)) - (test "Can flip individual bits." - (and (|> /.empty (/.flip idx) (/.get idx)) - (|> /.empty (/.flip idx) (/.flip idx) (/.get idx) not))) - - (test "Bits (only) grow when (and as much as) necessary." - (and (n/= +0 (/.capacity /.empty)) - (|> /.empty (/.set idx) /.capacity - (n/- idx) - (predicate.union (n/>= +0) - (n/< /.chunk-size))))) - (test "Bits (must) shrink when (and as much as) possible." - (let [grown (/.flip idx /.empty)] - (and (n/> +0 (/.capacity grown)) - (is? /.empty (/.flip idx grown))))) - - (test "Intersection can be detected when there are set bits in common." - (and (not (/.intersects? /.empty - /.empty)) - (/.intersects? (/.set idx /.empty) - (/.set idx /.empty)) - (not (/.intersects? (/.set (inc idx) /.empty) - (/.set idx /.empty))))) - (test "Cannot intersect with one's opposite." - (not (/.intersects? sample (/.not sample)))) - - (test "'and' with oneself changes nothing" - (:: /.Equivalence = sample (/.and sample sample))) - (test "'and' with one's opposite yields the empty bit-set." - (is? /.empty (/.and sample (/.not sample)))) - - (test "'or' with one's opposite fully saturates a bit-set." - (n/= (/.size (/.or sample (/.not sample))) - (/.capacity sample))) - - (test "'xor' with oneself yields the empty bit-set." - (is? /.empty (/.xor sample sample))) - (test "'xor' with one's opposite fully saturates a bit-set." - (n/= (/.size (/.xor sample (/.not sample))) - (/.capacity sample))) - - (test "Double negation results in original bit-set." - (:: /.Equivalence = sample (/.not (/.not sample)))) - (test "Negation does not affect the empty bit-set." - (is? /.empty (/.not /.empty))) - - (_eq.spec /.Equivalence ..bits) - )))) diff --git a/stdlib/test/test/lux/data/coll/dictionary.lux b/stdlib/test/test/lux/data/coll/dictionary.lux deleted file mode 100644 index 9c652ee7a..000000000 --- a/stdlib/test/test/lux/data/coll/dictionary.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] - [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 deleted file mode 100644 index 548fd7f83..000000000 --- a/stdlib/test/test/lux/data/coll/dictionary/ordered.lux +++ /dev/null @@ -1,88 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do Monad] - [equivalence #+ Equivalence]) - (data [product] - [number] - (coll ["s" set] - ["dict" dictionary] - (dictionary ["&" ordered]) - [list "L/" Functor])) - ["r" math/random]) - lux/test) - -(context: "Dictionary" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (n/% +100))) - keys (r.set number.Hash size r.nat) - values (r.set number.Hash size r.nat) - extra-key (|> r.nat (r.filter (|>> (s.member? keys) not))) - extra-value r.nat - #let [pairs (list.zip2 (s.to-list keys) - (s.to-list values)) - sample (&.from-list number.Order pairs) - sorted-pairs (list.sort (function (_ [left _] [right _]) - (n/< left right)) - pairs) - sorted-values (L/map product.right sorted-pairs) - (^open "&/") (&.Equivalence number.Equivalence)]] - ($_ seq - (test "Can query the size of a dictionary." - (n/= size (&.size sample))) - - (test "Can query value for minimum key." - (case [(&.min sample) (list.head sorted-values)] - [#.None #.None] - true - - [(#.Some reference) (#.Some sample)] - (n/= reference sample) - - _ - false)) - - (test "Can query value for maximum key." - (case [(&.max sample) (list.last sorted-values)] - [#.None #.None] - true - - [(#.Some reference) (#.Some sample)] - (n/= reference sample) - - _ - false)) - - (test "Converting dictionaries to/from lists cannot change their values." - (|> sample - &.entries (&.from-list number.Order) - (&/= sample))) - - (test "Order is preserved." - (let [(^open "L/") (list.Equivalence (: (Equivalence [Nat Nat]) - (function (_ [kr vr] [ks vs]) - (and (n/= kr ks) - (n/= vr vs)))))] - (L/= (&.entries sample) - sorted-pairs))) - - (test "Every key in a dictionary must be identifiable." - (list.every? (function (_ key) (&.contains? key sample)) - (&.keys sample))) - - (test "Can add and remove elements in a dictionary." - (and (not (&.contains? extra-key sample)) - (let [sample' (&.put extra-key extra-value sample) - sample'' (&.remove extra-key sample')] - (and (&.contains? extra-key sample') - (not (&.contains? extra-key sample'')) - (case [(&.get extra-key sample') - (&.get extra-key sample'')] - [(#.Some found) #.None] - (n/= extra-value found) - - _ - false))) - )) - )))) diff --git a/stdlib/test/test/lux/data/coll/list.lux b/stdlib/test/test/lux/data/coll/list.lux deleted file mode 100644 index d57b19b9c..000000000 --- a/stdlib/test/test/lux/data/coll/list.lux +++ /dev/null @@ -1,235 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do Monad] - pipe) - (data (coll ["&" list]) - [number] - [bool] - [product] - [maybe]) - ["r" math/random]) - lux/test) - -(def: bounded-size - (r.Random Nat) - (|> r.nat - (:: r.Monad map (|>> (n/% +100) (n/+ +10))))) - -(context: "Lists: Part 1" - (<| (times +100) - (do @ - [size bounded-size - idx (:: @ map (n/% size) r.nat) - sample (r.list size r.nat) - other-size bounded-size - other-sample (r.list other-size r.nat) - separator r.nat - #let [(^open) (&.Equivalence number.Equivalence) - (^open "&/") &.Functor]] - ($_ seq - (test "The size function should correctly portray the size of the list." - (n/= size (&.size sample))) - - (test "The repeat function should produce as many elements as asked of it." - (n/= size (&.size (&.repeat size [])))) - - (test "Reversing a list does not change it's size." - (n/= (&.size sample) - (&.size (&.reverse sample)))) - - (test "Reversing a list twice results in the original list." - (= sample - (&.reverse (&.reverse sample)))) - - (test "Filtering by a predicate and its complement should result in a number of elements equal to the original list." - (and (n/= (&.size sample) - (n/+ (&.size (&.filter n/even? sample)) - (&.size (&.filter (bool.complement n/even?) sample)))) - (let [[plus minus] (&.partition n/even? sample)] - (n/= (&.size sample) - (n/+ (&.size plus) - (&.size minus)))))) - - (test "If every element in a list satisfies a predicate, there can't be any that satisfy its complement." - (if (&.every? n/even? sample) - (and (not (&.any? (bool.complement n/even?) sample)) - (&.empty? (&.filter (bool.complement n/even?) sample))) - (&.any? (bool.complement n/even?) sample))) - - (test "Any element of the list can be considered its member." - (let [elem (maybe.assume (&.nth idx sample))] - (&.member? number.Equivalence sample elem))) - )))) - -(context: "Lists: Part 2" - (<| (times +100) - (do @ - [size bounded-size - idx (:: @ map (n/% size) r.nat) - sample (r.list size r.nat) - other-size bounded-size - other-sample (r.list other-size r.nat) - separator r.nat - #let [(^open) (&.Equivalence number.Equivalence) - (^open "&/") &.Functor]] - ($_ seq - (test "Appending the head and the tail should yield the original list." - (let [head (maybe.assume (&.head sample)) - tail (maybe.assume (&.tail sample))] - (= sample - (#.Cons head tail)))) - - (test "Appending the inits and the last should yield the original list." - (let [(^open) &.Monoid - inits (maybe.assume (&.inits sample)) - last (maybe.assume (&.last sample))] - (= sample - (compose inits (list last))))) - - (test "Functor should go over every element of the list." - (let [(^open) &.Functor - there (map inc sample) - back-again (map dec there)] - (and (not (= sample there)) - (= sample back-again)))) - - (test "Splitting a list into chunks and re-appending them should yield the original list." - (let [(^open) &.Monoid - [left right] (&.split idx sample) - [left' right'] (&.split-with n/even? sample)] - (and (= sample - (compose left right)) - (= sample - (compose left' right')) - (= sample - (compose (&.take idx sample) - (&.drop idx sample))) - (= sample - (compose (&.take-while n/even? sample) - (&.drop-while n/even? sample))) - ))) - - (test "Segmenting the list in pairs should yield as many elements as N/2." - (n/= (n// +2 size) - (&.size (&.as-pairs sample)))) - - (test "Sorting a list shouldn't change it's size." - (n/= (&.size sample) - (&.size (&.sort n/< sample)))) - - (test "Sorting a list with one order should yield the reverse of sorting it with the opposite order." - (= (&.sort n/< sample) - (&.reverse (&.sort n/> sample)))) - )))) - -(context: "Lists: Part 3" - (<| (times +100) - (do @ - [size bounded-size - idx (:: @ map (n/% size) r.nat) - sample (r.list size r.nat) - other-size bounded-size - other-sample (r.list other-size r.nat) - separator r.nat - from (|> r.nat (:: @ map (n/% +10))) - to (|> r.nat (:: @ map (n/% +10))) - #let [(^open) (&.Equivalence number.Equivalence) - (^open "&/") &.Functor]] - ($_ seq - (test "If you zip 2 lists, the result's size will be that of the smaller list." - (n/= (&.size (&.zip2 sample other-sample)) - (n/min (&.size sample) (&.size other-sample)))) - - (test "I can pair-up elements of a list in order." - (let [(^open) &.Functor - zipped (&.zip2 sample other-sample) - num-zipper (&.size zipped)] - (and (|> zipped (map product.left) (= (&.take num-zipper sample))) - (|> zipped (map product.right) (= (&.take num-zipper other-sample)))))) - - (test "You can generate indices for any size, and they will be in ascending order." - (let [(^open) &.Functor - indices (&.indices size)] - (and (n/= size (&.size indices)) - (= indices - (&.sort n/< indices)) - (&.every? (n/= (dec size)) - (&.zip2-with n/+ - indices - (&.sort n/> indices))) - ))) - - (test "The 'interpose' function places a value between every member of a list." - (let [(^open) &.Functor - sample+ (&.interpose separator sample)] - (and (n/= (|> size (n/* +2) dec) - (&.size sample+)) - (|> sample+ &.as-pairs (map product.right) (&.every? (n/= separator)))))) - - (test "List append is a monoid." - (let [(^open) &.Monoid] - (and (= sample (compose identity sample)) - (= sample (compose sample identity)) - (let [[left right] (&.split size (compose sample other-sample))] - (and (= sample left) - (= other-sample right)))))) - - (test "Apply allows you to create singleton lists, and apply lists of functions to lists of values." - (let [(^open) &.Monad - (^open) &.Apply] - (and (= (list separator) (wrap separator)) - (= (map inc sample) - (apply (wrap inc) sample))))) - - (test "List concatenation is a monad." - (let [(^open) &.Monad - (^open) &.Monoid] - (= (compose sample other-sample) - (join (list sample other-sample))))) - - (test "You can find any value that satisfies some criterium, if such values exist in the list." - (case (&.find n/even? sample) - (#.Some found) - (and (n/even? found) - (&.any? n/even? sample) - (not (&.every? (bool.complement n/even?) sample))) - - #.None - (and (not (&.any? n/even? sample)) - (&.every? (bool.complement n/even?) sample)))) - - (test "You can iteratively construct a list, generating values until you're done." - (= (&.n/range +0 (dec size)) - (&.iterate (function (_ n) (if (n/< size n) (#.Some (inc n)) #.None)) - +0))) - - (test "Can enumerate all elements in a list." - (let [enum-sample (&.enumerate sample)] - (and (= (&.indices (&.size enum-sample)) - (&/map product.left enum-sample)) - (= sample - (&/map product.right enum-sample))))) - - (test "Ranges can be constructed forward and backwards." - (and (let [(^open "list/") (&.Equivalence number.Equivalence)] - (list/= (&.n/range from to) - (&.reverse (&.n/range to from)))) - (let [(^open "list/") (&.Equivalence number.Equivalence) - from (.int from) - to (.int to)] - (list/= (&.i/range from to) - (&.reverse (&.i/range to from)))))) - )))) - -## TODO: Add again once new-luxc becomes the standard compiler. -(context: "Monad transformer" - (let [lift (&.lift io.Monad) - (^open "io/") io.Monad] - (test "Can add list functionality to any monad." - (|> (io.run (do (&.ListT io.Monad) - [a (lift (io/wrap 123)) - b (wrap 456)] - (wrap (i/+ a b)))) - (case> (^ (list 579)) true - _ false))))) diff --git a/stdlib/test/test/lux/data/coll/queue.lux b/stdlib/test/test/lux/data/coll/queue.lux deleted file mode 100644 index 12d924963..000000000 --- a/stdlib/test/test/lux/data/coll/queue.lux +++ /dev/null @@ -1,51 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do Monad]) - (data (coll ["&" queue]) - [number]) - ["r" math/random]) - lux/test) - -(context: "Queues" - (<| (times +100) - (do @ - [size (:: @ map (n/% +100) r.nat) - sample (r.queue size r.nat) - non-member (|> r.nat - (r.filter (|>> (&.member? number.Equivalence sample) not)))] - ($_ seq - (test "I can query the size of a queue (and empty queues have size 0)." - (if (n/= +0 size) - (&.empty? sample) - (n/= size (&.size sample)))) - - (test "Enqueueing and dequeing affects the size of queues." - (and (n/= (inc size) (&.size (&.push non-member sample))) - (or (&.empty? sample) - (n/= (dec size) (&.size (&.pop sample)))) - (n/= size (&.size (&.pop (&.push non-member sample)))))) - - (test "Transforming to/from list can't change the queue." - (let [(^open "&/") (&.Equivalence number.Equivalence)] - (|> sample - &.to-list &.from-list - (&/= sample)))) - - (test "I can always peek at a non-empty queue." - (case (&.peek sample) - #.None (&.empty? sample) - (#.Some _) true)) - - (test "I can query whether an element belongs to a queue." - (and (not (&.member? number.Equivalence sample non-member)) - (&.member? number.Equivalence (&.push non-member sample) - non-member) - (case (&.peek sample) - #.None - (&.empty? sample) - - (#.Some first) - (and (&.member? number.Equivalence sample first) - (not (&.member? number.Equivalence (&.pop sample) first)))))) - )))) diff --git a/stdlib/test/test/lux/data/coll/queue/priority.lux b/stdlib/test/test/lux/data/coll/queue/priority.lux deleted file mode 100644 index 17664056c..000000000 --- a/stdlib/test/test/lux/data/coll/queue/priority.lux +++ /dev/null @@ -1,52 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do Monad]) - (data (coll (queue ["&" priority])) - [number] - [maybe]) - ["r" math/random]) - lux/test) - -(def: (gen-queue size) - (-> Nat (r.Random (&.Queue Nat))) - (do r.Monad - [inputs (r.list size r.nat)] - (monad.fold @ (function (_ head tail) - (do @ - [priority r.nat] - (wrap (&.push priority head tail)))) - &.empty - inputs))) - -(context: "Queues" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (n/% +100))) - sample (gen-queue size) - non-member-priority r.nat - non-member (|> r.nat (r.filter (|>> (&.member? number.Equivalence sample) not)))] - ($_ seq - (test "I can query the size of a queue (and empty queues have size 0)." - (n/= size (&.size sample))) - - (test "Enqueueing and dequeing affects the size of queues." - (and (n/= (inc size) - (&.size (&.push non-member-priority non-member sample))) - (or (n/= +0 (&.size sample)) - (n/= (dec size) - (&.size (&.pop sample)))))) - - (test "I can query whether an element belongs to a queue." - (and (and (not (&.member? number.Equivalence sample non-member)) - (&.member? number.Equivalence - (&.push non-member-priority non-member sample) - non-member)) - (or (n/= +0 (&.size sample)) - (and (&.member? number.Equivalence - sample - (maybe.assume (&.peek sample))) - (not (&.member? number.Equivalence - (&.pop sample) - (maybe.assume (&.peek sample)))))))) - )))) diff --git a/stdlib/test/test/lux/data/coll/row.lux b/stdlib/test/test/lux/data/coll/row.lux deleted file mode 100644 index 643dcbe24..000000000 --- a/stdlib/test/test/lux/data/coll/row.lux +++ /dev/null @@ -1,73 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do Monad]) - (data (coll ["&" row] - [list "list/" Fold]) - [number] - [maybe]) - ["r" math/random]) - lux/test) - -(context: "Rows" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (|>> (n/% +100) (n/max +1)))) - idx (|> r.nat (:: @ map (n/% size))) - sample (r.row size r.nat) - other-sample (r.row size r.nat) - non-member (|> r.nat (r.filter (|>> (&.member? number.Equivalence sample) not))) - #let [(^open "&/") (&.Equivalence number.Equivalence) - (^open "&/") &.Apply - (^open "&/") &.Monad - (^open "&/") &.Fold - (^open "&/") &.Monoid]] - ($_ seq - (test "Can query size of row." - (if (&.empty? sample) - (and (n/= +0 size) - (n/= +0 (&.size sample))) - (n/= size (&.size sample)))) - - (test "Can add and remove elements to rows." - (and (n/= (inc size) (&.size (&.add non-member sample))) - (n/= (dec size) (&.size (&.pop sample))))) - - (test "Can put and get elements into rows." - (|> sample - (&.put idx non-member) - (&.nth idx) - maybe.assume - (is? non-member))) - - (test "Can update elements of rows." - (|> sample - (&.put idx non-member) (&.update idx inc) - (&.nth idx) maybe.assume - (n/= (inc non-member)))) - - (test "Can safely transform to/from lists." - (|> sample &.to-list &.from-list (&/= sample))) - - (test "Can identify members of a row." - (and (not (&.member? number.Equivalence sample non-member)) - (&.member? number.Equivalence (&.add non-member sample) non-member))) - - (test "Can fold over elements of row." - (n/= (list/fold n/+ +0 (&.to-list sample)) - (&/fold n/+ +0 sample))) - - (test "Functor goes over every element." - (let [there (&/map inc sample) - back-again (&/map dec there)] - (and (not (&/= sample there)) - (&/= sample back-again)))) - - (test "Apply allows you to create singleton rows, and apply rows of functions to rows of values." - (and (&/= (&.row non-member) (&/wrap non-member)) - (&/= (&/map inc sample) (&/apply (&/wrap inc) sample)))) - - (test "Row concatenation is a monad." - (&/= (&/compose sample other-sample) - (&/join (&.row sample other-sample)))) - )))) diff --git a/stdlib/test/test/lux/data/coll/sequence.lux b/stdlib/test/test/lux/data/coll/sequence.lux deleted file mode 100644 index d1e91bcd1..000000000 --- a/stdlib/test/test/lux/data/coll/sequence.lux +++ /dev/null @@ -1,101 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do Monad] - comonad) - (data [maybe] - [text "Text/" Monoid] - text/format - (coll [list] - ["&" sequence]) - [number "Nat/" Codec]) - ["r" math/random]) - lux/test) - -(context: "Sequences" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (|>> (n/% +100) (n/max +2)))) - offset (|> r.nat (:: @ map (n/% +100))) - factor (|> r.nat (:: @ map (|>> (n/% +100) (n/max +2)))) - elem r.nat - cycle-seed (r.list size r.nat) - cycle-sample-idx (|> r.nat (:: @ map (n/% +1000))) - #let [(^open "List/") (list.Equivalence number.Equivalence) - sample0 (&.iterate inc +0) - sample1 (&.iterate inc offset)]] - ($_ seq - (test "Can move along a sequence and take slices off it." - (and (and (List/= (list.n/range +0 (dec size)) - (&.take size sample0)) - (List/= (list.n/range offset (dec (n/+ offset size))) - (&.take size (&.drop offset sample0))) - (let [[drops takes] (&.split size sample0)] - (and (List/= (list.n/range +0 (dec size)) - drops) - (List/= (list.n/range size (dec (n/* +2 size))) - (&.take size takes))))) - (and (List/= (list.n/range +0 (dec size)) - (&.take-while (n/< size) sample0)) - (List/= (list.n/range offset (dec (n/+ offset size))) - (&.take-while (n/< (n/+ offset size)) - (&.drop-while (n/< offset) sample0))) - (let [[drops takes] (&.split-while (n/< size) sample0)] - (and (List/= (list.n/range +0 (dec size)) - drops) - (List/= (list.n/range size (dec (n/* +2 size))) - (&.take-while (n/< (n/* +2 size)) takes))))) - )) - - (test "Can repeat any element and infinite number of times." - (n/= elem (&.nth offset (&.repeat elem)))) - - (test "Can obtain the head & tail of a sequence." - (and (n/= offset (&.head sample1)) - (List/= (list.n/range (inc offset) (n/+ offset size)) - (&.take size (&.tail sample1))))) - - (test "Can filter sequences." - (and (n/= (n/* +2 offset) - (&.nth offset - (&.filter n/even? sample0))) - (let [[evens odds] (&.partition n/even? (&.iterate inc +0))] - (and (n/= (n/* +2 offset) - (&.nth offset evens)) - (n/= (inc (n/* +2 offset)) - (&.nth offset odds)))))) - - (test "Functor goes over 'all' elements in a sequence." - (let [(^open "&/") &.Functor - there (&/map (n/* factor) sample0) - back-again (&/map (n// factor) there)] - (and (not (List/= (&.take size sample0) - (&.take size there))) - (List/= (&.take size sample0) - (&.take size back-again))))) - - (test "CoMonad produces a value for every element in a sequence." - (let [(^open "&/") &.Functor] - (List/= (&.take size (&/map (n/* factor) sample1)) - (&.take size - (be &.CoMonad - [inputs sample1] - (n/* factor (&.head inputs))))))) - - (test "'unfold' generalizes 'iterate'." - (let [(^open "&/") &.Functor - (^open "List/") (list.Equivalence text.Equivalence)] - (List/= (&.take size - (&/map Nat/encode (&.iterate inc offset))) - (&.take size - (&.unfold (function (_ n) [(inc n) (Nat/encode n)]) - offset))))) - - (test "Can cycle over the same elements as an infinite sequence." - (|> (&.cycle cycle-seed) - maybe.assume - (&.nth cycle-sample-idx) - (n/= (|> cycle-seed - (list.nth (n/% size cycle-sample-idx)) - maybe.assume)))) - )))) diff --git a/stdlib/test/test/lux/data/coll/set.lux b/stdlib/test/test/lux/data/coll/set.lux deleted file mode 100644 index 6b341ee3a..000000000 --- a/stdlib/test/test/lux/data/coll/set.lux +++ /dev/null @@ -1,64 +0,0 @@ -(.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 deleted file mode 100644 index 6833bf4a6..000000000 --- a/stdlib/test/test/lux/data/coll/set/ordered.lux +++ /dev/null @@ -1,94 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do Monad]) - (data (coll [set] - (set ["&" ordered]) - [list "" Fold]) - [number] - text/format) - ["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 - 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) - sortedL (list.sort n/< listL) - minL (list.head sortedL) - maxL (list.last sortedL)]] - ($_ seq - (test "I can query the size of a set." - (n/= sizeL (&.size setL))) - - (test "Can query minimum value." - (case [(&.min setL) minL] - [#.None #.None] - true - - [(#.Some reference) (#.Some sample)] - (n/= reference sample) - - _ - false)) - - (test "Can query maximum value." - (case [(&.max setL) maxL] - [#.None #.None] - true - - [(#.Some reference) (#.Some sample)] - (n/= reference sample) - - _ - false)) - - (test "Converting sets to/from lists can't change their values." - (|> setL - &.to-list (&.from-list number.Order) - (&/= setL))) - - (test "Order is preserved." - (let [listL (&.to-list setL) - (^open "L/") (list.Equivalence number.Equivalence)] - (L/= listL - (list.sort n/< listL)))) - - (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.Order) - setL))) - - (test "Intersection with the empty set results in the empty set." - (let [empty-set (&.new number.Order)] - (&/= 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." - (list.every? (&.member? setL) (&.to-list setL))) - )))) diff --git a/stdlib/test/test/lux/data/coll/stack.lux b/stdlib/test/test/lux/data/coll/stack.lux deleted file mode 100644 index 9a5b1b438..000000000 --- a/stdlib/test/test/lux/data/coll/stack.lux +++ /dev/null @@ -1,45 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do Monad]) - (data (coll ["&" stack] - [list "" Fold]) - [number] - [maybe]) - ["r" math/random]) - lux/test) - -(def: gen-nat - (r.Random Nat) - (|> r.nat - (:: r.Monad map (n/% +100)))) - -(context: "Stacks" - (<| (times +100) - (do @ - [size gen-nat - sample (r.stack size gen-nat) - new-top gen-nat] - ($_ seq - (test "Can query the size of a stack." - (n/= size (&.size sample))) - - (test "Can peek inside non-empty stacks." - (case (&.peek sample) - #.None (&.empty? sample) - (#.Some _) (not (&.empty? sample)))) - - (test "Popping empty stacks doesn't change anything. - But, if they're non-empty, the top of the stack is removed." - (let [sample' (&.pop sample)] - (or (n/= (&.size sample) (inc (&.size sample'))) - (and (&.empty? sample) (&.empty? sample'))) - )) - - (test "Pushing onto a stack always increases it by 1, adding a new value at the top." - (and (is? sample - (&.pop (&.push new-top sample))) - (n/= (inc (&.size sample)) (&.size (&.push new-top sample))) - (|> (&.push new-top sample) &.peek maybe.assume - (is? new-top)))) - )))) diff --git a/stdlib/test/test/lux/data/coll/tree/rose.lux b/stdlib/test/test/lux/data/coll/tree/rose.lux deleted file mode 100644 index 133f2ef20..000000000 --- a/stdlib/test/test/lux/data/coll/tree/rose.lux +++ /dev/null @@ -1,47 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do Monad]) - (data [product] - [number] - [text "T/" Equivalence] - text/format - (coll (tree ["&" rose]) - [list "L/" Monad Fold])) - ["r" math/random]) - lux/test) - -(def: gen-tree - (r.Random [Nat (&.Tree Nat)]) - (r.rec - (function (_ gen-tree) - (r.either (:: r.Monad map (|>> &.leaf [+1]) r.nat) - (do r.Monad - [value r.nat - num-children (|> r.nat (:: @ map (n/% +3))) - children' (r.list num-children gen-tree) - #let [size' (L/fold n/+ +0 (L/map product.left children')) - children (L/map product.right children')]] - (wrap [(inc size') - (&.branch value children)])) - )))) - -(context: "Trees" - (<| (times +100) - (do @ - [[size sample] gen-tree - #let [(^open "&/") (&.Equivalence number.Equivalence) - (^open "&/") &.Fold - concat (function (_ addition partial) (format partial (%n addition)))]] - ($_ seq - (test "Can compare trees for equivalence." - (&/= sample sample)) - - (test "Can flatten a tree to get all the nodes as a flat tree." - (n/= size - (list.size (&.flatten sample)))) - - (test "Can fold trees." - (T/= (&/fold concat "" sample) - (L/fold concat "" (&.flatten sample)))) - )))) diff --git a/stdlib/test/test/lux/data/coll/tree/rose/zipper.lux b/stdlib/test/test/lux/data/coll/tree/rose/zipper.lux deleted file mode 100644 index 0f5eff838..000000000 --- a/stdlib/test/test/lux/data/coll/tree/rose/zipper.lux +++ /dev/null @@ -1,124 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do Monad] - pipe) - (data (coll [list "list/" Fold Functor] - (tree [rose] - (rose ["&" zipper]))) - [text] - text/format - [number] - [maybe]) - ["r" math/random]) - lux/test) - -(def: gen-tree - (r.Random (rose.Tree Nat)) - (r.rec (function (_ gen-tree) - (do r.Monad - ## Each branch can have, at most, 1 child. - [size (|> r.nat (:: @ map (n/% +2)))] - (r.seq r.nat - (r.list size gen-tree)))))) - -(def: (to-end zipper) - (All [a] (-> (&.Zipper a) (&.Zipper a))) - (loop [zipper zipper] - (if (&.end? zipper) - zipper - (recur (&.next zipper))))) - -(context: "Zippers." - (<| (times +100) - (do @ - [sample gen-tree - new-val r.nat - pre-val r.nat - post-val r.nat - #let [(^open "tree/") (rose.Equivalence number.Equivalence) - (^open "list/") (list.Equivalence number.Equivalence)]] - ($_ seq - (test "Trees can be converted to/from zippers." - (|> sample - &.zip &.unzip - (tree/= sample))) - - (test "Creating a zipper gives you a root node." - (|> sample &.zip &.root?)) - - (test "Can move down inside branches. Can move up from lower nodes." - (let [zipper (&.zip sample)] - (if (&.branch? zipper) - (let [child (|> zipper &.down)] - (and (not (tree/= sample (&.unzip child))) - (|> child &.up (is? zipper) not) - (|> child &.root (is? zipper) not))) - (and (&.leaf? zipper) - (|> zipper (&.prepend-child new-val) &.branch?))))) - - (test "Can prepend and append children." - (let [zipper (&.zip sample)] - (if (&.branch? zipper) - (let [mid-val (|> zipper &.down &.value) - zipper (|> zipper - (&.prepend-child pre-val) - (&.append-child post-val))] - (and (|> zipper &.down &.value (is? pre-val)) - (|> zipper &.down &.right &.value (is? mid-val)) - (|> zipper &.down &.right &.right &.value (is? post-val)) - (|> zipper &.down &.rightmost &.leftmost &.value (is? pre-val)) - (|> zipper &.down &.right &.left &.value (is? pre-val)) - (|> zipper &.down &.rightmost &.value (is? post-val)))) - true))) - - (test "Can insert children around a node (unless it's root)." - (let [zipper (&.zip sample)] - (if (&.branch? zipper) - (let [mid-val (|> zipper &.down &.value) - zipper (|> zipper - &.down - (&.insert-left pre-val) - maybe.assume - (&.insert-right post-val) - maybe.assume - &.up)] - (and (|> zipper &.down &.value (is? pre-val)) - (|> zipper &.down &.right &.value (is? mid-val)) - (|> zipper &.down &.right &.right &.value (is? post-val)) - (|> zipper &.down &.rightmost &.leftmost &.value (is? pre-val)) - (|> zipper &.down &.right &.left &.value (is? pre-val)) - (|> zipper &.down &.rightmost &.value (is? post-val)))) - (and (|> zipper (&.insert-left pre-val) (case> (#.Some _) false - #.None true)) - (|> zipper (&.insert-right post-val) (case> (#.Some _) false - #.None true)))))) - - (test "Can set and update the value of a node." - (|> sample &.zip (&.set new-val) &.value (n/= new-val))) - - (test "Zipper traversal follows the outline of the tree depth-first." - (list/= (rose.flatten sample) - (loop [zipper (&.zip sample)] - (if (&.end? zipper) - (list (&.value zipper)) - (#.Cons (&.value zipper) - (recur (&.next zipper))))))) - - (test "Backwards zipper traversal yield reverse tree flatten." - (list/= (list.reverse (rose.flatten sample)) - (loop [zipper (to-end (&.zip sample))] - (if (&.root? zipper) - (list (&.value zipper)) - (#.Cons (&.value zipper) - (recur (&.prev zipper))))))) - - (test "Can remove nodes (except root nodes)." - (let [zipper (&.zip sample)] - (if (&.branch? zipper) - (and (|> zipper &.down &.root? not) - (|> zipper &.down &.remove (case> #.None false - (#.Some node) (&.root? node)))) - (|> zipper &.remove (case> #.None true - (#.Some _) false))))) - )))) diff --git a/stdlib/test/test/lux/data/collection/array.lux b/stdlib/test/test/lux/data/collection/array.lux new file mode 100644 index 000000000..1e083676c --- /dev/null +++ b/stdlib/test/test/lux/data/collection/array.lux @@ -0,0 +1,140 @@ +(.module: + lux + (lux (control [monad #+ do Monad] + pipe) + [io] + (data (collection ["@" array] + [list]) + [number] + [maybe]) + ["r" math/random]) + lux/test) + +(def: bounded-size + (r.Random Nat) + (|> r.nat + (:: r.Monad map (|>> (n/% +100) (n/+ +1))))) + +(context: "Arrays and their copies" + (<| (times +100) + (do @ + [size bounded-size + original (r.array size r.nat) + #let [clone (@.clone original) + copy (: (Array Nat) + (@.new size)) + manual-copy (: (Array Nat) + (@.new size))]] + ($_ seq + (test "Size function must correctly return size of array." + (n/= size (@.size original))) + (test "Cloning an array should yield and identical array, but not the same one." + (and (:: (@.Equivalence number.Equivalence) = original clone) + (not (is? original clone)))) + (test "Full-range manual copies should give the same result as cloning." + (exec (@.copy size +0 original +0 copy) + (and (:: (@.Equivalence number.Equivalence) = original copy) + (not (is? original copy))))) + (test "Array folding should go over all values." + (exec (:: @.Fold fold + (function (_ x idx) + (exec (@.write idx x manual-copy) + (inc idx))) + +0 + original) + (:: (@.Equivalence number.Equivalence) = original manual-copy))) + (test "Transformations between (full) arrays and lists shouldn't cause lose or change any values." + (|> original + @.to-list @.from-list + (:: (@.Equivalence number.Equivalence) = original))) + )))) + +(context: "Array mutation" + (<| (times +100) + (do @ + [size bounded-size + idx (:: @ map (n/% size) r.nat) + array (|> (r.array size r.nat) + (r.filter (|>> @.to-list (list.any? n/odd?)))) + #let [value (maybe.assume (@.read idx array))]] + ($_ seq + (test "Shouldn't be able to find a value in an unoccupied cell." + (case (@.read idx (@.delete idx array)) + (#.Some _) false + #.None true)) + (test "You should be able to access values put into the array." + (case (@.read idx (@.write idx value array)) + (#.Some value') (n/= value' value) + #.None false)) + (test "All cells should be occupied on a full array." + (and (n/= size (@.occupied array)) + (n/= +0 (@.vacant array)))) + (test "Filtering mutates the array to remove invalid values." + (exec (@.filter n/even? array) + (and (n/< size (@.occupied array)) + (n/> +0 (@.vacant array)) + (n/= size (n/+ (@.occupied array) + (@.vacant array)))))) + )))) + +(context: "Finding values." + (<| (times +100) + (do @ + [size bounded-size + array (|> (r.array size r.nat) + (r.filter (|>> @.to-list (list.any? n/even?))))] + ($_ seq + (test "Can find values inside arrays." + (|> (@.find n/even? array) + (case> (#.Some _) true + #.None false))) + (test "Can find values inside arrays (with access to indices)." + (|> (@.find+ (function (_ idx n) + (and (n/even? n) + (n/< size idx))) + array) + (case> (#.Some _) true + #.None false))))))) + +(context: "Functor" + (<| (times +100) + (do @ + [size bounded-size + array (r.array size r.nat)] + (let [(^open) @.Functor + (^open) (@.Equivalence number.Equivalence)] + ($_ seq + (test "Functor shouldn't alter original array." + (let [copy (map id array)] + (and (= array copy) + (not (is? array copy))))) + (test "Functor should go over all available array elements." + (let [there (map inc array) + back-again (map dec there)] + (and (not (= array there)) + (= array back-again))))))))) + +(context: "Monoid" + (<| (times +100) + (do @ + [sizeL bounded-size + sizeR bounded-size + left (r.array sizeL r.nat) + right (r.array sizeR r.nat) + #let [(^open) @.Monoid + (^open) (@.Equivalence number.Equivalence) + fusion (compose left right)]] + ($_ seq + (test "Appending two arrays should produce a new one twice as large." + (n/= (n/+ sizeL sizeR) (@.size fusion))) + (test "First elements of fused array should equal the first array." + (|> (: (Array Nat) + (@.new sizeL)) + (@.copy sizeL +0 fusion +0) + (= left))) + (test "Last elements of fused array should equal the second array." + (|> (: (Array Nat) + (@.new sizeR)) + (@.copy sizeR sizeL fusion +0) + (= right))) + )))) diff --git a/stdlib/test/test/lux/data/collection/bits.lux b/stdlib/test/test/lux/data/collection/bits.lux new file mode 100644 index 000000000..bef677ad5 --- /dev/null +++ b/stdlib/test/test/lux/data/collection/bits.lux @@ -0,0 +1,80 @@ +(.module: + lux + (lux (control [monad #+ do] + [predicate]) + (data (collection ["/" bits])) + ["r" math/random]) + lux/test + (test (lux (control ["_eq" equivalence])))) + +(def: (size min max) + (-> Nat Nat (r.Random Nat)) + (|> r.nat + (:: r.Monad map (|>> (n/% max) (n/max min))))) + +(def: bits + (r.Random /.Bits) + (do r.Monad + [size (size +1 +1_000) + idx (|> r.nat (:: @ map (n/% size)))] + (wrap (|> /.empty (/.set idx))))) + +(context: "Bits." + (<| (times +100) + (do @ + [size (size +1 +1_000) + idx (|> r.nat (:: @ map (n/% size))) + sample bits] + ($_ seq + (test "Can set individual bits." + (and (|> /.empty (/.get idx) not) + (|> /.empty (/.set idx) (/.get idx)))) + (test "Can clear individual bits." + (|> /.empty (/.set idx) (/.clear idx) (/.get idx) not)) + (test "Can flip individual bits." + (and (|> /.empty (/.flip idx) (/.get idx)) + (|> /.empty (/.flip idx) (/.flip idx) (/.get idx) not))) + + (test "Bits (only) grow when (and as much as) necessary." + (and (n/= +0 (/.capacity /.empty)) + (|> /.empty (/.set idx) /.capacity + (n/- idx) + (predicate.union (n/>= +0) + (n/< /.chunk-size))))) + (test "Bits (must) shrink when (and as much as) possible." + (let [grown (/.flip idx /.empty)] + (and (n/> +0 (/.capacity grown)) + (is? /.empty (/.flip idx grown))))) + + (test "Intersection can be detected when there are set bits in common." + (and (not (/.intersects? /.empty + /.empty)) + (/.intersects? (/.set idx /.empty) + (/.set idx /.empty)) + (not (/.intersects? (/.set (inc idx) /.empty) + (/.set idx /.empty))))) + (test "Cannot intersect with one's opposite." + (not (/.intersects? sample (/.not sample)))) + + (test "'and' with oneself changes nothing" + (:: /.Equivalence = sample (/.and sample sample))) + (test "'and' with one's opposite yields the empty bit-set." + (is? /.empty (/.and sample (/.not sample)))) + + (test "'or' with one's opposite fully saturates a bit-set." + (n/= (/.size (/.or sample (/.not sample))) + (/.capacity sample))) + + (test "'xor' with oneself yields the empty bit-set." + (is? /.empty (/.xor sample sample))) + (test "'xor' with one's opposite fully saturates a bit-set." + (n/= (/.size (/.xor sample (/.not sample))) + (/.capacity sample))) + + (test "Double negation results in original bit-set." + (:: /.Equivalence = sample (/.not (/.not sample)))) + (test "Negation does not affect the empty bit-set." + (is? /.empty (/.not /.empty))) + + (_eq.spec /.Equivalence ..bits) + )))) diff --git a/stdlib/test/test/lux/data/collection/dictionary.lux b/stdlib/test/test/lux/data/collection/dictionary.lux new file mode 100644 index 000000000..5b18c863f --- /dev/null +++ b/stdlib/test/test/lux/data/collection/dictionary.lux @@ -0,0 +1,128 @@ +(.module: + lux + (lux [io] + (control [monad #+ do Monad] + ["eq" equivalence]) + (data [text] + text/format + [number] + [maybe] + (collection ["&" 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/collection/dictionary/ordered.lux b/stdlib/test/test/lux/data/collection/dictionary/ordered.lux new file mode 100644 index 000000000..a5b680037 --- /dev/null +++ b/stdlib/test/test/lux/data/collection/dictionary/ordered.lux @@ -0,0 +1,88 @@ +(.module: + lux + (lux [io] + (control [monad #+ do Monad] + [equivalence #+ Equivalence]) + (data [product] + [number] + (collection ["s" set] + ["dict" dictionary] + (dictionary ["&" ordered]) + [list "L/" Functor])) + ["r" math/random]) + lux/test) + +(context: "Dictionary" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (n/% +100))) + keys (r.set number.Hash size r.nat) + values (r.set number.Hash size r.nat) + extra-key (|> r.nat (r.filter (|>> (s.member? keys) not))) + extra-value r.nat + #let [pairs (list.zip2 (s.to-list keys) + (s.to-list values)) + sample (&.from-list number.Order pairs) + sorted-pairs (list.sort (function (_ [left _] [right _]) + (n/< left right)) + pairs) + sorted-values (L/map product.right sorted-pairs) + (^open "&/") (&.Equivalence number.Equivalence)]] + ($_ seq + (test "Can query the size of a dictionary." + (n/= size (&.size sample))) + + (test "Can query value for minimum key." + (case [(&.min sample) (list.head sorted-values)] + [#.None #.None] + true + + [(#.Some reference) (#.Some sample)] + (n/= reference sample) + + _ + false)) + + (test "Can query value for maximum key." + (case [(&.max sample) (list.last sorted-values)] + [#.None #.None] + true + + [(#.Some reference) (#.Some sample)] + (n/= reference sample) + + _ + false)) + + (test "Converting dictionaries to/from lists cannot change their values." + (|> sample + &.entries (&.from-list number.Order) + (&/= sample))) + + (test "Order is preserved." + (let [(^open "L/") (list.Equivalence (: (Equivalence [Nat Nat]) + (function (_ [kr vr] [ks vs]) + (and (n/= kr ks) + (n/= vr vs)))))] + (L/= (&.entries sample) + sorted-pairs))) + + (test "Every key in a dictionary must be identifiable." + (list.every? (function (_ key) (&.contains? key sample)) + (&.keys sample))) + + (test "Can add and remove elements in a dictionary." + (and (not (&.contains? extra-key sample)) + (let [sample' (&.put extra-key extra-value sample) + sample'' (&.remove extra-key sample')] + (and (&.contains? extra-key sample') + (not (&.contains? extra-key sample'')) + (case [(&.get extra-key sample') + (&.get extra-key sample'')] + [(#.Some found) #.None] + (n/= extra-value found) + + _ + false))) + )) + )))) diff --git a/stdlib/test/test/lux/data/collection/list.lux b/stdlib/test/test/lux/data/collection/list.lux new file mode 100644 index 000000000..90d3cfc67 --- /dev/null +++ b/stdlib/test/test/lux/data/collection/list.lux @@ -0,0 +1,235 @@ +(.module: + lux + (lux [io] + (control [monad #+ do Monad] + pipe) + (data (collection ["&" list]) + [number] + [bool] + [product] + [maybe]) + ["r" math/random]) + lux/test) + +(def: bounded-size + (r.Random Nat) + (|> r.nat + (:: r.Monad map (|>> (n/% +100) (n/+ +10))))) + +(context: "Lists: Part 1" + (<| (times +100) + (do @ + [size bounded-size + idx (:: @ map (n/% size) r.nat) + sample (r.list size r.nat) + other-size bounded-size + other-sample (r.list other-size r.nat) + separator r.nat + #let [(^open) (&.Equivalence number.Equivalence) + (^open "&/") &.Functor]] + ($_ seq + (test "The size function should correctly portray the size of the list." + (n/= size (&.size sample))) + + (test "The repeat function should produce as many elements as asked of it." + (n/= size (&.size (&.repeat size [])))) + + (test "Reversing a list does not change it's size." + (n/= (&.size sample) + (&.size (&.reverse sample)))) + + (test "Reversing a list twice results in the original list." + (= sample + (&.reverse (&.reverse sample)))) + + (test "Filtering by a predicate and its complement should result in a number of elements equal to the original list." + (and (n/= (&.size sample) + (n/+ (&.size (&.filter n/even? sample)) + (&.size (&.filter (bool.complement n/even?) sample)))) + (let [[plus minus] (&.partition n/even? sample)] + (n/= (&.size sample) + (n/+ (&.size plus) + (&.size minus)))))) + + (test "If every element in a list satisfies a predicate, there can't be any that satisfy its complement." + (if (&.every? n/even? sample) + (and (not (&.any? (bool.complement n/even?) sample)) + (&.empty? (&.filter (bool.complement n/even?) sample))) + (&.any? (bool.complement n/even?) sample))) + + (test "Any element of the list can be considered its member." + (let [elem (maybe.assume (&.nth idx sample))] + (&.member? number.Equivalence sample elem))) + )))) + +(context: "Lists: Part 2" + (<| (times +100) + (do @ + [size bounded-size + idx (:: @ map (n/% size) r.nat) + sample (r.list size r.nat) + other-size bounded-size + other-sample (r.list other-size r.nat) + separator r.nat + #let [(^open) (&.Equivalence number.Equivalence) + (^open "&/") &.Functor]] + ($_ seq + (test "Appending the head and the tail should yield the original list." + (let [head (maybe.assume (&.head sample)) + tail (maybe.assume (&.tail sample))] + (= sample + (#.Cons head tail)))) + + (test "Appending the inits and the last should yield the original list." + (let [(^open) &.Monoid + inits (maybe.assume (&.inits sample)) + last (maybe.assume (&.last sample))] + (= sample + (compose inits (list last))))) + + (test "Functor should go over every element of the list." + (let [(^open) &.Functor + there (map inc sample) + back-again (map dec there)] + (and (not (= sample there)) + (= sample back-again)))) + + (test "Splitting a list into chunks and re-appending them should yield the original list." + (let [(^open) &.Monoid + [left right] (&.split idx sample) + [left' right'] (&.split-with n/even? sample)] + (and (= sample + (compose left right)) + (= sample + (compose left' right')) + (= sample + (compose (&.take idx sample) + (&.drop idx sample))) + (= sample + (compose (&.take-while n/even? sample) + (&.drop-while n/even? sample))) + ))) + + (test "Segmenting the list in pairs should yield as many elements as N/2." + (n/= (n// +2 size) + (&.size (&.as-pairs sample)))) + + (test "Sorting a list shouldn't change it's size." + (n/= (&.size sample) + (&.size (&.sort n/< sample)))) + + (test "Sorting a list with one order should yield the reverse of sorting it with the opposite order." + (= (&.sort n/< sample) + (&.reverse (&.sort n/> sample)))) + )))) + +(context: "Lists: Part 3" + (<| (times +100) + (do @ + [size bounded-size + idx (:: @ map (n/% size) r.nat) + sample (r.list size r.nat) + other-size bounded-size + other-sample (r.list other-size r.nat) + separator r.nat + from (|> r.nat (:: @ map (n/% +10))) + to (|> r.nat (:: @ map (n/% +10))) + #let [(^open) (&.Equivalence number.Equivalence) + (^open "&/") &.Functor]] + ($_ seq + (test "If you zip 2 lists, the result's size will be that of the smaller list." + (n/= (&.size (&.zip2 sample other-sample)) + (n/min (&.size sample) (&.size other-sample)))) + + (test "I can pair-up elements of a list in order." + (let [(^open) &.Functor + zipped (&.zip2 sample other-sample) + num-zipper (&.size zipped)] + (and (|> zipped (map product.left) (= (&.take num-zipper sample))) + (|> zipped (map product.right) (= (&.take num-zipper other-sample)))))) + + (test "You can generate indices for any size, and they will be in ascending order." + (let [(^open) &.Functor + indices (&.indices size)] + (and (n/= size (&.size indices)) + (= indices + (&.sort n/< indices)) + (&.every? (n/= (dec size)) + (&.zip2-with n/+ + indices + (&.sort n/> indices))) + ))) + + (test "The 'interpose' function places a value between every member of a list." + (let [(^open) &.Functor + sample+ (&.interpose separator sample)] + (and (n/= (|> size (n/* +2) dec) + (&.size sample+)) + (|> sample+ &.as-pairs (map product.right) (&.every? (n/= separator)))))) + + (test "List append is a monoid." + (let [(^open) &.Monoid] + (and (= sample (compose identity sample)) + (= sample (compose sample identity)) + (let [[left right] (&.split size (compose sample other-sample))] + (and (= sample left) + (= other-sample right)))))) + + (test "Apply allows you to create singleton lists, and apply lists of functions to lists of values." + (let [(^open) &.Monad + (^open) &.Apply] + (and (= (list separator) (wrap separator)) + (= (map inc sample) + (apply (wrap inc) sample))))) + + (test "List concatenation is a monad." + (let [(^open) &.Monad + (^open) &.Monoid] + (= (compose sample other-sample) + (join (list sample other-sample))))) + + (test "You can find any value that satisfies some criterium, if such values exist in the list." + (case (&.find n/even? sample) + (#.Some found) + (and (n/even? found) + (&.any? n/even? sample) + (not (&.every? (bool.complement n/even?) sample))) + + #.None + (and (not (&.any? n/even? sample)) + (&.every? (bool.complement n/even?) sample)))) + + (test "You can iteratively construct a list, generating values until you're done." + (= (&.n/range +0 (dec size)) + (&.iterate (function (_ n) (if (n/< size n) (#.Some (inc n)) #.None)) + +0))) + + (test "Can enumerate all elements in a list." + (let [enum-sample (&.enumerate sample)] + (and (= (&.indices (&.size enum-sample)) + (&/map product.left enum-sample)) + (= sample + (&/map product.right enum-sample))))) + + (test "Ranges can be constructed forward and backwards." + (and (let [(^open "list/") (&.Equivalence number.Equivalence)] + (list/= (&.n/range from to) + (&.reverse (&.n/range to from)))) + (let [(^open "list/") (&.Equivalence number.Equivalence) + from (.int from) + to (.int to)] + (list/= (&.i/range from to) + (&.reverse (&.i/range to from)))))) + )))) + +## TODO: Add again once new-luxc becomes the standard compiler. +(context: "Monad transformer" + (let [lift (&.lift io.Monad) + (^open "io/") io.Monad] + (test "Can add list functionality to any monad." + (|> (io.run (do (&.ListT io.Monad) + [a (lift (io/wrap 123)) + b (wrap 456)] + (wrap (i/+ a b)))) + (case> (^ (list 579)) true + _ false))))) diff --git a/stdlib/test/test/lux/data/collection/queue.lux b/stdlib/test/test/lux/data/collection/queue.lux new file mode 100644 index 000000000..8160c9d82 --- /dev/null +++ b/stdlib/test/test/lux/data/collection/queue.lux @@ -0,0 +1,51 @@ +(.module: + lux + (lux [io] + (control [monad #+ do Monad]) + (data (collection ["&" queue]) + [number]) + ["r" math/random]) + lux/test) + +(context: "Queues" + (<| (times +100) + (do @ + [size (:: @ map (n/% +100) r.nat) + sample (r.queue size r.nat) + non-member (|> r.nat + (r.filter (|>> (&.member? number.Equivalence sample) not)))] + ($_ seq + (test "I can query the size of a queue (and empty queues have size 0)." + (if (n/= +0 size) + (&.empty? sample) + (n/= size (&.size sample)))) + + (test "Enqueueing and dequeing affects the size of queues." + (and (n/= (inc size) (&.size (&.push non-member sample))) + (or (&.empty? sample) + (n/= (dec size) (&.size (&.pop sample)))) + (n/= size (&.size (&.pop (&.push non-member sample)))))) + + (test "Transforming to/from list can't change the queue." + (let [(^open "&/") (&.Equivalence number.Equivalence)] + (|> sample + &.to-list &.from-list + (&/= sample)))) + + (test "I can always peek at a non-empty queue." + (case (&.peek sample) + #.None (&.empty? sample) + (#.Some _) true)) + + (test "I can query whether an element belongs to a queue." + (and (not (&.member? number.Equivalence sample non-member)) + (&.member? number.Equivalence (&.push non-member sample) + non-member) + (case (&.peek sample) + #.None + (&.empty? sample) + + (#.Some first) + (and (&.member? number.Equivalence sample first) + (not (&.member? number.Equivalence (&.pop sample) first)))))) + )))) diff --git a/stdlib/test/test/lux/data/collection/queue/priority.lux b/stdlib/test/test/lux/data/collection/queue/priority.lux new file mode 100644 index 000000000..d1880a735 --- /dev/null +++ b/stdlib/test/test/lux/data/collection/queue/priority.lux @@ -0,0 +1,52 @@ +(.module: + lux + (lux [io] + (control [monad #+ do Monad]) + (data (collection (queue ["&" priority])) + [number] + [maybe]) + ["r" math/random]) + lux/test) + +(def: (gen-queue size) + (-> Nat (r.Random (&.Queue Nat))) + (do r.Monad + [inputs (r.list size r.nat)] + (monad.fold @ (function (_ head tail) + (do @ + [priority r.nat] + (wrap (&.push priority head tail)))) + &.empty + inputs))) + +(context: "Queues" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (n/% +100))) + sample (gen-queue size) + non-member-priority r.nat + non-member (|> r.nat (r.filter (|>> (&.member? number.Equivalence sample) not)))] + ($_ seq + (test "I can query the size of a queue (and empty queues have size 0)." + (n/= size (&.size sample))) + + (test "Enqueueing and dequeing affects the size of queues." + (and (n/= (inc size) + (&.size (&.push non-member-priority non-member sample))) + (or (n/= +0 (&.size sample)) + (n/= (dec size) + (&.size (&.pop sample)))))) + + (test "I can query whether an element belongs to a queue." + (and (and (not (&.member? number.Equivalence sample non-member)) + (&.member? number.Equivalence + (&.push non-member-priority non-member sample) + non-member)) + (or (n/= +0 (&.size sample)) + (and (&.member? number.Equivalence + sample + (maybe.assume (&.peek sample))) + (not (&.member? number.Equivalence + (&.pop sample) + (maybe.assume (&.peek sample)))))))) + )))) diff --git a/stdlib/test/test/lux/data/collection/row.lux b/stdlib/test/test/lux/data/collection/row.lux new file mode 100644 index 000000000..709d8b44e --- /dev/null +++ b/stdlib/test/test/lux/data/collection/row.lux @@ -0,0 +1,73 @@ +(.module: + lux + (lux [io] + (control [monad #+ do Monad]) + (data (collection ["&" row] + [list "list/" Fold]) + [number] + [maybe]) + ["r" math/random]) + lux/test) + +(context: "Rows" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% +100) (n/max +1)))) + idx (|> r.nat (:: @ map (n/% size))) + sample (r.row size r.nat) + other-sample (r.row size r.nat) + non-member (|> r.nat (r.filter (|>> (&.member? number.Equivalence sample) not))) + #let [(^open "&/") (&.Equivalence number.Equivalence) + (^open "&/") &.Apply + (^open "&/") &.Monad + (^open "&/") &.Fold + (^open "&/") &.Monoid]] + ($_ seq + (test "Can query size of row." + (if (&.empty? sample) + (and (n/= +0 size) + (n/= +0 (&.size sample))) + (n/= size (&.size sample)))) + + (test "Can add and remove elements to rows." + (and (n/= (inc size) (&.size (&.add non-member sample))) + (n/= (dec size) (&.size (&.pop sample))))) + + (test "Can put and get elements into rows." + (|> sample + (&.put idx non-member) + (&.nth idx) + maybe.assume + (is? non-member))) + + (test "Can update elements of rows." + (|> sample + (&.put idx non-member) (&.update idx inc) + (&.nth idx) maybe.assume + (n/= (inc non-member)))) + + (test "Can safely transform to/from lists." + (|> sample &.to-list &.from-list (&/= sample))) + + (test "Can identify members of a row." + (and (not (&.member? number.Equivalence sample non-member)) + (&.member? number.Equivalence (&.add non-member sample) non-member))) + + (test "Can fold over elements of row." + (n/= (list/fold n/+ +0 (&.to-list sample)) + (&/fold n/+ +0 sample))) + + (test "Functor goes over every element." + (let [there (&/map inc sample) + back-again (&/map dec there)] + (and (not (&/= sample there)) + (&/= sample back-again)))) + + (test "Apply allows you to create singleton rows, and apply rows of functions to rows of values." + (and (&/= (&.row non-member) (&/wrap non-member)) + (&/= (&/map inc sample) (&/apply (&/wrap inc) sample)))) + + (test "Row concatenation is a monad." + (&/= (&/compose sample other-sample) + (&/join (&.row sample other-sample)))) + )))) diff --git a/stdlib/test/test/lux/data/collection/sequence.lux b/stdlib/test/test/lux/data/collection/sequence.lux new file mode 100644 index 000000000..a168d749f --- /dev/null +++ b/stdlib/test/test/lux/data/collection/sequence.lux @@ -0,0 +1,101 @@ +(.module: + lux + (lux [io] + (control [monad #+ do Monad] + comonad) + (data [maybe] + [text "Text/" Monoid] + text/format + (collection [list] + ["&" sequence]) + [number "Nat/" Codec]) + ["r" math/random]) + lux/test) + +(context: "Sequences" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% +100) (n/max +2)))) + offset (|> r.nat (:: @ map (n/% +100))) + factor (|> r.nat (:: @ map (|>> (n/% +100) (n/max +2)))) + elem r.nat + cycle-seed (r.list size r.nat) + cycle-sample-idx (|> r.nat (:: @ map (n/% +1000))) + #let [(^open "List/") (list.Equivalence number.Equivalence) + sample0 (&.iterate inc +0) + sample1 (&.iterate inc offset)]] + ($_ seq + (test "Can move along a sequence and take slices off it." + (and (and (List/= (list.n/range +0 (dec size)) + (&.take size sample0)) + (List/= (list.n/range offset (dec (n/+ offset size))) + (&.take size (&.drop offset sample0))) + (let [[drops takes] (&.split size sample0)] + (and (List/= (list.n/range +0 (dec size)) + drops) + (List/= (list.n/range size (dec (n/* +2 size))) + (&.take size takes))))) + (and (List/= (list.n/range +0 (dec size)) + (&.take-while (n/< size) sample0)) + (List/= (list.n/range offset (dec (n/+ offset size))) + (&.take-while (n/< (n/+ offset size)) + (&.drop-while (n/< offset) sample0))) + (let [[drops takes] (&.split-while (n/< size) sample0)] + (and (List/= (list.n/range +0 (dec size)) + drops) + (List/= (list.n/range size (dec (n/* +2 size))) + (&.take-while (n/< (n/* +2 size)) takes))))) + )) + + (test "Can repeat any element and infinite number of times." + (n/= elem (&.nth offset (&.repeat elem)))) + + (test "Can obtain the head & tail of a sequence." + (and (n/= offset (&.head sample1)) + (List/= (list.n/range (inc offset) (n/+ offset size)) + (&.take size (&.tail sample1))))) + + (test "Can filter sequences." + (and (n/= (n/* +2 offset) + (&.nth offset + (&.filter n/even? sample0))) + (let [[evens odds] (&.partition n/even? (&.iterate inc +0))] + (and (n/= (n/* +2 offset) + (&.nth offset evens)) + (n/= (inc (n/* +2 offset)) + (&.nth offset odds)))))) + + (test "Functor goes over 'all' elements in a sequence." + (let [(^open "&/") &.Functor + there (&/map (n/* factor) sample0) + back-again (&/map (n// factor) there)] + (and (not (List/= (&.take size sample0) + (&.take size there))) + (List/= (&.take size sample0) + (&.take size back-again))))) + + (test "CoMonad produces a value for every element in a sequence." + (let [(^open "&/") &.Functor] + (List/= (&.take size (&/map (n/* factor) sample1)) + (&.take size + (be &.CoMonad + [inputs sample1] + (n/* factor (&.head inputs))))))) + + (test "'unfold' generalizes 'iterate'." + (let [(^open "&/") &.Functor + (^open "List/") (list.Equivalence text.Equivalence)] + (List/= (&.take size + (&/map Nat/encode (&.iterate inc offset))) + (&.take size + (&.unfold (function (_ n) [(inc n) (Nat/encode n)]) + offset))))) + + (test "Can cycle over the same elements as an infinite sequence." + (|> (&.cycle cycle-seed) + maybe.assume + (&.nth cycle-sample-idx) + (n/= (|> cycle-seed + (list.nth (n/% size cycle-sample-idx)) + maybe.assume)))) + )))) diff --git a/stdlib/test/test/lux/data/collection/set.lux b/stdlib/test/test/lux/data/collection/set.lux new file mode 100644 index 000000000..346f1a39b --- /dev/null +++ b/stdlib/test/test/lux/data/collection/set.lux @@ -0,0 +1,64 @@ +(.module: + lux + (lux [io] + (control [monad #+ do Monad]) + (data (collection ["&" 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/collection/set/ordered.lux b/stdlib/test/test/lux/data/collection/set/ordered.lux new file mode 100644 index 000000000..455ea5cb2 --- /dev/null +++ b/stdlib/test/test/lux/data/collection/set/ordered.lux @@ -0,0 +1,94 @@ +(.module: + lux + (lux [io] + (control [monad #+ do Monad]) + (data (collection [set] + (set ["&" ordered]) + [list "" Fold]) + [number] + text/format) + ["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 + 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) + sortedL (list.sort n/< listL) + minL (list.head sortedL) + maxL (list.last sortedL)]] + ($_ seq + (test "I can query the size of a set." + (n/= sizeL (&.size setL))) + + (test "Can query minimum value." + (case [(&.min setL) minL] + [#.None #.None] + true + + [(#.Some reference) (#.Some sample)] + (n/= reference sample) + + _ + false)) + + (test "Can query maximum value." + (case [(&.max setL) maxL] + [#.None #.None] + true + + [(#.Some reference) (#.Some sample)] + (n/= reference sample) + + _ + false)) + + (test "Converting sets to/from lists can't change their values." + (|> setL + &.to-list (&.from-list number.Order) + (&/= setL))) + + (test "Order is preserved." + (let [listL (&.to-list setL) + (^open "L/") (list.Equivalence number.Equivalence)] + (L/= listL + (list.sort n/< listL)))) + + (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.Order) + setL))) + + (test "Intersection with the empty set results in the empty set." + (let [empty-set (&.new number.Order)] + (&/= 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." + (list.every? (&.member? setL) (&.to-list setL))) + )))) diff --git a/stdlib/test/test/lux/data/collection/stack.lux b/stdlib/test/test/lux/data/collection/stack.lux new file mode 100644 index 000000000..c4e5f58a3 --- /dev/null +++ b/stdlib/test/test/lux/data/collection/stack.lux @@ -0,0 +1,45 @@ +(.module: + lux + (lux [io] + (control [monad #+ do Monad]) + (data (collection ["&" stack] + [list "" Fold]) + [number] + [maybe]) + ["r" math/random]) + lux/test) + +(def: gen-nat + (r.Random Nat) + (|> r.nat + (:: r.Monad map (n/% +100)))) + +(context: "Stacks" + (<| (times +100) + (do @ + [size gen-nat + sample (r.stack size gen-nat) + new-top gen-nat] + ($_ seq + (test "Can query the size of a stack." + (n/= size (&.size sample))) + + (test "Can peek inside non-empty stacks." + (case (&.peek sample) + #.None (&.empty? sample) + (#.Some _) (not (&.empty? sample)))) + + (test "Popping empty stacks doesn't change anything. + But, if they're non-empty, the top of the stack is removed." + (let [sample' (&.pop sample)] + (or (n/= (&.size sample) (inc (&.size sample'))) + (and (&.empty? sample) (&.empty? sample'))) + )) + + (test "Pushing onto a stack always increases it by 1, adding a new value at the top." + (and (is? sample + (&.pop (&.push new-top sample))) + (n/= (inc (&.size sample)) (&.size (&.push new-top sample))) + (|> (&.push new-top sample) &.peek maybe.assume + (is? new-top)))) + )))) diff --git a/stdlib/test/test/lux/data/collection/tree/rose.lux b/stdlib/test/test/lux/data/collection/tree/rose.lux new file mode 100644 index 000000000..b83c3e675 --- /dev/null +++ b/stdlib/test/test/lux/data/collection/tree/rose.lux @@ -0,0 +1,47 @@ +(.module: + lux + (lux [io] + (control [monad #+ do Monad]) + (data [product] + [number] + [text "T/" Equivalence] + text/format + (collection (tree ["&" rose]) + [list "L/" Monad Fold])) + ["r" math/random]) + lux/test) + +(def: gen-tree + (r.Random [Nat (&.Tree Nat)]) + (r.rec + (function (_ gen-tree) + (r.either (:: r.Monad map (|>> &.leaf [+1]) r.nat) + (do r.Monad + [value r.nat + num-children (|> r.nat (:: @ map (n/% +3))) + children' (r.list num-children gen-tree) + #let [size' (L/fold n/+ +0 (L/map product.left children')) + children (L/map product.right children')]] + (wrap [(inc size') + (&.branch value children)])) + )))) + +(context: "Trees" + (<| (times +100) + (do @ + [[size sample] gen-tree + #let [(^open "&/") (&.Equivalence number.Equivalence) + (^open "&/") &.Fold + concat (function (_ addition partial) (format partial (%n addition)))]] + ($_ seq + (test "Can compare trees for equivalence." + (&/= sample sample)) + + (test "Can flatten a tree to get all the nodes as a flat tree." + (n/= size + (list.size (&.flatten sample)))) + + (test "Can fold trees." + (T/= (&/fold concat "" sample) + (L/fold concat "" (&.flatten sample)))) + )))) diff --git a/stdlib/test/test/lux/data/collection/tree/rose/zipper.lux b/stdlib/test/test/lux/data/collection/tree/rose/zipper.lux new file mode 100644 index 000000000..3a1a9ed7a --- /dev/null +++ b/stdlib/test/test/lux/data/collection/tree/rose/zipper.lux @@ -0,0 +1,124 @@ +(.module: + lux + (lux [io] + (control [monad #+ do Monad] + pipe) + (data (collection [list "list/" Fold Functor] + (tree [rose] + (rose ["&" zipper]))) + [text] + text/format + [number] + [maybe]) + ["r" math/random]) + lux/test) + +(def: gen-tree + (r.Random (rose.Tree Nat)) + (r.rec (function (_ gen-tree) + (do r.Monad + ## Each branch can have, at most, 1 child. + [size (|> r.nat (:: @ map (n/% +2)))] + (r.seq r.nat + (r.list size gen-tree)))))) + +(def: (to-end zipper) + (All [a] (-> (&.Zipper a) (&.Zipper a))) + (loop [zipper zipper] + (if (&.end? zipper) + zipper + (recur (&.next zipper))))) + +(context: "Zippers." + (<| (times +100) + (do @ + [sample gen-tree + new-val r.nat + pre-val r.nat + post-val r.nat + #let [(^open "tree/") (rose.Equivalence number.Equivalence) + (^open "list/") (list.Equivalence number.Equivalence)]] + ($_ seq + (test "Trees can be converted to/from zippers." + (|> sample + &.zip &.unzip + (tree/= sample))) + + (test "Creating a zipper gives you a root node." + (|> sample &.zip &.root?)) + + (test "Can move down inside branches. Can move up from lower nodes." + (let [zipper (&.zip sample)] + (if (&.branch? zipper) + (let [child (|> zipper &.down)] + (and (not (tree/= sample (&.unzip child))) + (|> child &.up (is? zipper) not) + (|> child &.root (is? zipper) not))) + (and (&.leaf? zipper) + (|> zipper (&.prepend-child new-val) &.branch?))))) + + (test "Can prepend and append children." + (let [zipper (&.zip sample)] + (if (&.branch? zipper) + (let [mid-val (|> zipper &.down &.value) + zipper (|> zipper + (&.prepend-child pre-val) + (&.append-child post-val))] + (and (|> zipper &.down &.value (is? pre-val)) + (|> zipper &.down &.right &.value (is? mid-val)) + (|> zipper &.down &.right &.right &.value (is? post-val)) + (|> zipper &.down &.rightmost &.leftmost &.value (is? pre-val)) + (|> zipper &.down &.right &.left &.value (is? pre-val)) + (|> zipper &.down &.rightmost &.value (is? post-val)))) + true))) + + (test "Can insert children around a node (unless it's root)." + (let [zipper (&.zip sample)] + (if (&.branch? zipper) + (let [mid-val (|> zipper &.down &.value) + zipper (|> zipper + &.down + (&.insert-left pre-val) + maybe.assume + (&.insert-right post-val) + maybe.assume + &.up)] + (and (|> zipper &.down &.value (is? pre-val)) + (|> zipper &.down &.right &.value (is? mid-val)) + (|> zipper &.down &.right &.right &.value (is? post-val)) + (|> zipper &.down &.rightmost &.leftmost &.value (is? pre-val)) + (|> zipper &.down &.right &.left &.value (is? pre-val)) + (|> zipper &.down &.rightmost &.value (is? post-val)))) + (and (|> zipper (&.insert-left pre-val) (case> (#.Some _) false + #.None true)) + (|> zipper (&.insert-right post-val) (case> (#.Some _) false + #.None true)))))) + + (test "Can set and update the value of a node." + (|> sample &.zip (&.set new-val) &.value (n/= new-val))) + + (test "Zipper traversal follows the outline of the tree depth-first." + (list/= (rose.flatten sample) + (loop [zipper (&.zip sample)] + (if (&.end? zipper) + (list (&.value zipper)) + (#.Cons (&.value zipper) + (recur (&.next zipper))))))) + + (test "Backwards zipper traversal yield reverse tree flatten." + (list/= (list.reverse (rose.flatten sample)) + (loop [zipper (to-end (&.zip sample))] + (if (&.root? zipper) + (list (&.value zipper)) + (#.Cons (&.value zipper) + (recur (&.prev zipper))))))) + + (test "Can remove nodes (except root nodes)." + (let [zipper (&.zip sample)] + (if (&.branch? zipper) + (and (|> zipper &.down &.root? not) + (|> zipper &.down &.remove (case> #.None false + (#.Some node) (&.root? node)))) + (|> zipper &.remove (case> #.None true + (#.Some _) false))))) + )))) diff --git a/stdlib/test/test/lux/data/format/json.lux b/stdlib/test/test/lux/data/format/json.lux index 02a82bc63..40aaf97d2 100644 --- a/stdlib/test/test/lux/data/format/json.lux +++ b/stdlib/test/test/lux/data/format/json.lux @@ -13,9 +13,9 @@ [maybe] [number] (format ["@" json]) - (coll [row #+ row] - ["d" dictionary] - [list])) + (collection [row #+ row] + ["d" dictionary] + [list])) [macro #+ with-gensyms] (macro [code] [syntax #+ syntax:] diff --git a/stdlib/test/test/lux/data/format/xml.lux b/stdlib/test/test/lux/data/format/xml.lux index dd82c2e14..a6f57d6b1 100644 --- a/stdlib/test/test/lux/data/format/xml.lux +++ b/stdlib/test/test/lux/data/format/xml.lux @@ -10,8 +10,8 @@ ["E" error] [maybe] (format ["&" xml]) - (coll ["dict" dictionary] - [list "list/" Functor])) + (collection ["dict" dictionary] + [list "list/" Functor])) ["r" math/random "r/" Monad] test) ) diff --git a/stdlib/test/test/lux/data/number/complex.lux b/stdlib/test/test/lux/data/number/complex.lux index 6219eedcc..d75cbc428 100644 --- a/stdlib/test/test/lux/data/number/complex.lux +++ b/stdlib/test/test/lux/data/number/complex.lux @@ -7,7 +7,7 @@ [number "frac/" Number] ["&" number/complex] text/format - (coll [list "list/" Functor])) + (collection [list "list/" Functor])) [math] ["r" math/random]) lux/test) diff --git a/stdlib/test/test/lux/data/sum.lux b/stdlib/test/test/lux/data/sum.lux index 47e68e220..6ef7ce2bc 100644 --- a/stdlib/test/test/lux/data/sum.lux +++ b/stdlib/test/test/lux/data/sum.lux @@ -6,7 +6,7 @@ (data sum [text "Text/" Monoid] [number] - (coll [list]))) + (collection [list]))) lux/test) (context: "Sum operations" diff --git a/stdlib/test/test/lux/data/text.lux b/stdlib/test/test/lux/data/text.lux index 23d6f8d9b..9c5f317f8 100644 --- a/stdlib/test/test/lux/data/text.lux +++ b/stdlib/test/test/lux/data/text.lux @@ -6,7 +6,7 @@ (data ["&" text] text/format [number] - (coll [list])) + (collection [list])) ["r" math/random]) lux/test) diff --git a/stdlib/test/test/lux/data/text/lexer.lux b/stdlib/test/test/lux/data/text/lexer.lux index d1d05074f..31b9dcc40 100644 --- a/stdlib/test/test/lux/data/text/lexer.lux +++ b/stdlib/test/test/lux/data/text/lexer.lux @@ -8,7 +8,7 @@ [text "text/" Equivalence] text/format ["&" text/lexer] - (coll [list])) + (collection [list])) ["r" math/random]) lux/test) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/case.lux b/stdlib/test/test/lux/lang/compiler/analysis/case.lux index 2088a775b..5baf47fc0 100644 --- a/stdlib/test/test/lux/lang/compiler/analysis/case.lux +++ b/stdlib/test/test/lux/lang/compiler/analysis/case.lux @@ -9,8 +9,8 @@ [maybe] [text "T/" Equivalence] text/format - (coll [list "list/" Monad] - [set])) + (collection [list "list/" Monad] + [set])) ["r" math/random "r/" Monad] [macro #+ Monad] (macro [code]) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/function.lux b/stdlib/test/test/lux/lang/compiler/analysis/function.lux index b8c5d23b6..315972d28 100644 --- a/stdlib/test/test/lux/lang/compiler/analysis/function.lux +++ b/stdlib/test/test/lux/lang/compiler/analysis/function.lux @@ -8,7 +8,7 @@ [product] [text "text/" Equivalence] text/format - (coll [list "list/" Functor])) + (collection [list "list/" Functor])) ["r" math/random "r/" Monad] [macro] (macro [code]) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/procedure/common.lux b/stdlib/test/test/lux/lang/compiler/analysis/procedure/common.lux index 1651feaf9..377a48478 100644 --- a/stdlib/test/test/lux/lang/compiler/analysis/procedure/common.lux +++ b/stdlib/test/test/lux/lang/compiler/analysis/procedure/common.lux @@ -7,7 +7,7 @@ (data text/format ["e" error] [product] - (coll [array])) + (collection [array])) ["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 7aa527c93..3d3dc41d5 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 @@ -9,9 +9,9 @@ [maybe] [text "text/" Equivalence] text/format - (coll [array] - [list "list/" Fold] - ["dict" dictionary])) + (collection [array] + [list "list/" Fold] + ["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 0fc97dfbe..4b43d150f 100644 --- a/stdlib/test/test/lux/lang/compiler/analysis/structure.lux +++ b/stdlib/test/test/lux/lang/compiler/analysis/structure.lux @@ -9,8 +9,8 @@ [maybe] [text] text/format - (coll [list "list/" Functor] - [set])) + (collection [list "list/" Functor] + [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 44df282b9..008062e5e 100644 --- a/stdlib/test/test/lux/lang/compiler/synthesis/function.lux +++ b/stdlib/test/test/lux/lang/compiler/synthesis/function.lux @@ -8,9 +8,9 @@ [error] [number] text/format - (coll [list "list/" Functor Fold] - ["dict" dictionary #+ Dictionary] - [set])) + (collection [list "list/" Functor Fold] + ["dict" dictionary #+ Dictionary] + [set])) (lang ["///." reference #+ Variable "variable/" Equivalence] ["///." compiler] [".L" analysis #+ Arity Analysis] diff --git a/stdlib/test/test/lux/lang/compiler/synthesis/structure.lux b/stdlib/test/test/lux/lang/compiler/synthesis/structure.lux index eb970d3a3..b3e4d6b67 100644 --- a/stdlib/test/test/lux/lang/compiler/synthesis/structure.lux +++ b/stdlib/test/test/lux/lang/compiler/synthesis/structure.lux @@ -6,7 +6,7 @@ (data [bool "bool/" Equivalence] [product] [error] - (coll [list])) + (collection [list])) (lang ["///." compiler] [".L" analysis] ["//" synthesis #+ Synthesis] diff --git a/stdlib/test/test/lux/lang/syntax.lux b/stdlib/test/test/lux/lang/syntax.lux index f3066368e..9c2be5dd2 100644 --- a/stdlib/test/test/lux/lang/syntax.lux +++ b/stdlib/test/test/lux/lang/syntax.lux @@ -7,8 +7,8 @@ [text] (text format ["l" lexer]) - (coll [list] - ["dict" dictionary #+ Dictionary])) + (collection [list] + ["dict" dictionary #+ Dictionary])) ["r" math/random "r/" Monad] (macro [code]) (lang ["&" syntax]) diff --git a/stdlib/test/test/lux/lang/type.lux b/stdlib/test/test/lux/lang/type.lux index 26f59f7b1..0a5b42461 100644 --- a/stdlib/test/test/lux/lang/type.lux +++ b/stdlib/test/test/lux/lang/type.lux @@ -7,7 +7,7 @@ text/format [number] [maybe] - (coll [list])) + (collection [list])) ["r" math/random] (lang ["&" type])) lux/test) diff --git a/stdlib/test/test/lux/lang/type/check.lux b/stdlib/test/test/lux/lang/type/check.lux index 7a65782de..889f05bd8 100644 --- a/stdlib/test/test/lux/lang/type/check.lux +++ b/stdlib/test/test/lux/lang/type/check.lux @@ -8,8 +8,8 @@ [number] [text "text/" Monoid Equivalence] text/format - (coll [list "list/" Functor] - [set])) + (collection [list "list/" Functor] + [set])) ["r" math/random] (lang [type "type/" Equivalence] ["@" type/check])) diff --git a/stdlib/test/test/lux/macro/poly/equivalence.lux b/stdlib/test/test/lux/macro/poly/equivalence.lux index f37ad04b5..fc86cb597 100644 --- a/stdlib/test/test/lux/macro/poly/equivalence.lux +++ b/stdlib/test/test/lux/macro/poly/equivalence.lux @@ -8,7 +8,7 @@ [number "int/" Number] [text] [maybe] - (coll [list])) + (collection [list])) ["r" math/random] [macro] (macro [poly #+ derived:] diff --git a/stdlib/test/test/lux/math/logic/fuzzy.lux b/stdlib/test/test/lux/math/logic/fuzzy.lux index d4a8ced61..a73df0c37 100644 --- a/stdlib/test/test/lux/math/logic/fuzzy.lux +++ b/stdlib/test/test/lux/math/logic/fuzzy.lux @@ -2,8 +2,8 @@ lux (lux [io] (control [monad #+ do Monad]) - (data (coll [list] - [set]) + (data (collection [list] + [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 1e85636d5..a7e2f583d 100644 --- a/stdlib/test/test/lux/math/random.lux +++ b/stdlib/test/test/lux/math/random.lux @@ -4,13 +4,13 @@ (control [monad #+ do Monad]) (data [number] text/format - (coll [list] - [row] - [array] - [queue] - [stack] - [set] - ["dict" dictionary])) + (collection [list] + [row] + [array] + [queue] + [stack] + [set] + ["dict" dictionary])) (math ["r" random])) lux/test) diff --git a/stdlib/test/test/lux/type/implicit.lux b/stdlib/test/test/lux/type/implicit.lux index 30f20b073..001185a2e 100644 --- a/stdlib/test/test/lux/type/implicit.lux +++ b/stdlib/test/test/lux/type/implicit.lux @@ -6,7 +6,7 @@ [monad #+ do Monad]) (data [number] [bool "bool/" Equivalence] - (coll [list])) + (collection [list])) ["r" math/random] (type implicit)) lux/test) diff --git a/stdlib/test/test/lux/type/object/interface.lux b/stdlib/test/test/lux/type/object/interface.lux index 7e2bddcdb..e7afc5f64 100644 --- a/stdlib/test/test/lux/type/object/interface.lux +++ b/stdlib/test/test/lux/type/object/interface.lux @@ -1,6 +1,6 @@ (.module: lux - (lux (data (coll [list])) + (lux (data (collection [list])) (type (object interface)))) ## No parameters diff --git a/stdlib/test/test/lux/world/blob.lux b/stdlib/test/test/lux/world/blob.lux index 908a4050f..c0704d851 100644 --- a/stdlib/test/test/lux/world/blob.lux +++ b/stdlib/test/test/lux/world/blob.lux @@ -6,7 +6,7 @@ (data [bit] [number] ["e" error] - (coll [list])) + (collection [list])) (world ["/" blob]) ["r" math/random]) lux/test -- cgit v1.2.3