├── .gitignore ├── LICENSE ├── README.md ├── cl-data-structures-tests.asd ├── cl-data-structures.asd ├── docs ├── .gitignore ├── conventions.lore ├── dicts.lore ├── in-depth.lore ├── introduction.lore ├── key-concepts.lore ├── manual.lore ├── package.lisp ├── queues.lore ├── sequences.lore ├── sets.lore └── vars.lisp ├── run-ccl-tests.sh ├── run-sbcl-tests.sh ├── run-tests.lisp ├── source.txt ├── src ├── adapters │ ├── distance-matrix.lisp │ ├── hash-table.lisp │ ├── list.lisp │ ├── package.lisp │ ├── vector-tests.lisp │ └── vector.lisp ├── algorithms │ ├── accumulate.lisp │ ├── array-elementwise.lisp │ ├── cartesian.lisp │ ├── chain-test.lisp │ ├── chain.lisp │ ├── common-range-category.lisp │ ├── common.lisp │ ├── contains.lisp │ ├── count.lisp │ ├── cumulative-accumulate.lisp │ ├── design-notes.org │ ├── distinct-test.lisp │ ├── distinct.lisp │ ├── docstrings.lisp │ ├── enumerate.lisp │ ├── establish-special.lisp │ ├── extrema-test.lisp │ ├── extrema.lisp │ ├── extremum.lisp │ ├── filtering.lisp │ ├── first-element.lisp │ ├── flatten-lists.lisp │ ├── frequency.lisp │ ├── group-by.lisp │ ├── hash-table-elementwise.lisp │ ├── in-batches.lisp │ ├── latch.lisp │ ├── meta │ │ ├── classes.lisp │ │ ├── docstrings.lisp │ │ ├── generics.lisp │ │ ├── macros.lisp │ │ ├── meta-tests.lisp │ │ ├── methods.lisp │ │ └── notes.org │ ├── multiplex.lisp │ ├── notes.org │ ├── on-each-test.lisp │ ├── on-each.lisp │ ├── only-different.lisp │ ├── only.lisp │ ├── package.lisp │ ├── partition-if-test.lisp │ ├── partition-if.lisp │ ├── rate.lisp │ ├── repeat.lisp │ ├── reservoir-sample.lisp │ ├── restrain-size.lisp │ ├── reversed.lisp │ ├── shuffled-range.lisp │ ├── sliding-window.lisp │ ├── split-into-chunks-test.lisp │ ├── summary-test.lisp │ ├── summary.lisp │ ├── to-hash-table.lisp │ ├── to-list.lisp │ ├── to-vector.lisp │ ├── translation.lisp │ ├── with-previous-element.lisp │ ├── without-test.lisp │ ├── without.lisp │ ├── zip-test.lisp │ └── zip.lisp ├── api │ ├── auxilary.lisp │ ├── conditions.lisp │ ├── delay.lisp │ ├── docstrings.lisp │ ├── expression-tests.lisp │ ├── expression-wrapper.lisp │ ├── field.lisp │ ├── functions.lisp │ ├── fundamental-classes.lisp │ ├── generics.lisp │ ├── macros.lisp │ ├── meta-docstrings.lisp │ ├── meta.lisp │ └── trait-classes.lisp ├── aux-package.lisp ├── common │ ├── 2-3-tree │ │ ├── common.lisp │ │ ├── package.lisp │ │ └── tests.lisp │ ├── abstract │ │ ├── common.lisp │ │ └── package.lisp │ ├── content-tuple.lisp │ ├── docstrings.lisp │ ├── eager-modification-operation-status.lisp │ ├── egnat │ │ ├── classes.lisp │ │ ├── common.lisp │ │ ├── docstrings.lisp │ │ ├── generics.lisp │ │ ├── methods.lisp │ │ ├── package.lisp │ │ └── tests.lisp │ ├── hamt │ │ ├── common.lisp │ │ └── package.lisp │ ├── lazy-box.lisp │ ├── lazy-range.lisp │ ├── lsh-table.lisp │ ├── meta.lisp │ ├── modification-operation-status.lisp │ ├── package.lisp │ ├── qp-trie-tests.lisp │ ├── qp-trie.lisp │ ├── ranges.lisp │ ├── rrb │ │ ├── common.lisp │ │ ├── notes.org │ │ └── package.lisp │ ├── sequence-window-tests.lisp │ ├── sequence-window.lisp │ └── skip-list │ │ ├── common.lisp │ │ ├── package.lisp │ │ └── tests.lisp ├── composite │ ├── implementation.lisp │ ├── package.lisp │ └── tests.lisp ├── counting │ ├── apriori.lisp │ ├── docstrings.lisp │ ├── generics.lisp │ ├── internal.lisp │ ├── methods.lisp │ ├── package.lisp │ ├── tests.lisp │ └── types.lisp ├── dicts │ ├── api.lisp │ ├── common.lisp │ ├── docstrings.lisp │ ├── functional-dictionary-test-suite.lisp │ ├── hamt │ │ ├── api.lisp │ │ ├── docstrings.lisp │ │ ├── internal.lisp │ │ ├── lazy-tests.lisp │ │ ├── notes.org │ │ ├── range-test.lisp │ │ └── transactions-tests.lisp │ ├── mutable-dictionary-test-suite.lisp │ ├── notes.org │ ├── packages.lisp │ ├── skip-list │ │ ├── api.lisp │ │ └── tests.lisp │ ├── srrb │ │ ├── api.lisp │ │ ├── docstrings.lisp │ │ ├── internal.lisp │ │ ├── notes.org │ │ ├── tests.lisp │ │ └── types.lisp │ ├── trait-classes.lisp │ └── transactional-dictionary-test-suite.lisp ├── file-system │ ├── common.lisp │ ├── docstrings.lisp │ ├── find.lisp │ ├── line-by-line.lisp │ ├── notes.org │ ├── package.lisp │ ├── tokenize.lisp │ ├── unix.lisp │ └── words.lisp ├── math │ ├── absolute-value-norm.lisp │ ├── average.lisp │ ├── bootstrap.lisp │ ├── chi-squared-tests.lisp │ ├── chi-squared.lisp │ ├── co-occurence-table.lisp │ ├── docstrings.lisp │ ├── entropy.lisp │ ├── fast-map.lisp │ ├── gini-impurity.lisp │ ├── hmm.lisp │ ├── hodges-lehmann.lisp │ ├── median-absolute-deviation.lisp │ ├── moments-tests.lisp │ ├── moments.lisp │ ├── moving-average.lisp │ ├── mutual-information-tests.lisp │ ├── mutual-information.lisp │ ├── package.lisp │ ├── simple-linear-regression-tests.lisp │ ├── simple-linear-regression.lisp │ ├── standard-deviation.lisp │ ├── sum.lisp │ └── variance.lisp ├── metric-space │ ├── api.lisp │ ├── common.lisp │ ├── docstrings.lisp │ ├── egnat │ │ ├── api.lisp │ │ └── tests.lisp │ ├── packages.lisp │ └── trait-classes.lisp ├── package.lisp ├── queues │ ├── 2-3-tree │ │ ├── api.lisp │ │ ├── docstrings.lisp │ │ ├── notes.org │ │ └── tests.lisp │ ├── common.lisp │ ├── docstrings.lisp │ └── packages.lisp ├── sequences │ ├── common.lisp │ ├── packages.lisp │ └── rrb │ │ ├── api.lisp │ │ ├── docstrings.lisp │ │ └── tests.lisp ├── sets │ ├── common.lisp │ ├── docstrings.lisp │ ├── packages.lisp │ ├── qp-trie │ │ ├── api.lisp │ │ ├── docstrings.lisp │ │ └── tests.lisp │ └── skip-list │ │ ├── api.lisp │ │ ├── docstrings.lisp │ │ └── tests.lisp ├── streaming-algorithms │ ├── approximated-counts.lisp │ ├── approximated-histogram-tests.lisp │ ├── approximated-histogram.lisp │ ├── approximated-set-cardinality.lisp │ ├── approximated-top-k.lisp │ ├── bloom-filter.lisp │ ├── common.lisp │ ├── docstrings.lisp │ ├── hyperloglog.lisp │ ├── minhash.lisp │ ├── package.lisp │ ├── polynomial-hashing.lisp │ └── simhash.lisp ├── threads │ ├── buffer-range.lisp │ ├── common.lisp │ ├── contains.lisp │ ├── docstrings.lisp │ ├── package.lisp │ ├── parallel-group-by.lisp │ ├── parallel-multiplex.lisp │ ├── parallel-on-each.lisp │ └── traverse.lisp └── utils │ ├── arrays.lisp │ ├── bind.lisp │ ├── bucket-sort.lisp │ ├── cartesian.lisp │ ├── cloning.lisp │ ├── distances-tests.lisp │ ├── distances.lisp │ ├── docstrings.lisp │ ├── embedding.lisp │ ├── hashing.lisp │ ├── higher-order.lisp │ ├── lambda-lists.lisp │ ├── lazy-shuffle-tests.lisp │ ├── lazy-shuffle.lisp │ ├── lists.lisp │ ├── macros.lisp │ ├── modification-algorithms.lisp │ ├── numbers.lisp │ ├── ordered-algorithms-tests.lisp │ ├── ordered-algorithms.lisp │ ├── package.lisp │ ├── parallel-tools.lisp │ ├── trees.lisp │ ├── trivial.lisp │ └── types.lisp ├── test ├── dicts │ └── .gitignore └── files │ └── words.txt └── todo.org /.gitignore: -------------------------------------------------------------------------------- 1 | *.FASL 2 | *.fasl 3 | *.lisp-temp 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Simplified BSD License 2 | 3 | Copyright (c) 2020 Marek Kochanowicz 4 | 5 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 8 | 9 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 10 | 11 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 12 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # cl-data-structures 2 | Data structures (mutable and immutable) + stream algorithms (aggregations, group-by and so one). 3 | 4 | Docs [are elsewhere](https://sirherrbatka.github.io/cl-data-structures/main.html). 5 | -------------------------------------------------------------------------------- /docs/.gitignore: -------------------------------------------------------------------------------- 1 | ./build/* -------------------------------------------------------------------------------- /docs/conventions.lore: -------------------------------------------------------------------------------- 1 | (in-package #:cl-data-structures.documentation) 2 | (cl-lore.api.syntax:syntax 3 | cl-lore.extensions.documentation.api 4 | cl-lore.extensions.sequence-graphs.api) 5 | 6 | @begin{section} 7 | @title{Conventions} 8 | @label{Conventions} 9 | @text{Data structure types are not hidden under generic interface names (like "std::unordered_map") but are instead directly exposed to the user. Users are encouraged to read the implementation details section of this manual to decide what data structure implementation works best for the specific use case. Destructive (in the sense of capable of mutating data passed as an argument) functions follow the Scheme style of adding '!' as a suffix (so we have the generic function ADD! that is the destructive version of ADD). There are exceptions to this rule, namely SETF functions. According to the above, there should be a generic function called INSERT!, but alas, that's not the case. Instead, there is the (SETF AT) API function that does the thing one would expect from INSERT!. In addition to this difference, SETF functions are expected to return the value of the modified place, and not the container itself. Therefore, that's what (SETF AT) does to maintain a cohesive style.} 10 | @end{section} 11 | -------------------------------------------------------------------------------- /docs/introduction.lore: -------------------------------------------------------------------------------- 1 | (in-package #:cl-data-structures.documentation) 2 | (cl-lore.api.syntax:syntax 3 | cl-lore.extensions.documentation.api 4 | cl-lore.extensions.sequence-graphs.api) 5 | 6 | 7 | @begin{section} 8 | @label{cl-ds intro} 9 | @title{Overview} 10 | @text{Cl-data-structures is a portable collection of data structures and algorithms. The design goals of this library are the following:} 11 | (level [list] 12 | @item{Uniform -- Data structures that are used for a specific task should have a common interface. The user should just know how to use a dictionary, and not some specific implementation of it.} 13 | @item{Complete -- This package intends to be the definitive Common Lisp data structures collection, containing both functional and mutable structures, for every use case possible.} 14 | @item{Universal -- There should be no limitations on when this library is useful.} 15 | @item{Stable -- The API should be backward compatible. Breaking existing software is not acceptable.}) 16 | @text{To achieve these goals, the package cl-data-structures contains the common API. Various implementations of that API have their own, separate packages. Implementations are divided into few categories:} 17 | 18 | (level [list] 19 | @item{Dicts (short for dictionaries) -- Data structures that map keys to values. All in the package cl-ds.dicts.} 20 | @item{Sequences -- Data structures that are akin to cl:vector in respect that they store elements in sequential manner.}) 21 | @text{In order to minimize the amount of code required to write useful applications, a number of algorithms is provided to operate on ranges of values from those structures. Thanks to combination of layer functions and aggregation functions it is possible to write concise code akin to SQL (TODO: simple example that shows the SQL association). Due to personal intrests of the author, some statistical functions has been added in the math package.} 22 | @include{Conventions} 23 | @include{Key concepts} 24 | @end{section} 25 | -------------------------------------------------------------------------------- /docs/package.lisp: -------------------------------------------------------------------------------- 1 | (ql:quickload :cl-lore) 2 | (cl:defpackage :cl-data-structures.documentation 3 | (:use #:cl #:cl-lore 4 | #:cl-lore.api.syntax 5 | #:cl-lore.extensions.documentation.api 6 | #:cl-lore.extensions.sequence-graphs.api) 7 | (:export #:build-docs)) 8 | 9 | (cl:in-package #:cl-data-structures.documentation) 10 | 11 | 12 | (def-chunks *cl-data-structures*) 13 | (setf documentation-utils-extensions:*documentation* (documentation-utils-extensions:make-documentation-collection)) 14 | (ql:quickload :cl-data-structures) 15 | 16 | (cl-lore.api.syntax:syntax 17 | cl-lore.extensions.documentation.api 18 | cl-lore.extensions.sequence-graphs.api) 19 | 20 | (cl-lore.api.syntax:define-save-output-function 21 | build-docs 22 | (:cl-data-structures.documentation 23 | () 24 | cl-lore.mechanics: 25 | *cl-data-structures*) 26 | (:output-options (:css cl-lore.mechanics:*mechanics-html-style*)) 27 | 28 | ("vars.lisp" 29 | "key-concepts.lore" 30 | "conventions.lore" 31 | "introduction.lore" 32 | "dicts.lore" 33 | "sets.lore" 34 | "sequences.lore" 35 | "manual.lore" 36 | "queues.lore" 37 | "in-depth.lore") 38 | 39 | (title "CL-DATA-STRUCTURES") 40 | (include "cl-ds intro") 41 | (include "cl-ds API") 42 | (include "dicts") 43 | (include "sets") 44 | (include "queues") 45 | (include "sequences") 46 | (include "cl-ds algorithms") 47 | (include "cl-ds file system") 48 | (include "cl-ds math") 49 | (include "cl-ds threads") 50 | (include "cl-ds streaming") 51 | (include "cl-ds internals") 52 | ) 53 | 54 | (build-docs "/home/shka/lore") 55 | -------------------------------------------------------------------------------- /docs/queues.lore: -------------------------------------------------------------------------------- 1 | (in-package #:cl-data-structures.documentation) 2 | (cl-lore.api.syntax:syntax 3 | cl-lore.extensions.documentation.api 4 | cl-lore.extensions.sequence-graphs.api) 5 | 6 | 7 | @begin{section} 8 | @label{queues api} 9 | @title{API} 10 | @text{To modify content of the functional queue use the following functions.} 11 | @begin{list} 12 | @item{PUT} 13 | @item{TAKE-OUT} 14 | @end{list} 15 | @text{To modify content of the mutable queue use the following functions.} 16 | @begin{list} 17 | @item{PUT!} 18 | @item{TAKE-OUT!} 19 | @end{list} 20 | @end{section} 21 | 22 | @begin{section} 23 | @label{2-3-tree} 24 | @title{2-3-tree} 25 | @text{2-3-tree is a trie where each subtree holds either 2 or 3 children and grows like B-tree (and as such does not need balancing).} 26 | @begin{documentation} @pack{CL-DATA-STRUCTURES.QUEUES.2-3-TREE} 27 | @docfun['cl-ds.queues.2-3-tree:make-functional-2-3-queue] 28 | @docfun['cl-ds.queues.2-3-tree:make-mutable-2-3-queue] 29 | @docfun['cl-ds.queues.2-3-tree:make-transactional-2-3-queue] 30 | @docclass['cl-ds.queues.2-3-tree:functional-2-3-queue] 31 | @docclass['cl-ds.queues.2-3-tree:mutable-2-3-queue] 32 | @docclass['cl-ds.queues.2-3-tree:transactional-2-3-queue] 33 | @end{documentation} 34 | @end{section} 35 | 36 | @begin{section} 37 | @label{queues} 38 | @title{Queue structures} 39 | @text{Queues are FIFO structures, commonly used for the implementation of scheduling systems and various breadth-first search algorithms.} 40 | @include{queues api} 41 | @include{2-3-tree} 42 | @end{section} 43 | -------------------------------------------------------------------------------- /docs/sequences.lore: -------------------------------------------------------------------------------- 1 | (in-package #:cl-data-structures.documentation) 2 | (cl-lore.api.syntax:syntax 3 | cl-lore.extensions.documentation.api 4 | cl-lore.extensions.sequence-graphs.api) 5 | 6 | @begin{section} @label{RRB vector} 7 | @title{RRB vector} 8 | @text{RRB stands for "Relaxed Radix Trie". Elements are indexed using the successive 5 bit fragments of the index as the keys in the trees. This data structure is commonly seen in the new generation of functional languages (scala, clojure).} 9 | @docclass['cl-ds.seqs.rrb:functional-rrb-vector] 10 | @docclass['cl-ds.seqs.rrb:mutable-rrb-vector] 11 | @docclass['cl-ds.seqs.rrb:transactional-rrb-vector] 12 | @docfun['cl-ds.seqs.rrb:make-functional-rrb-vector] 13 | @docfun['cl-ds.seqs.rrb:make-mutable-rrb-vector] 14 | @docfun['cl-ds.seqs.rrb:make-transactional-rrb-vector] 15 | @end{section} 16 | 17 | @begin{section} @label{Sequences API} 18 | @title{API} 19 | @text{To obtain value under index use the AT function. To modify content of the sequence use the following function.} 20 | @begin{list} 21 | @item{PUT} 22 | @item{PUT!} 23 | @item{TAKE-OUT!} 24 | @item{TAKE-OUT!} 25 | @end{list} 26 | @end{section} 27 | 28 | @begin{section} @title{Sequence structures} 29 | @label{sequences} 30 | @text{Sequences are collections storing elements under numeric index, in consecutive numeric range starting from 0. Those semantics are very much like those of CL:SEQUENCE.} 31 | @include{Sequences API} 32 | @include{RRB vector} 33 | @end{section} -------------------------------------------------------------------------------- /docs/sets.lore: -------------------------------------------------------------------------------- 1 | (in-package #:cl-data-structures.documentation) 2 | (cl-lore.api.syntax:syntax 3 | cl-lore.extensions.documentation.api 4 | cl-lore.extensions.sequence-graphs.api) 5 | 6 | @begin{section} 7 | @title{QP-Trie set} 8 | @label{QP-Trie set} 9 | @text{QP-Trie set is dedicated storage for the (simple-array (unsigned-byte 8) (*)) objects. Primary use case are utf-8. This data structure is uniquely suited toward storing large sets of such strings because it utilizes prefix structure that will compress set to reuse memory for storing identical prefixes of the content.} 10 | @text{QP-Trie set is dedicated storage for the (simple-array (unsigned-byte 8) (*)) objects. Primary use case are utf-8 strings. This data structure is uniquely suited toward storing large sets of such strings because it utilizes prefix structure that will compress set to reuse memory for storing identical prefixes of the content.} 11 | @begin{documentation} 12 | @pack{CL-DATA-STRUCTURES.SETS.QP-TRIE} 13 | @docclass['cl-ds.sets.qp-trie:mutable-qp-trie-set] 14 | @docfun['cl-ds.sets.qp-trie:make-mutable-qp-trie-set] 15 | @end{documentation} 16 | @end{section} 17 | 18 | @begin{section} 19 | @title{Skip-list set} 20 | @label{Skip-list set} 21 | @text{Skip lists are a general purpose ordered containers, like a self-balancing trees.} 22 | @begin{documentation} 23 | @pack{CL-DATA-STRUCTURES.SETS.SKIP-LIST} 24 | @docclass['cl-ds.sets.skip-list:mutable-skip-list-set] 25 | @docfun['cl-ds.sets.skip-list:make-mutable-skip-list-set] 26 | @end{documentation} 27 | @end{section} 28 | 29 | @begin{section} 30 | @label{Sets API} 31 | @title{API} 32 | @text{To modify content of the mutable set use the following functions.} 33 | @begin{list} 34 | @item{PUT!} 35 | @item{ERASE!} 36 | @end{list} 37 | @text{To query content of the set use AT function. Pass object as a key. Function will return T if element is in the set and NIL otherwise.} 38 | @end{section} 39 | 40 | @begin{section} 41 | @title{Set structures} 42 | @label{sets} 43 | @text{Sets are collections of unique elements. Therefore the only operation which can be performed on the set is checking if objects is member of the set, removing object from the set, and adding object to the set.} 44 | @include{Sets API} 45 | @include{QP-Trie set} 46 | @include{Skip-list set} 47 | @end{section} 48 | -------------------------------------------------------------------------------- /docs/vars.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-data-structures.documentation) 2 | 3 | (alexandria:define-constant lisp "Common Lisp" :test 'equal) 4 | -------------------------------------------------------------------------------- /run-ccl-tests.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | ccl --no-init --load run-tests.lisp 4 | -------------------------------------------------------------------------------- /run-sbcl-tests.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | sbcl --dynamic-space-size 8000 --no-sysinit --no-userinit --load run-tests.lisp --noinform 4 | -------------------------------------------------------------------------------- /run-tests.lisp: -------------------------------------------------------------------------------- 1 | (let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" 2 | (user-homedir-pathname)))) 3 | (when (probe-file quicklisp-init) 4 | (load quicklisp-init))) 5 | 6 | (quicklisp:quickload :documentation-utils-extensions :silent t) 7 | (setf documentation-utils-extensions:*documentation* 8 | (documentation-utils-extensions:make-documentation-collection)) 9 | (quicklisp:quickload :cl-data-structures-tests :silent t) 10 | 11 | (unwind-protect 12 | (handler-bind 13 | ((lparallel.kernel:no-kernel-error 14 | (lambda (c) 15 | (declare (ignore c)) 16 | (invoke-restart 'lparallel.kernel:make-kernel 8)))) 17 | (let ((*error-output* (make-broadcast-stream)) 18 | (prove:*test-result-output* *standard-output*) 19 | (*standard-output* (make-broadcast-stream)) 20 | (prove:*enable-colors* t) 21 | (prove:*default-reporter* :dot)) 22 | (prove:run :cl-data-structures-tests) 23 | (prove:diag "Running API examples now.") 24 | (documentation-utils-extensions:execute-documentation :package :cl-data-structures :label :examples) 25 | (prove:diag "Running ALG examples now.") 26 | (documentation-utils-extensions:execute-documentation :package :cl-data-structures.algorithms :label :examples))) 27 | (cl-user::quit)) 28 | -------------------------------------------------------------------------------- /source.txt: -------------------------------------------------------------------------------- 1 | latest-github-release https://github.com/sirherrbatka/cl-data-structures.git 2 | -------------------------------------------------------------------------------- /src/adapters/distance-matrix.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-ds.adapters) 2 | 3 | 4 | (defmethod cl-ds:at ((matrix cl-ds.utils:half-matrix) location &rest more) 5 | (let ((first location) 6 | (second (first more))) 7 | (cl-ds:assert-one-dimension (rest more)) 8 | (cl-ds.utils:mref matrix first second))) 9 | -------------------------------------------------------------------------------- /src/adapters/hash-table.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-ds.adapters) 2 | 3 | 4 | (defmethod cl-ds:at ((container hash-table) location &rest more-locations) 5 | (cl-ds:assert-one-dimension more-locations) 6 | (gethash location container)) 7 | -------------------------------------------------------------------------------- /src/adapters/list.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.adapters) 2 | 3 | 4 | (defmethod cl-ds:at ((container sequence) index &rest more-locations) 5 | (cl-ds:assert-one-dimension more-locations) 6 | (elt container index)) 7 | 8 | 9 | (defmethod cl-ds:size ((seq list)) 10 | (length seq)) 11 | 12 | 13 | (defclass list-range (cl-ds:fundamental-forward-range) 14 | ((%content :initarg :content 15 | :accessor access-content) 16 | (%original-content :initarg :original-content 17 | :reader read-original-content))) 18 | 19 | 20 | (defmethod cl-ds:clone ((obj list-range)) 21 | (make 'list-range 22 | :content (access-content obj) 23 | :original-content (access-content obj))) 24 | 25 | 26 | (defmethod cl-ds:reset! ((obj list-range)) 27 | (setf (access-content obj) (read-original-content obj)) 28 | obj) 29 | 30 | 31 | (defmethod cl-ds:peek-front ((obj list-range)) 32 | (if (endp (access-content obj)) 33 | (values nil nil) 34 | (values (first (access-content obj)) 35 | t))) 36 | 37 | 38 | (defmethod cl-ds:consume-front ((obj list-range)) 39 | (if (endp (access-content obj)) 40 | (values nil nil) 41 | (values (pop (access-content obj)) 42 | t))) 43 | 44 | 45 | (defmethod cl-ds:traverse ((obj list-range) function) 46 | (ensure-functionf function) 47 | (map nil function (access-content obj)) 48 | (setf (access-content obj) nil) 49 | obj) 50 | 51 | 52 | (defmethod cl-ds:across ((obj list-range) function) 53 | (ensure-functionf function) 54 | (map nil function (access-content obj)) 55 | obj) 56 | 57 | 58 | (defmethod cl-ds:whole-range ((container cl:list)) 59 | (make 'list-range 60 | :content container 61 | :original-content container)) 62 | -------------------------------------------------------------------------------- /src/adapters/package.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | 3 | 4 | (defpackage :cl-data-structures.adapters 5 | (:use #:common-lisp #:cl-data-structures.aux-package) 6 | (:nicknames #:cl-ds.adapters) 7 | (:export 8 | #:vector-range 9 | #:list-range 10 | #:offset-vector-range)) 11 | -------------------------------------------------------------------------------- /src/adapters/vector-tests.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | (defpackage vector-tests 3 | (:use #:cl #:prove #:cl-ds #:iterate #:alexandria)) 4 | 5 | (cl:in-package #:vector-tests) 6 | 7 | (plan 14) 8 | (let* ((vector (serapeum:vect 1 2 3 4 5 6 7)) 9 | (range (cl-ds:whole-range vector))) 10 | (iterate 11 | (for (values val more) = (cl-ds:consume-front range)) 12 | (while more) 13 | (for i from 0) 14 | (is (aref vector i) val)) 15 | (reset! range) 16 | (iterate 17 | (for (values val more) = (cl-ds:consume-back range)) 18 | (while more) 19 | (for i from (1- (length vector)) downto 0) 20 | (is (aref vector i) val))) 21 | (finalize) 22 | -------------------------------------------------------------------------------- /src/algorithms/accumulate.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.algorithms) 2 | 3 | 4 | (cl-ds.alg.meta:define-aggregation-function 5 | accumulate accumulate-function 6 | 7 | (:range fn &key key initial-value after) 8 | (:range fn &key (key #'identity) (initial-value :unbound) (after #'identity)) 9 | 10 | (%value %fn %first-iteration %initial-value-present) 11 | 12 | ((setf %value initial-value 13 | %fn fn 14 | %first-iteration t 15 | %initial-value-present (not (eq :unbound initial-value)))) 16 | 17 | ((element) 18 | (if %first-iteration 19 | (setf %value (if %initial-value-present 20 | (funcall %fn %value element) 21 | element) 22 | %first-iteration nil) 23 | (setf %value (funcall %fn %value element)))) 24 | 25 | (%value)) 26 | -------------------------------------------------------------------------------- /src/algorithms/chain-test.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | (defpackage chain-tests 3 | (:use :cl :cl-ds :prove :cl-data-structures.aux-package)) 4 | 5 | (cl:in-package #:chain-tests) 6 | 7 | (plan 38) 8 | 9 | (let* ((vector1 (vect 1 2 3 4 5 6 7)) 10 | (vector2 (vect 8 9 10 11 12)) 11 | (range (cl-ds.alg:chain (cl-ds:whole-range vector1) 12 | (cl-ds:whole-range vector2)))) 13 | (is (cl-ds:size range) (+ (length vector1) (length vector2))) 14 | (iterate 15 | (for (values val more) = (cl-ds:consume-front range)) 16 | (while more) 17 | (for i from 1) 18 | (is val i)) 19 | (reset! range) 20 | (iterate 21 | (for (values val more) = (cl-ds:consume-back range)) 22 | (while more) 23 | (for i from 12 downto 0) 24 | (is val i)) 25 | (reset! range) 26 | (iterate 27 | (for (values val more) = (cl-ds:consume-front range)) 28 | (while more) 29 | (for i from 1) 30 | (is val i)) 31 | (iterate 32 | (for (values val more) = (cl-ds:consume-back range)) 33 | (while more) 34 | (for i from 12 downto 0) 35 | (is val i)) 36 | (is (cl-ds:size range) 0)) 37 | 38 | (finalize) 39 | -------------------------------------------------------------------------------- /src/algorithms/common-range-category.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.algorithms) 2 | 3 | 4 | (defgeneric fundamental-range-class-of (range class) 5 | (:method ((range cl-ds:fundamental-forward-range) class) 6 | (declare (ignore class)) 7 | 'fundamental-forward-range) 8 | (:method ((range cl-ds:fundamental-bidirectional-range) 9 | (class (eql 'fundamental-random-access-range))) 10 | 'fundamental-bidirectional-range) 11 | (:method ((range cl-ds:fundamental-bidirectional-range) 12 | (class (eql 'fundamental-bidirectional-range))) 13 | 'fundamental-bidirectional-range) 14 | (:method ((range cl-ds:fundamental-random-access-range) 15 | class) 16 | class)) 17 | 18 | 19 | (defun common-fundamental-range-class (ranges) 20 | (reduce (lambda (prev next) (fundamental-range-class-of next prev)) 21 | ranges 22 | :initial-value 'fundamental-random-access-range)) 23 | -------------------------------------------------------------------------------- /src/algorithms/contains.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-ds.alg) 2 | 3 | 4 | (defun containsp (range test-function) 5 | (cl-ds:across (lambda (elt) 6 | (when (funcall test-function elt) 7 | (return-from containsp t))) 8 | range) 9 | nil) 10 | -------------------------------------------------------------------------------- /src/algorithms/count.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.algorithms) 2 | 3 | 4 | (cl-ds.alg.meta:define-aggregation-function 5 | count-elements 6 | count-elements-function 7 | 8 | (:range &key after) 9 | (:range &key (after #'identity)) 10 | 11 | ((%count integer)) 12 | 13 | ((setf %count 0)) 14 | 15 | ((element) 16 | (declare (ignore element)) 17 | (incf %count)) 18 | 19 | (%count)) 20 | -------------------------------------------------------------------------------- /src/algorithms/design-notes.org: -------------------------------------------------------------------------------- 1 | * aggregation protocol 2 | ** range layer 3 | *** responsible for creating aggregators 4 | *** responsible for iteration over itself and passing content to aggregator 5 | ** aggregator layer 6 | *** responsible for constructing and managing stages 7 | 8 | * construct-aggregator 9 | ** will return aggregator 10 | ** outer-fn may be nil, or function that shall construct aggregator 11 | -------------------------------------------------------------------------------- /src/algorithms/distinct-test.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | (defpackage distinct-tests 3 | (:use :cl :prove :cl-data-structures.aux-package)) 4 | 5 | (cl:in-package #:distinct-tests) 6 | 7 | (plan 3) 8 | 9 | (let* ((input '((0 . 1) (0 . 2) (0 . 1) (1 . 1) (1 . 1) (1 . 2))) 10 | (result (serapeum:~> input 11 | (cl-ds.alg:group-by :key #'car) 12 | (cl-ds.alg:distinct :key #'cdr) 13 | cl-ds.alg:to-list))) 14 | (is (cl-ds:size result) 2) 15 | (is (cl-ds:at result 0) '((0 . 1) (0 . 2)) :test #'equal) 16 | (is (cl-ds:at result 1) '((1 . 1) (1 . 2)) :test #'equal)) 17 | 18 | (finalize) 19 | -------------------------------------------------------------------------------- /src/algorithms/enumerate.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.algorithms) 2 | 3 | 4 | (cl-ds.alg.meta:define-aggregation-function 5 | enumerate enumerate-function 6 | 7 | (:range &key key test size number) 8 | (:range &key (test 'eql) (key #'identity) 9 | (number 0) (size 16)) 10 | 11 | (%table %number) 12 | 13 | ((check-type number integer) 14 | (setf %table (make-hash-table :test test :size size) 15 | %number number)) 16 | 17 | ((element) 18 | (ensure (gethash element %table) 19 | (prog1 %number (incf %number)))) 20 | 21 | (%table)) 22 | -------------------------------------------------------------------------------- /src/algorithms/extrema-test.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | (defpackage extrema-tests 3 | (:use #:cl #:prove #:cl-ds #:cl-data-structures.aux-package)) 4 | 5 | (cl:in-package #:extrema-tests) 6 | 7 | (plan 2) 8 | 9 | (bind ((data (cl-ds:xpr (:i 0) 10 | (when (< i 250) 11 | (cl-ds:send-recur i :i (1+ i))))) 12 | ((min . max) (cl-ds.alg:extrema data #'<))) 13 | (is min 0) 14 | (is max 249)) 15 | 16 | (finalize) 17 | -------------------------------------------------------------------------------- /src/algorithms/extrema.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.algorithms) 2 | 3 | 4 | (cl-ds.alg.meta:define-aggregation-function 5 | extrema extrema-function 6 | 7 | (:range fn &key key value-key after) 8 | (:range fn &key (key #'identity) (value-key #'identity) (after #'identity)) 9 | 10 | (%low-value %high-value %fn %first-iteration %value-key) 11 | 12 | ((ensure-functionf value-key fn) 13 | (setf %fn fn 14 | %value-key value-key 15 | %first-iteration t)) 16 | 17 | ((element) 18 | (let ((value-key (ensure-function %value-key)) 19 | (fn (ensure-function %fn))) 20 | (cl-ds.utils:lazy-let ((elt (funcall value-key element)) 21 | (high-value (funcall value-key %high-value)) 22 | (low-value (funcall value-key %low-value))) 23 | (cond (%first-iteration 24 | (setf %low-value element 25 | %high-value element 26 | %first-iteration nil)) 27 | ((funcall fn elt high-value) 28 | (setf %high-value element)) 29 | ((funcall fn low-value elt) 30 | (setf %low-value element)))))) 31 | 32 | ((list* %high-value %low-value))) 33 | -------------------------------------------------------------------------------- /src/algorithms/extremum.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.algorithms) 2 | 3 | 4 | (cl-ds.alg.meta:define-aggregation-function 5 | extremum extremum-function 6 | 7 | (:range fn &key key value-key after) 8 | (:range fn &key (key #'identity) (value-key #'identity) (after #'identity)) 9 | 10 | (%value %fn %first-iteration %value-key) 11 | 12 | ((ensure-functionf value-key fn) 13 | (setf %fn fn 14 | %value-key value-key 15 | %first-iteration t)) 16 | 17 | ((element) 18 | (cond (%first-iteration 19 | (setf %value element 20 | %first-iteration nil)) 21 | ((not (funcall (ensure-function %fn) 22 | (funcall (ensure-function %value-key) %value) 23 | (funcall (ensure-function %value-key) element))) 24 | (setf %value element)))) 25 | 26 | (%value)) 27 | -------------------------------------------------------------------------------- /src/algorithms/first-element.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.algorithms) 2 | 3 | 4 | (cl-ds.alg.meta:define-aggregation-function 5 | first-element first-element-function 6 | 7 | (:range &key key) 8 | (:range &key (key #'identity)) 9 | 10 | (%value %bound) 11 | 12 | ((setf %value nil 13 | %bound nil)) 14 | 15 | ((element) 16 | (unless %bound 17 | (setf %bound t 18 | %value element))) 19 | 20 | (%value)) 21 | 22 | 23 | (cl-ds.alg.meta:define-aggregation-function 24 | last-element last-element-function 25 | 26 | (:range &key key) 27 | (:range &key (key #'identity)) 28 | 29 | (%value) 30 | 31 | ((setf %value nil)) 32 | 33 | ((element) 34 | (setf %value element)) 35 | 36 | (%value)) 37 | -------------------------------------------------------------------------------- /src/algorithms/frequency.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.algorithms) 2 | 3 | 4 | (cl-ds.alg.meta:define-aggregation-function 5 | frequency frequency-function 6 | (:range &key key test normalize) 7 | (:range &key (key #'identity) (test 'eql) (normalize t)) 8 | 9 | ((%total-count integer) (%sub-counts hash-table) %normalize) 10 | 11 | ((setf %total-count 0 12 | %normalize normalize 13 | %sub-counts (make-hash-table :test test))) 14 | 15 | ((element) 16 | (incf %total-count) 17 | (incf (the integer (gethash element %sub-counts 0)) 1)) 18 | 19 | ((when %normalize 20 | (iterate 21 | (for (key value) in-hashtable %sub-counts) 22 | (setf (gethash key %sub-counts) 23 | (coerce (/ value %total-count) 'single-float)))) 24 | (make-hash-table-range %sub-counts))) 25 | -------------------------------------------------------------------------------- /src/algorithms/hash-table-elementwise.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.algorithms) 2 | 3 | 4 | (defclass hash-table-elementwise-function (layer-function) 5 | () 6 | (:metaclass closer-mop:funcallable-standard-class)) 7 | 8 | 9 | (defgeneric hash-table-elementwise (range) 10 | (:generic-function-class hash-table-elementwise-function) 11 | (:method (range) 12 | (apply-range-function range #'hash-table-elementwise (list range)))) 13 | 14 | 15 | (defclass hash-table-elementwise-forward-proxy (forward-proxy-range) 16 | ()) 17 | 18 | 19 | (defmethod cl-ds.alg.meta:apply-layer ((range cl-ds:traversable) 20 | (function hash-table-elementwise-function) 21 | arguments) 22 | (make 'hash-table-elementwise-forward-proxy :original-range range)) 23 | 24 | 25 | (defmethod cl-ds.alg.meta:layer-aggregator-constructor ((function hash-table-elementwise-function) 26 | outer-constructor 27 | arguments) 28 | (cl-ds.alg.meta:let-aggregator 29 | ((inners nil)) 30 | 31 | ((element) 32 | (check-type element hash-table) 33 | (when (null inners) 34 | (setf inners (make-hash-table :test (hash-table-test element) 35 | :size (hash-table-size element)))) 36 | (maphash (lambda (key value) 37 | (let ((aggregator (ensure (gethash key inners) 38 | (cl-ds.alg.meta:call-constructor outer-constructor)))) 39 | (cl-ds.alg.meta:pass-to-aggregation aggregator 40 | value))) 41 | element)) 42 | ((unless (null inners) 43 | (lret ((result (make-hash-table :test (hash-table-test inners) 44 | :size (hash-table-size inners)))) 45 | (maphash (lambda (key value) 46 | (setf (gethash key result) (cl-ds.alg.meta:extract-result value))) 47 | inners)))) 48 | 49 | (unless (null inners) 50 | (maphash-values #'cl-ds.alg.meta:cleanup inners)))) 51 | 52 | 53 | (defmethod cl-ds.alg.meta:aggregator-constructor ((range hash-table-elementwise-forward-proxy) 54 | outer-constructor 55 | (function aggregation-function) 56 | (arguments list)) 57 | (let ((outer-fn (call-next-method))) 58 | (assert (functionp outer-fn)) 59 | (cl-ds.alg.meta:aggregator-constructor 60 | (read-original-range range) 61 | (cl-ds.alg.meta:layer-aggregator-constructor #'hash-table-elementwise 62 | outer-fn 63 | arguments) 64 | function 65 | arguments))) 66 | -------------------------------------------------------------------------------- /src/algorithms/meta/classes.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.algorithms.meta) 2 | 3 | 4 | (defclass range-function (closer-mop:standard-generic-function) 5 | () 6 | (:metaclass closer-mop:funcallable-standard-class)) 7 | 8 | 9 | (defclass layer-function (range-function) 10 | () 11 | (:metaclass closer-mop:funcallable-standard-class)) 12 | 13 | 14 | (defclass transformation!-function (range-function) 15 | () 16 | (:metaclass closer-mop:funcallable-standard-class)) 17 | 18 | 19 | (defclass aggregation-function (range-function) 20 | () 21 | (:metaclass closer-mop:funcallable-standard-class)) 22 | 23 | 24 | (define-condition early-aggregation-exit (condition) 25 | ()) 26 | -------------------------------------------------------------------------------- /src/algorithms/meta/generics.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.algorithms.meta) 2 | 3 | #| 4 | Top level aggregator protocol. 5 | |# 6 | 7 | 8 | (defstruct aggregator 9 | (pass #'identity :type (-> (t) t)) 10 | (extract (lambda () nil) :type (-> () t)) 11 | (cleanup (lambda () nil) :type (-> () t))) 12 | 13 | (declaim (inline pass-to-aggregation)) 14 | (-> pass-to-aggregation (aggregator t) null) 15 | (defun pass-to-aggregation (aggregator element) 16 | (declare (type aggregator aggregator) 17 | (optimize (speed 3) (safety 0))) 18 | (~> aggregator aggregator-pass (funcall element)) 19 | nil) 20 | 21 | (declaim (inline extract-result)) 22 | (-> extract-result (aggregator) t) 23 | (defun extract-result (aggregator) 24 | (declare (type aggregator aggregator) 25 | (optimize (speed 3) (safety 0))) 26 | (~> aggregator aggregator-extract funcall)) 27 | 28 | (declaim (inline cleanup)) 29 | (-> cleanup (aggregator) t) 30 | (defun cleanup (aggregator) 31 | (declare (type aggregator aggregator) 32 | (optimize (speed 3) (safety 0))) 33 | (~> aggregator aggregator-cleanup funcall)) 34 | 35 | #| 36 | Range function invokaction protocol. 37 | |# 38 | 39 | (defgeneric apply-layer (range function arguments)) 40 | 41 | (defgeneric apply-range-function (range function arguments)) 42 | 43 | (defgeneric apply-aggregation-function (range function arguments)) 44 | 45 | (defgeneric make-state (aggregation-function 46 | &rest all 47 | &key &allow-other-keys)) 48 | 49 | (defgeneric state-result (function state) 50 | (:method ((function aggregation-function) state) 51 | state)) 52 | 53 | (defgeneric across-aggregate (range function) 54 | (:method ((range cl-ds:traversable) function) 55 | (cl-ds:across range function)) 56 | (:method ((range sequence) function) 57 | (map nil function range) 58 | range)) 59 | 60 | (defgeneric aggregator-constructor (range outer-constructor 61 | function arguments) 62 | (:method ((range cl:sequence) (outer-constructor function) 63 | (function aggregation-function) (arguments list)) 64 | outer-constructor) 65 | (:method ((range cl-ds:traversable) (outer-constructor function) 66 | (function aggregation-function) (arguments list)) 67 | outer-constructor)) 68 | 69 | (defgeneric layer-aggregator-constructor (function outer-constructor arguments)) 70 | 71 | (defmacro call-constructor (constructor) 72 | `(the aggregator (funcall (the function ,constructor)))) 73 | 74 | (defun construct-aggregator (range function arguments) 75 | (call-constructor (aggregator-constructor range nil function arguments))) 76 | -------------------------------------------------------------------------------- /src/algorithms/meta/meta-tests.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | (defpackage alg-meta-tests 3 | (:use #:common-lisp #:prove #:cl-data-structures.aux-package) 4 | (:shadowing-import-from #:iterate #:collecting #:summing #:in)) 5 | 6 | (cl:in-package #:alg-meta-tests) 7 | 8 | (plan 6) 9 | 10 | (let* ((vector1 #((1) (2) (1) (2) (1) (2) (1))) 11 | (proxy (~> vector1 12 | cl-ds:whole-range 13 | (cl-ds.alg:group-by :key (alexandria:compose #'evenp #'car) 14 | :test #'eq) 15 | (cl-ds.alg:accumulate #'max :key #'car)))) 16 | (is (cl-ds:at proxy t) 2) 17 | (is (cl-ds:at proxy nil) 1)) 18 | 19 | 20 | (let* ((vector1 #((6 . 1) (6 . 1) (6 . 1) 21 | (5 . 2) (5 . 2) (5 . 2) 22 | (5 . 3) (5 . 3) (5 . 3) 23 | (6 . 4) (6 . 4) (6 . 4))) 24 | (proxy (~> vector1 25 | cl-ds:whole-range 26 | (cl-ds.alg:group-by :key (alexandria:compose #'evenp #'car) 27 | :test #'eq) 28 | (cl-ds.alg:group-by :key (alexandria:compose #'evenp #'cdr) 29 | :test #'eq) 30 | (cl-ds.alg:accumulate #'+ :key #'cdr)))) 31 | (is (~> proxy (cl-ds:at t) (cl-ds:at t)) 12 :test #'=) 32 | (is (~> proxy (cl-ds:at nil) (cl-ds:at t)) 6 :test #'=) 33 | (is (~> proxy (cl-ds:at nil) (cl-ds:at nil)) 9 :test #'=) 34 | (is (~> proxy (cl-ds:at t) (cl-ds:at nil)) 3 :test #'=)) 35 | 36 | (finalize) 37 | -------------------------------------------------------------------------------- /src/algorithms/meta/methods.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.algorithms.meta) 2 | 3 | #| 4 | Range function invokaction protocol. 5 | |# 6 | 7 | (defmethod apply-range-function ((object cl-ds:fundamental-container) 8 | (function aggregation-function) 9 | all) 10 | (apply-aggregation-function object function all)) 11 | 12 | 13 | (defmethod apply-range-function ((object cl:sequence) 14 | (function aggregation-function) 15 | all) 16 | (apply-aggregation-function object function all)) 17 | 18 | 19 | (defmethod apply-range-function (range 20 | (function aggregation-function) 21 | all) 22 | (apply-aggregation-function range function all)) 23 | 24 | 25 | (defmethod apply-range-function ((range cl-ds:traversable) 26 | (function layer-function) 27 | all) 28 | (warn "Appling range function to ~a object which is not a range." 29 | range) 30 | (apply-layer range function all)) 31 | 32 | 33 | (defmethod apply-range-function ((range cl-ds:fundamental-range) 34 | (function layer-function) 35 | all) 36 | (apply-layer (cl-ds:clone range) function all)) 37 | 38 | 39 | (defmethod apply-range-function ((range cl:hash-table) 40 | (function layer-function) 41 | all) 42 | (apply-layer (cl-ds:whole-range range) function all)) 43 | 44 | 45 | (defmethod apply-range-function ((range cl:sequence) 46 | (function layer-function) 47 | all) 48 | (apply-layer (cl-ds:whole-range range) function all)) 49 | 50 | 51 | (defmethod apply-range-function ((range cl-ds:fundamental-container) 52 | (function layer-function) 53 | all) 54 | (apply-layer (cl-ds:whole-range range) function all)) 55 | 56 | 57 | (defmethod apply-aggregation-function (range 58 | (function aggregation-function) 59 | all) 60 | (let ((aggregator (construct-aggregator range function all)) 61 | (success nil)) 62 | (unwind-protect 63 | (progn 64 | (handler-case 65 | (across-aggregate range 66 | (lambda (x) 67 | (pass-to-aggregation aggregator 68 | x))) 69 | (early-aggregation-exit nil)) 70 | (setf success t)) 71 | (unless success (cleanup aggregator))) 72 | (extract-result aggregator))) 73 | -------------------------------------------------------------------------------- /src/algorithms/meta/notes.org: -------------------------------------------------------------------------------- 1 | * Tasks 2 | ** DONE This will need another function to check if state of the function is complete. 3 | CLOSED: [2020-01-18 sob 11:03] 4 | [2019-02-03 nie] 5 | [[file:~/quicklisp/local-projects/cl-data-structures/src/algorithms/meta/generics.lisp::(defgeneric%20expects-content-p%20(aggregator))]] 6 | -------------------------------------------------------------------------------- /src/algorithms/notes.org: -------------------------------------------------------------------------------- 1 | * Tasks 2 | ** TODO Instead of chunking-mixin, it should forward chunking into each of its inner ranges. 3 | [2018-10-18 czw] 4 | [[file:~/quicklisp/local-projects/cl-data-structures/src/algorithms/chain.lisp::(defclass%20forward-chain-of-ranges%20(cl-ds:chunking-mixin]] 5 | ** DONE Unique is missing. I need to fix that. 6 | CLOSED: [2019-02-05 wto 09:58] 7 | [2019-02-04 pon] 8 | [[file:~/quicklisp/local-projects/cl-data-structures/src/algorithms/only.lisp::(declare%20(ignore%20all))]] 9 | -------------------------------------------------------------------------------- /src/algorithms/on-each-test.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | (defpackage on-each-tests 3 | (:use :cl :prove :cl-data-structures.aux-package)) 4 | 5 | (cl:in-package #:on-each-tests) 6 | 7 | (plan 2) 8 | 9 | (let* ((data #(1 2 3 4)) 10 | (range (cl-ds.alg:on-each (cl-ds:whole-range data) #'1+))) 11 | (is (cl-ds.alg:accumulate range #'+) (+ 2 3 4 5))) 12 | 13 | (is (cl-ds.alg:accumulate 14 | (cl-ds.alg:on-each (cl-ds:xpr (:i 1) 15 | (when (< i 5) 16 | (cl-ds:send-recur i :i (1+ i)))) 17 | #'1+) 18 | #'+) 19 | (+ 2 3 4 5)) 20 | 21 | (finalize) 22 | -------------------------------------------------------------------------------- /src/algorithms/only.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.algorithms) 2 | 3 | 4 | (defclass only-proxy (filtering-proxy) 5 | ((%predicate :initarg :predicate 6 | :reader read-predicate))) 7 | 8 | 9 | (defmethod cl-ds.utils:cloning-information append 10 | ((proxy only-proxy)) 11 | '((:predicate read-predicate))) 12 | 13 | 14 | (defclass forward-only-proxy (only-proxy 15 | forward-filtering-proxy) 16 | ()) 17 | 18 | 19 | (defclass bidirectional-only-proxy (forward-only-proxy 20 | bidirectional-filtering-proxy) 21 | ()) 22 | 23 | 24 | (defmethod should-skip ((range only-proxy) element can-mutate) 25 | (declare (ignore can-mutate)) 26 | (~>> element (funcall (read-predicate range)) not)) 27 | 28 | 29 | (defclass only-function (layer-function) 30 | () 31 | (:metaclass closer-mop:funcallable-standard-class)) 32 | 33 | 34 | (defmethod wrap-chunk ((range forward-only-proxy) 35 | (chunk cl-ds:fundamental-forward-range)) 36 | (make 'forward-only-proxy 37 | :original-range chunk 38 | :key (read-key range) 39 | :predicate (read-predicate range))) 40 | 41 | 42 | (defgeneric only (range predicate &key key) 43 | (:generic-function-class only-function) 44 | (:method (range predicate &key (key #'identity)) 45 | (apply-range-function range #'only 46 | (list range predicate 47 | :key key)))) 48 | 49 | 50 | (defmethod apply-layer ((range fundamental-bidirectional-range) 51 | (function only-function) 52 | all) 53 | (make 'bidirectional-only-proxy 54 | :predicate (second all) 55 | :key (getf (cddr all) :key) 56 | :original-range range)) 57 | 58 | 59 | (defmethod apply-layer ((range cl-ds:traversable) 60 | (function only-function) 61 | all) 62 | (make 'forward-only-proxy 63 | :predicate (second all) 64 | :key (getf (cddr all) :key) 65 | :original-range range)) 66 | 67 | 68 | (defmethod cl-ds.alg.meta:aggregator-constructor ((range only-proxy) 69 | outer-constructor 70 | (function aggregation-function) 71 | (arguments list)) 72 | (declare (optimize (speed 3) (safety 0))) 73 | (let ((outer-fn (or outer-constructor 74 | (cl-ds.alg.meta:aggregator-constructor 75 | '() nil function arguments))) 76 | (predicate (ensure-function (read-predicate range))) 77 | (key (ensure-function (read-key range)))) 78 | (cl-ds.utils:cases ((:variant (eq key #'identity))) 79 | (cl-ds.alg.meta:aggregator-constructor 80 | (read-original-range range) 81 | (cl-ds.alg.meta:let-aggregator ((inner (cl-ds.alg.meta:call-constructor outer-fn))) 82 | ((element) 83 | (when (funcall predicate (funcall key element)) 84 | (cl-ds.alg.meta:pass-to-aggregation inner element))) 85 | 86 | ((cl-ds.alg.meta:extract-result inner)) 87 | 88 | (cl-ds.alg.meta:cleanup inner)) 89 | function 90 | arguments)))) 91 | -------------------------------------------------------------------------------- /src/algorithms/partition-if-test.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | (defpackage partition-if-tests 3 | (:use :cl :prove :cl-data-structures.aux-package)) 4 | 5 | (cl:in-package #:partition-if-tests) 6 | 7 | (plan 12) 8 | 9 | (let ((result (~> #(0 1 2 3 4 5 6 7 8 9 10 11) 10 | (cl-ds.alg:partition-if (lambda (prev next) 11 | (eql (truncate prev 3) 12 | (truncate next 3)))) 13 | cl-ds.alg:to-vector))) 14 | (is (cl-ds:at result 0) #(0 1 2) :test #'vector=) 15 | (is (cl-ds:at result 1) #(3 4 5) :test #'vector=) 16 | (is (cl-ds:at result 2) #(6 7 8) :test #'vector=) 17 | (is (cl-ds:at result 3) #(9 10 11) :test #'vector=)) 18 | 19 | (let ((result (~> #(0 1 2 3 4 5 6 7 8 9 10 11) 20 | (cl-ds.alg:partition-if (lambda (prev current) 21 | (< (- current prev) 3)) 22 | :on-first t) 23 | cl-ds.alg:to-vector))) 24 | (is (cl-ds:at result 0) #(0 1 2) :test #'vector=) 25 | (is (cl-ds:at result 1) #(3 4 5) :test #'vector=) 26 | (is (cl-ds:at result 2) #(6 7 8) :test #'vector=) 27 | (is (cl-ds:at result 3) #(9 10 11) :test #'vector=)) 28 | 29 | (let ((result (~> #(0 1 2 3 4 5 6 7 8 9 10 11) 30 | (cl-ds.alg:partition-if #'= :key (lambda (x) 31 | (truncate x 3))) 32 | cl-ds.alg:to-vector))) 33 | (is (cl-ds:at result 0) #(0 1 2) :test #'vector=) 34 | (is (cl-ds:at result 1) #(3 4 5) :test #'vector=) 35 | (is (cl-ds:at result 2) #(6 7 8) :test #'vector=) 36 | (is (cl-ds:at result 3) #(9 10 11) :test #'vector=)) 37 | 38 | (finalize) 39 | -------------------------------------------------------------------------------- /src/algorithms/rate.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.algorithms) 2 | 3 | 4 | (cl-ds.alg.meta:define-aggregation-function 5 | rate rate-function 6 | (:range test &key key positive total after) 7 | (:range test &key (key #'identity) (positive 0) (total 0) (after #'identity)) 8 | 9 | (%positive %total %test) 10 | 11 | ((ensure-functionf test) 12 | (setf %positive positive 13 | %test test 14 | %total total)) 15 | 16 | ((element) 17 | (incf %total) 18 | (when (funcall %test element) 19 | (incf %positive))) 20 | 21 | ((/ %positive %total))) 22 | -------------------------------------------------------------------------------- /src/algorithms/reservoir-sample.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.algorithms) 2 | 3 | 4 | (declaim (inline gen-w)) 5 | (-> gen-w (fixnum &optional double-float) double-float) 6 | (defun gen-w (count &optional (w 1.0d0)) 7 | (declare (optimize (speed 3) (safety 0))) 8 | (* w (exp (/ (log (random 1.0d0)) 9 | count)))) 10 | 11 | 12 | (declaim (inline calculate-skip-count)) 13 | (-> calculate-skip-count (positive-double-float) positive-fixnum) 14 | (defun calculate-skip-count (w) 15 | (declare (optimize (speed 3) (safety 0))) 16 | (1+ (the fixnum (floor (/ (the negative-double-float (log (random 1.0d0))) 17 | (the negative-double-float (log (- 1 w)))))))) 18 | 19 | 20 | (defstruct (reservoir-sampling (:constructor make-reservoir-sampling*)) 21 | result 22 | replacement 23 | test 24 | (w 0.0d0 :type double-float) 25 | (skip-count 0 :type fixnum)) 26 | 27 | 28 | (defun make-reservoir-sampling (sample-size &optional (replacement t) (test #'eql)) 29 | (check-type sample-size positive-fixnum) 30 | (let ((w (gen-w sample-size))) 31 | (make-reservoir-sampling* 32 | :result (make-array sample-size :fill-pointer 0) 33 | :replacement replacement 34 | :test test 35 | :w w 36 | :skip-count (calculate-skip-count w)))) 37 | 38 | 39 | (defun reservoir-sampling-sample-size (reservoir-sampling) 40 | (~> reservoir-sampling reservoir-sampling-result (array-dimension 0))) 41 | 42 | 43 | (cl-ds.utils:define-list-of-slots reservoir-sampling () 44 | (result reservoir-sampling-result) 45 | (w reservoir-sampling-w) 46 | (replacement reservoir-sampling-replacement) 47 | (test reservoir-sampling-test) 48 | (skip-count reservoir-sampling-skip-count) 49 | (sample-size reservoir-sampling-sample-size)) 50 | 51 | 52 | (defun reservoir-sampling-push (reservoir-sampling element) 53 | (check-type reservoir-sampling reservoir-sampling) 54 | (cl-ds.utils:with-slots-for (reservoir-sampling reservoir-sampling) 55 | (cond ((and (< (fill-pointer result) sample-size) 56 | (nand (not replacement) 57 | (find element result :test test))) 58 | (vector-push element result)) 59 | ((and (zerop skip-count) 60 | (nand (not replacement) 61 | (find element result :test test))) 62 | (setf skip-count (calculate-skip-count w) 63 | (aref result (random sample-size)) element 64 | w (gen-w sample-size w))) 65 | (t (decf skip-count))))) 66 | 67 | 68 | (cl-ds.alg.meta:define-aggregation-function 69 | reservoir-sample reservoir-sample-function 70 | 71 | (:range sample-size &key key after test replacement) 72 | (:range sample-size &key (key #'identity) (after #'identity) (test #'eql) (replacement t)) 73 | 74 | ((%result reservoir-sampling)) 75 | 76 | ((setf %result (make-reservoir-sampling sample-size replacement test))) 77 | 78 | ((element) 79 | (reservoir-sampling-push %result element)) 80 | 81 | ((reservoir-sampling-result %result))) 82 | -------------------------------------------------------------------------------- /src/algorithms/reversed.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.algorithms) 2 | -------------------------------------------------------------------------------- /src/algorithms/shuffled-range.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.algorithms) 2 | 3 | 4 | (defclass shuffled-range (cl-ds:chunking-mixin 5 | cl-ds:fundamental-forward-range) 6 | ((%table :initform (make-hash-table) 7 | :initarg :table 8 | :reader read-table) 9 | (%index :accessor access-index 10 | :initarg :index) 11 | (%from :reader read-from 12 | :initarg :from) 13 | (%to :reader read-to 14 | :initarg :to))) 15 | 16 | 17 | (defun shuffled-range (from to) 18 | (check-type from integer) 19 | (check-type to integer) 20 | (unless (<= from to) 21 | (error 'cl-ds:incompatible-arguments 22 | :format-control "FROM must be smaller then TO." 23 | :parameters '(from to) 24 | :values (list from to))) 25 | (make 'shuffled-range 26 | :index from 27 | :from from 28 | :to to)) 29 | 30 | 31 | (defmethod cl-ds:consume-front ((object shuffled-range)) 32 | (bind (((:slots %table %index %from %to) object)) 33 | (cond ((eql (- %to 1) %index) 34 | (let ((index %index)) 35 | (ensure (gethash %index %table) %index) 36 | (incf %index) 37 | (values (gethash index %table) t))) 38 | ((< %index %to) 39 | (let ((next-random (random-in-range %index %to)) 40 | (index %index)) 41 | (ensure (gethash %index %table) %index) 42 | (ensure (gethash next-random %table) next-random) 43 | (rotatef (gethash %index %table) 44 | (gethash next-random %table)) 45 | (incf %index) 46 | (values (gethash index %table) t))) 47 | (t (values nil nil))))) 48 | 49 | 50 | (defmethod cl-ds:peek-front ((object shuffled-range)) 51 | (bind (((:slots %table %index %from %to) object)) 52 | (cond ((eql (- %to 1) %index) 53 | (values (ensure (gethash %index %table) %index) t)) 54 | ((< %index %to) 55 | (let ((next-random (random-in-range %index %to))) 56 | (ensure (gethash %index %table) %index) 57 | (ensure (gethash next-random %table) next-random) 58 | (rotatef (gethash %index %table) 59 | (gethash next-random %table)) 60 | (values (gethash (1+ %index) %table) t))) 61 | (t (values nil nil))))) 62 | 63 | 64 | (defmethod cl-ds:clone ((object shuffled-range)) 65 | (make 'shuffled-range 66 | :index (access-index object) 67 | :from (access-index object) 68 | :table (copy-hash-table (read-table object)) 69 | :to (read-to object))) 70 | 71 | 72 | (defmethod cl-ds:reset! ((object shuffled-range)) 73 | (setf (access-index object) (read-from object)) 74 | object) 75 | -------------------------------------------------------------------------------- /src/algorithms/split-into-chunks-test.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | (defpackage split-into-chunks-tests 3 | (:use :cl :prove :cl-data-structures.aux-package)) 4 | 5 | (cl:in-package #:split-into-chunks-tests) 6 | 7 | (plan 4) 8 | 9 | (let* ((vector #(0 1 2 3 4 5 6 7 8 9 10 11)) 10 | (result (cl-ds.alg:to-vector (cl-ds.alg:in-batches vector 3)))) 11 | (is (cl-ds:at result 0) #(0 1 2) :test #'vector=) 12 | (is (cl-ds:at result 1) #(3 4 5) :test #'vector=) 13 | (is (cl-ds:at result 2) #(6 7 8) :test #'vector=) 14 | (is (cl-ds:at result 3) #(9 10 11) :test #'vector=)) 15 | 16 | (finalize) 17 | -------------------------------------------------------------------------------- /src/algorithms/summary-test.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | (defpackage summary-tests 3 | (:use #:cl #:prove #:cl-ds #:cl-data-structures.aux-package)) 4 | 5 | (cl:in-package #:summary-tests) 6 | 7 | (plan 4) 8 | 9 | (let* ((data (cl-ds:xpr (:i 0) 10 | (when (< i 250) 11 | (cl-ds:send-recur i :i (1+ i))))) 12 | (min-and-max (cl-ds.alg:summary (cl-ds.alg:group-by data :key #'evenp) 13 | :min (cl-ds.alg:accumulate #'min) 14 | :max (cl-ds.alg:accumulate #'max)))) 15 | (is (~> min-and-max (cl-ds:at t) (cl-ds:at :min)) 0) 16 | (is (~> min-and-max (cl-ds:at nil) (cl-ds:at :max)) 249)) 17 | 18 | (let* ((data (~> (cl-ds:iota-range :to 50) 19 | (cl-ds.alg:group-by :key #'oddp))) 20 | (summary (cl-ds.alg:summary data 21 | :vector (cl-ds.alg:to-vector)))) 22 | (is (~> summary (cl-ds:at nil) (cl-ds:at :vector) length) 23 | 25) 24 | (is (~> summary (cl-ds:at t) (cl-ds:at :vector) length) 25 | 25)) 26 | 27 | (finalize) 28 | -------------------------------------------------------------------------------- /src/algorithms/summary.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.algorithms) 2 | 3 | 4 | (defclass summary-aggregation-function (cl-ds.alg.meta:aggregation-function) 5 | () 6 | (:metaclass closer-mop:funcallable-standard-class)) 7 | 8 | 9 | (defclass summary-result-range (hash-table-range) 10 | ()) 11 | 12 | 13 | (cl-ds.alg.meta:define-aggregation-function 14 | %summary %summary-function 15 | 16 | (:range ids constructors) 17 | (:range ids constructors) 18 | 19 | (%aggregators %ids) 20 | 21 | ((setf %aggregators (mapcar #'funcall constructors) 22 | %ids ids)) 23 | 24 | ((element) 25 | (iterate 26 | (for aggregator in %aggregators) 27 | (cl-ds.alg.meta:pass-to-aggregation aggregator element))) 28 | 29 | ((let ((result (make-hash-table :test 'eq :size (length %aggregators)))) 30 | (iterate 31 | (for aggregator in %aggregators) 32 | (for id in-vector %ids) 33 | (setf (gethash id result) (cl-ds.alg.meta:extract-result aggregator))) 34 | (make-instance 'summary-result-range 35 | :hash-table result 36 | :keys %ids 37 | :begin 0 38 | :end (hash-table-count result))))) 39 | 40 | 41 | (defmacro summary (range &body functions) 42 | (once-only (range) 43 | (iterate 44 | (for (id (function . body)) in (batches functions 2)) 45 | (check-type id symbol) 46 | (check-type function symbol) 47 | (for aggregator = `(cl-ds.alg.meta:aggregator-constructor 48 | '() nil (function ,function) (list ,range ,@body))) 49 | (collect aggregator into forms) 50 | (collect id into ids) 51 | (finally (return `(%summary ,range (vector ,@ids) (list ,@forms))))))) 52 | -------------------------------------------------------------------------------- /src/algorithms/to-hash-table.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.algorithms) 2 | 3 | 4 | (cl-ds.alg.meta:define-aggregation-function 5 | to-hash-table to-hash-table-function 6 | 7 | (:range 8 | &key key test size hash-table-key hash-table-value after) 9 | (:range &key 10 | (test 'eql) 11 | (key #'identity) 12 | (hash-table-key #'identity) 13 | (hash-table-value #'identity) 14 | (after #'identity) 15 | (size 16)) 16 | 17 | (%table %hash-table-key %hash-table-value) 18 | 19 | ((ensure-functionf hash-table-key hash-table-value) 20 | (setf %table (make-hash-table :test test :size size) 21 | %hash-table-key hash-table-key 22 | %hash-table-value hash-table-value)) 23 | 24 | ((element) 25 | (setf (gethash (funcall %hash-table-key element) %table) 26 | (funcall %hash-table-value element))) 27 | 28 | (%table)) 29 | -------------------------------------------------------------------------------- /src/algorithms/to-list.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.algorithms) 2 | 3 | 4 | (cl-ds.alg.meta:define-aggregation-function 5 | to-list to-list-function 6 | 7 | (:range &key key after) 8 | (:range &key (key #'identity) (after #'identity)) 9 | 10 | (%list %tail) 11 | 12 | ((setf %list '() 13 | %tail %list)) 14 | 15 | ((element) 16 | (if (null %list) 17 | (setf %list (list element) 18 | %tail %list) 19 | (let ((next-cell (list element))) 20 | (setf (cdr %tail) next-cell 21 | %tail next-cell)))) 22 | 23 | (%list)) 24 | -------------------------------------------------------------------------------- /src/algorithms/to-vector.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.algorithms) 2 | 3 | 4 | (cl-ds.alg.meta:define-aggregation-function 5 | to-vector to-vector-function 6 | 7 | (:range &key key element-type size after) 8 | (:range &key 9 | (key #'identity) (element-type t) 10 | (after #'identity) (size 16)) 11 | 12 | (%vector) 13 | 14 | ((setf %vector (make-array size 15 | :adjustable t 16 | :fill-pointer 0 17 | :element-type element-type))) 18 | ((element) 19 | (vector-push-extend element %vector)) 20 | 21 | (%vector)) 22 | -------------------------------------------------------------------------------- /src/algorithms/translation.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.algorithms) 2 | 3 | 4 | (defclass translation-function (on-each-function) 5 | () 6 | (:metaclass closer-mop:funcallable-standard-class)) 7 | 8 | 9 | (defgeneric translation (range dict &key key) 10 | (:generic-function-class translation-function) 11 | (:method (range dict &key (key #'identity)) 12 | (apply-range-function range #'translation 13 | (list range 14 | :key key 15 | :function (lambda (x) 16 | (bind (((:values result found) 17 | (cl-ds:at dict x))) 18 | (if found result nil))))))) 19 | -------------------------------------------------------------------------------- /src/algorithms/without-test.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | (defpackage without-tests 3 | (:use :cl :prove :cl-data-structures.aux-package)) 4 | 5 | (cl:in-package #:without-tests) 6 | 7 | (plan 8) 8 | 9 | (let ((vector #(0 1 2 3 4 5 6 7 8 9 10 11)) 10 | (result nil)) 11 | (cl-ds:traverse (cl-ds.alg:without vector #'evenp) 12 | (lambda (x) (push x result))) 13 | (is (sort result #'<) '(1 3 5 7 9 11) :test #'equal) 14 | (setf result (serapeum:~> vector 15 | (cl-ds.alg:without #'evenp) 16 | (cl-ds.alg:group-by :key (lambda (x) (mod x 3))) 17 | (cl-ds.alg:accumulate (flip #'cons) 18 | :initial-value nil))) 19 | (is (cl-ds:at result 0) '(9 3) :test #'equal) 20 | (is (cl-ds:at result 2) '(11 5) :test #'equal) 21 | (is (cl-ds:at result 1) '(7 1) :test #'equal)) 22 | 23 | (let ((vector #(0 1 2 3 4 5 6 7 8 9 10 11)) 24 | (result nil)) 25 | (cl-ds:traverse (cl-ds.alg:without vector #'evenp) 26 | (lambda (x) (push x result))) 27 | (is (sort result #'<) '(1 3 5 7 9 11) :test #'equal) 28 | (setf result (serapeum:~> vector 29 | (cl-ds.alg:group-by :key (lambda (x) (mod x 3))) 30 | (cl-ds.alg:without #'evenp) 31 | (cl-ds.alg:accumulate (flip #'cons) 32 | :initial-value nil))) 33 | (is (cl-ds:at result 0) '(9 3) :test #'equal) 34 | (is (cl-ds:at result 2) '(11 5) :test #'equal) 35 | (is (cl-ds:at result 1) '(7 1) :test #'equal)) 36 | 37 | (finalize) 38 | -------------------------------------------------------------------------------- /src/algorithms/without.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.algorithms) 2 | 3 | 4 | (defclass without-proxy (filtering-proxy) 5 | ((%predicate :initarg :predicate 6 | :reader read-predicate))) 7 | 8 | 9 | (defmethod cl-ds.utils:cloning-information append 10 | ((proxy without-proxy)) 11 | '((:predicate read-predicate))) 12 | 13 | 14 | (defclass forward-without-proxy (without-proxy 15 | forward-filtering-proxy) 16 | ()) 17 | 18 | 19 | (defclass bidirectional-without-proxy (forward-without-proxy 20 | bidirectional-filtering-proxy) 21 | ()) 22 | 23 | 24 | (defmethod should-skip ((range without-proxy) element can-mutate) 25 | (declare (ignore can-mutate)) 26 | (funcall (read-predicate range) element)) 27 | 28 | 29 | (defclass without-function (layer-function) 30 | () 31 | (:metaclass closer-mop:funcallable-standard-class)) 32 | 33 | 34 | (defgeneric without (range predicate &key key) 35 | (:generic-function-class without-function) 36 | (:method (range predicate &key (key #'identity)) 37 | (apply-range-function range #'without 38 | (list range predicate 39 | :key key)))) 40 | 41 | 42 | (defmethod apply-layer ((range fundamental-bidirectional-range) 43 | (function without-function) 44 | all) 45 | (make 'bidirectional-without-proxy 46 | :predicate (second all) 47 | :key (getf (cddr all) :key) 48 | :original-range range)) 49 | 50 | 51 | (defmethod apply-layer ((range cl-ds:traversable) 52 | (function without-function) 53 | all) 54 | (make 'forward-without-proxy 55 | :predicate (second all) 56 | :key (getf (cddr all) :key) 57 | :original-range range)) 58 | 59 | 60 | (defmethod wrap-chunk ((range without-proxy) 61 | (chunk cl-ds:fundamental-forward-range)) 62 | (without chunk (read-predicate range) :key (read-key range))) 63 | 64 | 65 | (defmethod cl-ds.alg.meta:aggregator-constructor ((range without-proxy) 66 | outer-constructor 67 | (function aggregation-function) 68 | (arguments list)) 69 | (declare (optimize (speed 3) (safety 0))) 70 | (let ((outer-fn (or outer-constructor 71 | (cl-ds.alg.meta:aggregator-constructor 72 | '() nil function arguments))) 73 | (predicate (ensure-function (read-predicate range))) 74 | (key (ensure-function (read-key range)))) 75 | (cl-ds.utils:cases ((:variant (eq key #'identity))) 76 | (cl-ds.alg.meta:aggregator-constructor 77 | (read-original-range range) 78 | (cl-ds.alg.meta:let-aggregator ((inner (cl-ds.alg.meta:call-constructor outer-fn))) 79 | ((element) 80 | (unless (funcall predicate (funcall key element)) 81 | (cl-ds.alg.meta:pass-to-aggregation inner element))) 82 | 83 | ((cl-ds.alg.meta:extract-result inner)) 84 | 85 | (cl-ds.alg.meta:cleanup inner)) 86 | function 87 | arguments)))) 88 | -------------------------------------------------------------------------------- /src/algorithms/zip-test.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-ds.alg) 2 | 3 | 4 | (prove:plan 6) 5 | 6 | (let* ((vector1 #(1 2 3 4 5 6 7)) 7 | (vector2 #(8 9 10 11 12)) 8 | (range (cl-ds.alg:zip 9 | #'list* 10 | (cl-ds:whole-range vector1) 11 | (cl-ds:whole-range vector2)))) 12 | (prove:is (cl-ds:size range) (min (length vector1) (length vector2))) 13 | (iterate 14 | (for (values value more) = (cl-ds:consume-front range)) 15 | (while more) 16 | (for v1 in-vector vector1) 17 | (for v2 in-vector vector2) 18 | (prove:is value (list* v1 v2) :test #'equal))) 19 | 20 | (prove:finalize) 21 | -------------------------------------------------------------------------------- /src/api/auxilary.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures) 2 | 3 | 4 | (defclass empty-range (fundamental-forward-range) 5 | ()) 6 | 7 | 8 | (defmethod cl-ds:consume-front ((range empty-range)) 9 | (values nil nil)) 10 | 11 | 12 | (defmethod cl-ds:peek-front ((range empty-range)) 13 | (values nil nil)) 14 | 15 | 16 | (defmethod cl-ds:reset! ((range empty-range)) 17 | range) 18 | 19 | 20 | (defmethod cl-ds:clone ((range empty-range)) 21 | (make (class-of range))) 22 | 23 | 24 | (defmethod cl-ds:traverse ((range empty-range) 25 | function) 26 | (ensure-functionf function) 27 | range) 28 | 29 | 30 | (defmethod cl-ds:across ((range empty-range) 31 | function) 32 | (ensure-functionf function) 33 | range) 34 | -------------------------------------------------------------------------------- /src/api/delay.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures) 2 | 3 | 4 | (defclass delayed () 5 | ((%callback :initarg :callback 6 | :reader read-callback) 7 | %value)) 8 | 9 | 10 | (defun make-delay (callback) 11 | (make 'delayed :callback callback)) 12 | 13 | 14 | (defmacro delay (&body body) 15 | `(cl-ds:make-delay (lambda () ,@body))) 16 | 17 | 18 | (declaim (inline force)) 19 | (defun force (obj) 20 | (if (typep obj 'delayed) 21 | (if (slot-boundp obj '%value) 22 | (slot-value obj '%value) 23 | (setf (slot-value obj '%value) 24 | (funcall (slot-value obj '%callback)))) 25 | obj)) 26 | -------------------------------------------------------------------------------- /src/api/expression-tests.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | (defpackage expression-tests 3 | (:use :cl :prove :cl-data-structures.aux-package)) 4 | (cl:in-package #:expression-tests) 5 | 6 | (plan 5) 7 | (let ((data nil) 8 | (expression (cl-ds:xpr (:iteration 1) 9 | (when (< iteration 5) 10 | (cl-ds:send-recur iteration :iteration (1+ iteration)))))) 11 | (is (cl-ds:peek-front expression) 1) 12 | (cl-ds:across expression 13 | (lambda (x) (push x data))) 14 | (is data '(4 3 2 1) :test #'equal) 15 | (setf data nil) 16 | (iterate 17 | (for (values value not-finished) = (cl-ds:consume-front expression)) 18 | (while not-finished) 19 | (push value data)) 20 | (is data '(4 3 2 1) :test #'equal)) 21 | 22 | (let* ((data '(1 2 (3 4) (5 (6 7)))) 23 | (expression (cl-ds:xpr (:stack (list data)) 24 | (unless (endp stack) 25 | (let ((front (first stack))) 26 | (cond ((atom front) 27 | (cl-ds:send-recur front :stack (rest stack))) 28 | (t (cl-ds:recur :stack (append front (rest stack)))))))))) 29 | (let ((result nil)) 30 | (cl-ds:traverse expression (lambda (x) (push x result))) 31 | (is (sort result #'<) '(1 2 3 4 5 6 7) :test #'equal))) 32 | 33 | (let* ((data '(1 2 (3 4) (5 (6 7)))) 34 | (expression (cl-ds:xpr (:stack (list data)) 35 | (unless (endp stack) 36 | (destructuring-bind (front . stack) stack 37 | (cond ((atom front) 38 | (cl-ds:send-recur front :stack stack)) 39 | (t (cl-ds:recur 40 | :stack (iterate 41 | (for elt in front) 42 | (push elt stack) 43 | (finally (return stack))))))))))) 44 | (let ((result nil)) 45 | (cl-ds:traverse expression (lambda (x) (push x result))) 46 | (is (sort result #'<) '(1 2 3 4 5 6 7) :test #'equal))) 47 | 48 | (finalize) 49 | -------------------------------------------------------------------------------- /src/api/functions.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures) 2 | 3 | 4 | (defun traverse-multiple (function range &rest more) 5 | (let ((more (cons range more))) 6 | (map-into more #'whole-range more) 7 | (iterate 8 | (for data = 9 | (iterate 10 | (for r in more) 11 | (for (values data more) = (consume-front r)) 12 | (unless more 13 | (return-from traverse-multiple nil)) 14 | (collect data))) 15 | (apply function data)))) 16 | 17 | 18 | (defun iota-range (&key (from 0) to (by 1)) 19 | (check-type to (or null integer)) 20 | (check-type from integer) 21 | (check-type by integer) 22 | (if (or (null to) (<= from to)) 23 | (progn 24 | (unless (positive-integer-p by) 25 | (error 'argument-value-out-of-bounds 26 | :format-control "BY must be positive because TO is larger then FROM." 27 | :argument 'by 28 | :bounds '(> 0) 29 | :value by)) 30 | (cl-ds:xpr (:i from) 31 | (when (or (null to) 32 | (< i to)) 33 | (send-recur i :i (+ by i))))) 34 | (progn 35 | (unless (negative-integer-p by) 36 | (error 'argument-value-out-of-bounds 37 | :format-control "BY must be negative because TO is smaller then FROM." 38 | :argument 'by 39 | :bounds '(< 0) 40 | :value by)) 41 | (cl-ds:xpr (:i from) 42 | (when (or (null to) 43 | (> i to)) 44 | (send-recur i :i (+ by i))))))) 45 | 46 | 47 | (defun modulo-range (size &key (start 0) (by 1)) 48 | (check-type size positive-integer) 49 | (check-type start non-negative-integer) 50 | (check-type by positive-integer) 51 | (cl-ds:xpr (:i (rem start size)) 52 | (cl-ds:send-recur i :i (rem (+ i by) size)))) 53 | -------------------------------------------------------------------------------- /src/api/fundamental-classes.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures) 2 | 3 | 4 | (defclass traversable () 5 | ()) 6 | 7 | 8 | (defclass fundamental-container (traversable) 9 | ()) 10 | 11 | 12 | (defclass fundamental-modification-operation-status () 13 | ()) 14 | 15 | 16 | (defclass fundamental-range (traversable) 17 | ()) 18 | 19 | 20 | (defclass fundamental-assiganable-range (fundamental-range) 21 | ()) 22 | 23 | 24 | (defclass fundamental-forward-range (fundamental-range) 25 | ()) 26 | 27 | 28 | (defclass fundamental-bidirectional-range (fundamental-forward-range) 29 | ()) 30 | 31 | 32 | (defclass fundamental-random-access-range (fundamental-bidirectional-range) 33 | ()) 34 | 35 | 36 | (defclass fundamental-assignable-forward-range (fundamental-forward-range 37 | fundamental-assiganable-range) 38 | ()) 39 | 40 | 41 | (defclass fundamental-assignable-bidirectional-range (fundamental-bidirectional-range 42 | fundamental-assiganable-range) 43 | ()) 44 | 45 | 46 | (defclass fundamental-assignable-random-access-range (fundamental-random-access-range 47 | fundamental-assiganable-range) 48 | ()) 49 | 50 | 51 | (defclass key-value-range () 52 | ()) 53 | 54 | 55 | (defclass chunking-mixin () 56 | ()) 57 | 58 | 59 | (defclass chunked-range (chunking-mixin fundamental-forward-range) 60 | ((%original-range :initarg :original-range 61 | :reader read-original-range) 62 | (%chunk-size :initarg :chunk-size 63 | :reader read-chunk-size))) 64 | -------------------------------------------------------------------------------- /src/api/macros.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures) 2 | 3 | 4 | (defmacro mod-bind ((first &optional found value changed) form &body body) 5 | (alexandria:with-gensyms (!status) 6 | `(multiple-value-bind (,first ,!status) ,form 7 | (declare (ignorable ,first ,!status)) 8 | (symbol-macrolet (,@(remove-if (lambda (x) (null (car x))) 9 | `((,found (found ,!status)) 10 | (,value (value ,!status)) 11 | (,changed (changed ,!status))))) 12 | ,@body)))) 13 | 14 | 15 | (metabang.bind::defbinding-form (:at 16 | :use-values-p nil 17 | :accept-multiple-forms-p nil) 18 | (let* ((container (list (gensym) values)) 19 | (variables metabang.bind::variables) 20 | (arguments (mapcar (lambda (x) (list (gensym) (second x))) variables)) 21 | (symbols (mapcar #'first variables)) 22 | (forms (mapcar (lambda (x argument) (list x `(cl-ds:at ,(first container) 23 | ,(first argument)))) 24 | symbols arguments))) 25 | `(serapeum:nest 26 | (let* (,container ,@arguments)) 27 | (symbol-macrolet ,forms)))) 28 | 29 | 30 | (metabang.bind::defbinding-form (:modification 31 | :use-values-p nil 32 | :accept-multiple-forms-p nil) 33 | (multiple-value-bind (bindings ignores) 34 | (metabang.bind.developer:bind-fix-nils metabang.bind::variables) 35 | (declare (ignore bindings)) 36 | `(mod-bind ,metabang.bind::variables ,values 37 | (declare (ignore ,@ignores))))) 38 | 39 | 40 | (defmacro assert-one-dimension (more) 41 | (once-only (more) 42 | `(unless (endp ,more) 43 | (error 'cl-ds:too-many-dimensions 44 | :format-control "Can't pass more then one dimension into one dimensional data structures." 45 | :value (1+ (length ,more)) 46 | :bounds 1)))) 47 | 48 | 49 | (defmacro check-argument-bounds (argument expression) 50 | `(unless ,expression 51 | (error 'cl-ds:argument-value-out-of-bounds 52 | :argument ',argument 53 | :bounds ',expression 54 | :value ,argument))) 55 | -------------------------------------------------------------------------------- /src/api/trait-classes.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures) 2 | 3 | 4 | (defclass functional (fundamental-container) 5 | ()) 6 | 7 | 8 | (defclass mutable (fundamental-container) 9 | ()) 10 | 11 | 12 | (defclass transactional (mutable) 13 | ()) 14 | 15 | 16 | (defclass lazy (functional) 17 | ()) 18 | -------------------------------------------------------------------------------- /src/common/2-3-tree/package.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | 3 | 4 | (defpackage :cl-data-structures.common.2-3-tree 5 | (:use #:cl 6 | #:cl-data-structures.aux-package) 7 | (:nicknames #:cl-ds.common.2-3) 8 | (:export 9 | #:access-root 10 | #:delete-back-from-tree 11 | #:delete-back-from-tree! 12 | #:insert-front-into-tree 13 | #:insert-front-into-tree! 14 | #:transactional-insert-front-into-tree! 15 | #:transactional-delete-back-from-tree! 16 | #:node 17 | #:2-node 18 | #:3-node 19 | #:access-left 20 | #:access-right 21 | #:access-middle 22 | #:tree)) 23 | -------------------------------------------------------------------------------- /src/common/abstract/package.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | 3 | 4 | (defpackage :cl-data-structures.common.abstract 5 | (:use #:common-lisp #:cl-data-structures.aux-package) 6 | (:nicknames #:cl-ds.common.abstract) 7 | (:export 8 | #:acquire-ownership 9 | #:enclose-finalizer 10 | #:fundamental-ownership-tagged-object 11 | #:make-ownership-tag 12 | #:make-tagged-node 13 | #:define-tagged-untagged-node 14 | #:tagged-struct-node 15 | #:read-ownership-tag 16 | #:tagged-node 17 | #:replica 18 | #:write-ownership-tag)) 19 | -------------------------------------------------------------------------------- /src/common/content-tuple.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.common) 2 | 3 | 4 | (defstruct hash-content 5 | (hash 0 :type fixnum) 6 | location) 7 | 8 | 9 | (defstruct (hash-dict-content (:include hash-content)) 10 | value) 11 | 12 | 13 | (defun single-element-p (seq) 14 | (and (not (null seq)) 15 | (cond ((listp seq) 16 | (endp (rest seq))) 17 | ((vectorp seq) 18 | (eql (length seq) 1))))) 19 | 20 | 21 | (defstruct dict-content 22 | location value) 23 | -------------------------------------------------------------------------------- /src/common/docstrings.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.common) 2 | 3 | 4 | (docs:define-docs 5 | :formatter docs.ext:rich-aggregating-formatter 6 | 7 | (function sequence-window 8 | (:description "Creates sequence window out of sequence or other sequence-window." 9 | :returns "Sequence-window object." 10 | :arguments ((sequence "Object with content.") 11 | (from "Lower bound of resulting window.") 12 | (to "Upper bound of resulting window."))))) 13 | -------------------------------------------------------------------------------- /src/common/eager-modification-operation-status.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.common) 2 | 3 | 4 | (defclass eager-modification-operation-status 5 | (implementation-modification-operation-status) 6 | ()) 7 | 8 | 9 | (defun make-eager-modification-operation-status (found value changed) 10 | (make-instance 'eager-modification-operation-status 11 | :found found 12 | :changed changed 13 | :value value)) 14 | 15 | 16 | (def empty-eager-modification-operation-status 17 | (make-eager-modification-operation-status nil nil nil)) 18 | 19 | 20 | (def empty-changed-eager-modification-operation-status 21 | (make-eager-modification-operation-status nil nil t)) 22 | -------------------------------------------------------------------------------- /src/common/egnat/docstrings.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.common.egnat) 2 | -------------------------------------------------------------------------------- /src/common/egnat/generics.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.common.egnat) 2 | 3 | 4 | (defgeneric select-children (range node) 5 | (:method ((range egnat-range) (node egnat-subtree)) 6 | (make-array (length (read-children node)) 7 | :element-type 'bit 8 | :initial-element 1)) 9 | (:method ((range egnat-range-around) (node egnat-subtree)) 10 | (prune-subtrees (read-container range) 11 | (read-children node) 12 | (read-close-range node) 13 | (read-distant-range node) 14 | (read-near range) 15 | (read-margin range)))) 16 | 17 | 18 | (defgeneric distance (container bucket element)) 19 | 20 | 21 | (defgeneric next-elements (range stack) 22 | (:method ((range egnat-range) stack) 23 | (bind (((cell . rest) stack) 24 | ((node content) cell)) 25 | (cond ((null content) 26 | (add-children-to-stack range node rest)) 27 | ((eq t content) 28 | (if (typep node 'egnat-node) 29 | (iterate 30 | (with results = '()) 31 | (for c in-vector (read-content node)) 32 | (push c results) 33 | (finally (return (cons (list node results) rest)))) 34 | (cons (list node (list (read-content node))) 35 | rest))) 36 | (t (cons (list node (rest content)) 37 | rest))))) 38 | (:method ((range egnat-range-around) stack) 39 | (bind (((cell . rest) stack) 40 | ((node content) cell) 41 | ((:slots %container %near %margin) range)) 42 | (cond ((null content) 43 | (add-children-to-stack range node rest)) 44 | ((eq t content) 45 | (if (typep node 'egnat-node) 46 | (iterate 47 | (with results = '()) 48 | (for c in-vector (read-content node)) 49 | (for distance = (distance %container %near c)) 50 | (when (<= distance %margin) 51 | (push c results)) 52 | (finally (return (cons (list node results) rest)))) 53 | (if (<= (distance %container %near (read-content node)) 54 | %margin) 55 | (cons (list node (list (read-content node))) 56 | rest) 57 | (cons (list node '()) 58 | rest)))) 59 | (t (cons (list node (rest content)) 60 | rest)))))) 61 | -------------------------------------------------------------------------------- /src/common/egnat/package.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | 3 | 4 | (defpackage :cl-data-structures.common.egnat 5 | (:use #:common-lisp #:cl-data-structures.aux-package) 6 | (:nicknames #:cl-ds.common.egnat) 7 | (:export 8 | #:access-root 9 | #:access-size 10 | #:distance 11 | #:fundamental-egnat-container 12 | #:get-value 13 | #:make-egnat-tree 14 | #:mutable-egnat-container 15 | #:prune-subtrees 16 | #:read-margin 17 | #:read-near 18 | #:select-children 19 | #:traverse-impl)) 20 | -------------------------------------------------------------------------------- /src/common/egnat/tests.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cl-user) 2 | (defpackage egnat-tests (:use :prove :cl :iterate :metabang-bind)) 3 | (cl:in-package :egnat-tests) 4 | 5 | 6 | (defmethod cl-ds.common.egnat:distance ((container cl-ds.common.egnat:mutable-egnat-container) 7 | bucket item) 8 | (logxor bucket item)) 9 | 10 | 11 | (plan 2) 12 | 13 | (let ((container (make-instance 14 | 'cl-ds.common.egnat:mutable-egnat-container 15 | :branching-factor 5 16 | :samples-count 5 17 | :metric-type 'fixnum 18 | :content-count-in-node 5)) 19 | (data (coerce (iterate 20 | (with generator = (cl-ds.utils:lazy-shuffle 0 5000)) 21 | (repeat 50) 22 | (collect (funcall generator))) 23 | 'vector))) 24 | (let ((root (cl-ds.common.egnat::make-egnat-tree container #'cl-ds:put! nil data))) 25 | (setf (cl-ds.common.egnat::access-root container) root) 26 | (is (length (cl-ds.common.egnat::read-children root)) 5)) 27 | (let ((near (cl-ds.alg:to-vector (cl-ds:near container (aref data 0) 3)))) 28 | (prove:ok (find (aref data 0) near)))) 29 | 30 | (finalize) 31 | -------------------------------------------------------------------------------- /src/common/hamt/package.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | 3 | 4 | (defpackage :cl-data-structures.common.hamt 5 | (:use #:cl 6 | #:cl-data-structures.common.abstract 7 | #:cl-data-structures.aux-package) 8 | (:nicknames #:cl-ds.common.hamt) 9 | (:export 10 | #:+depth+ 11 | #:+hash-level+ 12 | #:+maximum-children-count+ 13 | #:access-root 14 | #:access-size 15 | #:build-node 16 | #:build-rehashed-node 17 | #:clear-modification-masks 18 | #:copy-node 19 | #:copy-on-write 20 | #:get-range-key-function 21 | #:go-down-on-path 22 | #:hamt-container 23 | #:hash-do 24 | #:hash-node-access 25 | #:hash-node-contains 26 | #:hash-node-contains-node 27 | #:hash-node-content 28 | #:hash-node-content-modified 29 | #:hash-node-deep-copy 30 | #:hash-node-insert! 31 | #:hash-node-insert-into-copy 32 | #:hash-node-p 33 | #:hash-node-remove! 34 | #:hash-node-remove-from-the-copy 35 | #:hash-node-replace! 36 | #:hash-node-replace-in-the-copy 37 | #:hash-node-size 38 | #:hash-node-to-masked-index 39 | #:hash-node-transactional-insert 40 | #:hash-node-transactional-remove 41 | #:hash-node-transactional-replace 42 | #:hash-node-whole-mask 43 | #:new-cell 44 | #:obtain-value 45 | #:read-max-depth 46 | #:rebuild-rehashed-node 47 | #:rehash 48 | #:transactional-copy-on-write 49 | #:transactional-rebuild-rehashed-node 50 | #:with-destructive-erase-hamt 51 | #:with-hamt-path 52 | #:with-hash-tree-functions)) 53 | -------------------------------------------------------------------------------- /src/common/modification-operation-status.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.common) 2 | 3 | 4 | (defclass implementation-modification-operation-status 5 | (cl-ds:fundamental-modification-operation-status) 6 | ((%value :initarg :value 7 | :reader read-value 8 | :reader cl-ds:value 9 | :writer write-value) 10 | (%changed :initarg :changed 11 | :reader cl-ds:changed 12 | :writer write-changed 13 | :reader read-changed) 14 | (%found :initarg :found 15 | :reader read-found 16 | :reader cl-ds:found 17 | :writer write-found))) 18 | -------------------------------------------------------------------------------- /src/common/package.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | 3 | 4 | (defpackage :cl-data-structures.common 5 | (:use #:common-lisp #:cl-data-structures.aux-package) 6 | (:nicknames #:cl-ds.common) 7 | (:export 8 | #:access-content 9 | #:assignable-forward-tree-range 10 | #:assignable-tree-range 11 | #:close-queue 12 | #:defmethod-with-peek-stack 13 | #:defmethod-with-stack 14 | #:dict-content 15 | #:dict-content-location 16 | #:dict-content-value 17 | #:eager-modification-operation-status 18 | #:empty-eager-modification-operation-status 19 | #:empty-changed-eager-modification-operation-status 20 | #:sequence-window 21 | #:force-version 22 | #:forward-lazy-range 23 | #:forward-tree-range 24 | #:hash-content-hash 25 | #:hash-content-location 26 | #:hash-dict-content-value 27 | #:lazy-bidirectional-range 28 | #:lazy-box-container 29 | #:array-to-half-byte-array 30 | #:lazy-random-access-range 31 | #:make-dict-content 32 | #:make-eager-modification-operation-status 33 | #:make-hash-content 34 | #:make-hash-dict-content 35 | #:make-lazy-range 36 | #:read-found 37 | #:read-store-value 38 | #:read-value 39 | #:single-element-p)) 40 | -------------------------------------------------------------------------------- /src/common/qp-trie-tests.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.common.qp-trie) 2 | 3 | (prove:plan 9) 4 | 5 | (let ((tree (make 'qp-trie)) 6 | (content nil) 7 | (bytes (make-array 5 8 | :element-type '(unsigned-byte 8) 9 | :initial-contents '(5 13 53 20 10)))) 10 | (prove:is (qp-trie-find tree bytes) 0) 11 | (prove:ok (qp-trie-insert! tree bytes (make-qp-trie-node))) 12 | (prove:ok (not (qp-trie-insert! tree bytes (make-qp-trie-node)))) 13 | (prove:is (qp-trie-find tree bytes) 5) 14 | (map-qp-trie-nodes (lambda (x) 15 | (prove:is content nil) 16 | (setf content x)) 17 | (access-root tree)) 18 | (prove:is content bytes :test #'vector=) 19 | (prove:ok (qp-trie-delete! tree bytes)) 20 | (prove:ok (not (qp-trie-delete! tree bytes))) 21 | (prove:is (qp-trie-find tree bytes) 0) 22 | ) 23 | 24 | (prove:finalize) 25 | -------------------------------------------------------------------------------- /src/common/rrb/notes.org: -------------------------------------------------------------------------------- 1 | * Tasks 2 | ** TODO 3 | [2018-10-11 czw] 4 | [[file:~/quicklisp/local-projects/cl-data-structures/src/common/rrb/common.lisp::;;%20TODO%20very%20innefficient!]] 5 | Walking over whole vector to obtain children nodes is just stupid. It should be a lot better to use tree structure in the range (perhaps by having separate ref to tail AND head). 6 | ** TODO Need to protect objects of those class from race condition on cl-ds:clone. 7 | [2018-11-20 wto] 8 | [[file:~/quicklisp/local-projects/cl-data-structures/src/common/rrb/common.lisp::(%25mutex%20:type%20bt:lock]] 9 | -------------------------------------------------------------------------------- /src/common/rrb/package.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | 3 | 4 | (defpackage :cl-data-structures.common.rrb 5 | (:use #:common-lisp 6 | #:cl-data-structures.common.abstract 7 | #:cl-data-structures.aux-package) 8 | (:nicknames #:cl-ds.common.rrb) 9 | (:export 10 | #:+bit-count+ 11 | #:+depth+ 12 | #:+maximal-shift+ 13 | #:+maximum-children-count+ 14 | #:+tail-mask+ 15 | #:access-last-size 16 | #:access-lower-bound 17 | #:access-root 18 | #:access-shift 19 | #:access-size 20 | #:access-start 21 | #:access-tail 22 | #:access-tail-size 23 | #:access-upper-bound 24 | #:copy-on-write 25 | #:copy-on-write-without-tail 26 | #:copy-on-write-without-tail 27 | #:deep-copy-sparse-rrb-node 28 | #:descend-into-tree 29 | #:destructive-write 30 | #:destructive-write-without-tail 31 | #:fill-sparse-rrb-node-with-new 32 | #:insert-tail 33 | #:make-node-content 34 | #:make-rrb-node 35 | #:make-sparse-rrb-node 36 | #:node-content 37 | #:node-size 38 | #:nref 39 | #:read-element-type 40 | #:reduce-path 41 | #:remove-tail 42 | #:rrb-at 43 | #:rrb-container 44 | #:rrb-index 45 | #:rrb-node 46 | #:rrb-node-content 47 | #:rrb-node-position 48 | #:rrb-node-push! 49 | #:rrb-node-push-into-copy 50 | #:rrb-range 51 | #:shift 52 | #:sparse-node 53 | #:sparse-nref 54 | #:sparse-rrb-mask 55 | #:sparse-rrb-node 56 | #:sparse-rrb-node-untagged 57 | #:sparse-rrb-tree-map 58 | #:sparse-rrb-node-tagged 59 | #:sparse-rrb-node-bitmask 60 | #:sparse-rrb-node-contains 61 | #:sparse-rrb-node-contains 62 | #:sparse-rrb-node-content 63 | #:sparse-rrb-node-erase 64 | #:sparse-rrb-node-erase! 65 | #:sparse-rrb-node-size 66 | #:sparse-rrb-tree-size 67 | #:transactional-copy-on-write 68 | #:transactional-copy-on-write-without-tail 69 | #:with-sparse-rrb-node 70 | #:with-sparse-rrb-node-path)) 71 | -------------------------------------------------------------------------------- /src/common/sequence-window-tests.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | (defpackage sequence-window-tests 3 | (:use #:cl #:prove #:serapeum #:cl-ds #:iterate #:alexandria) 4 | (:shadowing-import-from #:iterate #:sum #:collecting #:summing #:in)) 5 | 6 | (cl:in-package #:sequence-window-tests) 7 | 8 | (plan 2) 9 | 10 | (let* ((vector #(0 1 2 3 4 5 6 7 8 9 10 11 12)) 11 | (range (cl-ds.common:sequence-window vector 0 13)) 12 | (collection nil) 13 | (window-range (cl-ds.common:sequence-window vector 4 10))) 14 | (cl-ds:across range 15 | (lambda (x) (push x collection))) 16 | (is (sort collection #'<) (iota 13) :test #'equal) 17 | (setf collection nil) 18 | (cl-ds:across window-range 19 | (lambda (x) (push x collection))) 20 | (is (sort collection #'<) (iota 6 :start 4) :test #'equal)) 21 | 22 | (finalize) 23 | -------------------------------------------------------------------------------- /src/common/skip-list/package.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | 3 | 4 | (defpackage :cl-data-structures.common.skip-list 5 | (:use #:common-lisp 6 | #:cl-data-structures.common.abstract 7 | #:cl-data-structures.aux-package) 8 | (:nicknames #:cl-ds.common.skip-list) 9 | (:export 10 | #:access-test-function 11 | #:make-skip-list-node 12 | #:assoc-skip-list-node-value 13 | #:delete-node-between! 14 | #:fundamental-skip-list 15 | #:fundamental-skip-list-range 16 | #:insert-node-between! 17 | #:insert-or 18 | #:level 19 | #:locate-node 20 | #:make-range 21 | #:make-skip-list-node-of-level 22 | #:make-skip-list-node-of-random-level 23 | #:access-maximum-level 24 | #:new-node-update-pointers! 25 | #:pointers 26 | #:random-level 27 | #:read-ordering-function 28 | #:read-pointers 29 | #:size 30 | #:skip-list-locate-node 31 | #:skip-list-node 32 | #:skip-list-node-at 33 | #:skip-list-node-clone 34 | #:skip-list-node-compare 35 | #:skip-list-node-content 36 | #:skip-list-node-level 37 | #:skip-list-node-pointers 38 | #:skip-list-node-update-pointers! 39 | #:update-head-pointers!)) 40 | -------------------------------------------------------------------------------- /src/composite/package.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage :cl-data-structures.composite 2 | (:use #:common-lisp 3 | #:cl-data-structures.aux-package) 4 | (:nicknames #:cl-ds.composite) 5 | (:export 6 | :position-modification 7 | :position-modification! 8 | :make-mutable-composite-container 9 | :make-functional-composite-container)) 10 | -------------------------------------------------------------------------------- /src/composite/tests.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-ds.composite) 2 | 3 | (prove:plan 5) 4 | 5 | (let ((composite-container (make 'mutable-composite-container 6 | :root (cl-ds.dicts.srrb:make-mutable-sparse-rrb-vector) 7 | :make-bucket-callbacks (list (make-bucket-callback 8 | (cl-ds.dicts.srrb:make-mutable-sparse-rrb-vector)))))) 9 | (position-modification! (list #'cl-ds:insert! #'cl-ds:insert!) 10 | composite-container 11 | (list 1 1) 12 | 5) 13 | (prove:is (cl-ds:at composite-container 1 1) 5) 14 | (position-modification! (list #'cl-ds:insert! 15 | (list #'cl-ds:update-if! 16 | :condition-fn (constantly nil))) 17 | composite-container 18 | (list 1 1) 19 | 7) 20 | (prove:is (cl-ds:at composite-container 1 1) 5) 21 | (position-modification! (list #'cl-ds:insert! 22 | (list #'cl-ds:update-if! 23 | :condition-fn (constantly t))) 24 | composite-container 25 | (list 1 1) 26 | 7) 27 | (prove:is (cl-ds:at composite-container 1 1) 7)) 28 | 29 | 30 | (let* ((composite-container (make 'functional-composite-container 31 | :root (cl-ds.dicts.srrb:make-functional-sparse-rrb-vector) 32 | :make-bucket-callbacks (list (make-bucket-callback 33 | (cl-ds.dicts.srrb:make-functional-sparse-rrb-vector))))) 34 | (fresh-container (position-modification (list #'cl-ds:insert #'cl-ds:insert) 35 | composite-container 36 | (list 1 1) 37 | 5))) 38 | (prove:is (cl-ds:at composite-container 1 1) nil) 39 | (prove:is (cl-ds:at fresh-container 1 1) 5)) 40 | 41 | (prove:finalize) 42 | -------------------------------------------------------------------------------- /src/counting/apriori.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package cl-data-structures.counting) 2 | 3 | 4 | (defclass set-index-function (cl-ds.alg.meta:multi-aggregation-function) 5 | () 6 | (:metaclass closer-mop:funcallable-standard-class)) 7 | 8 | 9 | (defgeneric set-index (range minimal-support &key key) 10 | (:generic-function-class set-index-function) 11 | (:method (range minimal-support &key (key #'identity)) 12 | (ensure-functionf key) 13 | (check-type minimal-support positive-fixnum) 14 | (cl-ds.alg.meta:apply-aggregation-function 15 | range 16 | #'set-index 17 | :minimal-support minimal-support 18 | :key key))) 19 | 20 | 21 | (defun set-index-algorithm (&key set-form minimal-support &allow-other-keys) 22 | (bind (((_ total-size . table) set-form) 23 | ((:values index children) (make-set-index table 24 | total-size 25 | minimal-support)) 26 | (queue (lparallel.queue:make-queue)) 27 | (reverse-mapping (make-array (hash-table-count table))) 28 | (mapping (make-hash-table :size (hash-table-count table) 29 | :test 'equal))) 30 | (async-expand-node index (read-root index) children 0 queue) 31 | (iterate 32 | (for i from 0) 33 | (for (key value) in-hashtable table) 34 | (for (id . positions) = value) 35 | (setf (aref reverse-mapping id) key 36 | (gethash key mapping) i)) 37 | (setf (access-mapping index) mapping 38 | (access-reverse-mapping index) reverse-mapping) 39 | (iterate 40 | (for (values f more) = (lparallel.queue:try-pop-queue queue)) 41 | (while more) 42 | (lparallel:force f)) 43 | index)) 44 | 45 | 46 | (defmethod cl-ds.alg.meta:multi-aggregation-stages 47 | ((function set-index-function) 48 | &rest all 49 | &key minimal-support key &allow-other-keys) 50 | (declare (ignore all)) 51 | (list (cl-ds.alg.meta:reduce-stage :set-form 52 | (list* -1 0 (make-hash-table :test 'equal)) 53 | (state data &rest all) 54 | (declare (ignore all)) 55 | (bind (((_ position . table) state)) 56 | (cl-ds:across (funcall key data) 57 | (lambda (k) 58 | (ensure (gethash k table) 59 | (list* (incf (car state)) 60 | (make-array 4 :element-type 'fixnum 61 | :adjustable t 62 | :fill-pointer 0))) 63 | (vector-push-extend position 64 | (cdr (gethash k table)))))) 65 | (incf (second state)) 66 | state) 67 | #'set-index-algorithm)) 68 | -------------------------------------------------------------------------------- /src/counting/docstrings.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.counting) 2 | 3 | 4 | (docs:define-docs 5 | :formatter docs.ext:rich-aggregating-formatter 6 | 7 | (generic set-index 8 | (:description "Constructs the set-index out of the RANGE.")) 9 | 10 | (function find-association 11 | (:description "Find and return APRIORI-SET object containing apriori set and aposteriori set. Returned object can be used to obtain association-frequency, support and to find super-sets." 12 | :arguments ((index "SET-INDEX instance.") 13 | (apriori "List of content in the apriori set.") 14 | (aposteriori "List of content the aposteriori set.")) 15 | :exceptional-situations ("Will return empty set if at least one element in either apriori or aposteriori can't be find in the index." 16 | "Will return empty set if set does not exist in the index."))) 17 | 18 | (function apriori-set 19 | (:description "Returns SET-IN-INDEX object containing apriori part of association." 20 | :arguments ((set "Set containing association.")))) 21 | 22 | (function aposteriori-set 23 | (:description "Returns SET-IN-INDEX object containing aposteriori part of association." 24 | :arguments ((set "Set containing association.")))) 25 | 26 | (function association-frequency 27 | (:description "Returns frequency of association between aposteriori and apriori of association-set." 28 | :returns "Value between 0 and 1.")) 29 | 30 | (function all-sets 31 | (:description "Obtain all sets up to size from the index." 32 | :arguments ((index "Index, containing all subsets.") 33 | (maximal-size "Integer, only return sets up-to this size.") 34 | (minimal-frequency "Real, only return sets with total frequency above this limit.")) 35 | :exceptional-situations ("Will signal type-errors if minimal-frequency is not real or maximal-size is not of type integer." 36 | "Will signal cl-ds:argument-value-out-of-bounds if minimal frequency is below 0 or above 1" 37 | "Will signal cl-ds:argument-value-out-of-bounds if maximal-size is not above 0.") 38 | :returns "Forward range of SET-IN-INDEX objects."))) 39 | -------------------------------------------------------------------------------- /src/counting/generics.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.counting) 2 | 3 | 4 | (defgeneric association-frequency (set)) 5 | 6 | (defgeneric type-count (object)) 7 | 8 | (defgeneric find-association (index apriori aposteriori)) 9 | 10 | (defgeneric find-set (index &rest content)) 11 | 12 | (defgeneric all-super-sets (set minimal-frequency &optional maximal-size)) 13 | 14 | (defgeneric all-sets (index minimal-frequency &optional maximal-size)) 15 | 16 | (defgeneric apriori-set (set)) 17 | 18 | (defgeneric aposteriori-set (set)) 19 | 20 | (defgeneric content (set)) 21 | 22 | (defgeneric make-association-set (apriori aposteriori)) 23 | 24 | (defgeneric support (object)) 25 | -------------------------------------------------------------------------------- /src/counting/package.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | 3 | 4 | (defpackage :cl-data-structures.counting 5 | (:use #:common-lisp 6 | #:cl-data-structures.aux-package 7 | #:cl-data-structures.utils) 8 | (:nicknames #:cl-ds.counting) 9 | (:export 10 | #:all-sets 11 | #:all-super-sets 12 | #:aposteriori-set 13 | #:apriori-set 14 | #:association-frequency 15 | #:content 16 | #:find-association 17 | #:find-set 18 | #:make-association-set 19 | #:set-index 20 | #:support 21 | #:type-count)) 22 | -------------------------------------------------------------------------------- /src/counting/types.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.counting) 2 | 3 | 4 | (defclass tree-mixin () 5 | ((%sets :reader read-sets 6 | :writer write-sets 7 | :type vector 8 | :initarg :sets 9 | :initform (vect)))) 10 | 11 | 12 | (defclass set-index-node () 13 | ((%type :reader read-type 14 | :initarg :type 15 | :initform nil 16 | :type (or null integer)) 17 | (%count :reader read-count 18 | :initarg :count 19 | :type integer))) 20 | 21 | 22 | (defclass tree-set-index-node (tree-mixin set-index-node) 23 | ()) 24 | 25 | 26 | (defclass set-index () 27 | ((%root :reader read-root 28 | :initarg :root) 29 | (%minimal-support :reader read-minimal-support 30 | :initarg :minimal-support) 31 | (%reverse-mapping :accessor access-reverse-mapping 32 | :initform nil) 33 | (%mapping :accessor access-mapping 34 | :initform nil) 35 | (%total-size :reader read-total-size 36 | :initarg :total-size))) 37 | 38 | 39 | (defclass set-in-index () 40 | ((%node :initarg :node 41 | :type (or null set-index-node) 42 | :reader read-node) 43 | (%path :initarg :path 44 | :type vector 45 | :reader read-path) 46 | (%index :initarg :index 47 | :initform nil 48 | :type set-index 49 | :reader read-index))) 50 | 51 | 52 | (defclass association-set (set-in-index) 53 | ((%apriori-node :initarg :apriori-node 54 | :reader read-apriori-node 55 | :initform nil 56 | :type (or null set-index-node)) 57 | (%apriori-path :initarg :apriori-path 58 | :reader read-apriori-path))) 59 | 60 | 61 | (defclass empty-mixin () 62 | ((%type-count :initarg :type-count 63 | :reader read-type-count 64 | :type non-negative-fixnum))) 65 | 66 | 67 | (defclass empty-set-in-index (empty-mixin set-in-index) 68 | ()) 69 | 70 | 71 | (defclass empty-association-set (empty-mixin association-set) 72 | ()) 73 | -------------------------------------------------------------------------------- /src/dicts/common.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-ds.dicts) 2 | 3 | 4 | (defclass lazy-box-dictionary (cl-ds.common:lazy-box-container lazy-dictionary) 5 | ()) 6 | 7 | 8 | (defmethod cl-ds:at ((container lazy-box-dictionary) location &rest more-locations) 9 | (assert (null more-locations)) 10 | (cl-ds.common:force-version container) 11 | (cl-ds:at (cl-ds.common:access-content container) location)) 12 | 13 | 14 | (defmethod cl-ds:become-lazy ((container cl-ds.dicts:fundamental-dictionary)) 15 | (make 'lazy-box-dictionary 16 | :content (cl-ds:become-transactional container))) 17 | 18 | 19 | (defmethod cl-ds:whole-range ((container lazy-box-dictionary)) 20 | (cl-ds.common:make-lazy-range cl-ds.common:forward-lazy-range 21 | container 22 | (cl-ds:whole-range container))) 23 | 24 | 25 | (defmethod cl-ds.meta:map-bucket ((container fundamental-hashing-dictionary) 26 | bucket 27 | function) 28 | (map nil 29 | (lambda (x) (funcall function 30 | (cons 31 | (cl-ds.common:hash-content-location x) 32 | (cl-ds.common:hash-dict-content-value x)))) 33 | bucket) 34 | bucket) 35 | 36 | 37 | (defmethod cl-ds.meta:map-bucket ((container fundamental-sparse-vector) 38 | bucket 39 | function) 40 | (funcall function bucket) 41 | bucket) 42 | -------------------------------------------------------------------------------- /src/dicts/docstrings.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-ds.dicts) 2 | 3 | (docs:define-docs 4 | :formatter docs.ext:rich-aggregating-formatter 5 | 6 | (type fundamental-dictionary 7 | (:description "Container that provides location to value mapping. Either ordered or unordered.")) 8 | 9 | (type fundamental-hashing-dictionary 10 | (:description "Dictionary that uses hashing function. Hashing function is assumed to return fixnum.")) 11 | 12 | (type functional-hashing-dictionary 13 | (:description "Functional variant of hashing a dictionary.")) 14 | 15 | (type mutable-hashing-dictionary 16 | (:description "Mutable variant of hashing a dictionary.")) 17 | 18 | (type transactional-hashing-dictionary 19 | (:description "Transactional variant of hashing a dictionary.")) 20 | 21 | (type lazy-hashing-dictionary 22 | (:description "Lazy variant of a hashing dictionary.")) 23 | 24 | (type mutable-dictionary 25 | (:description "Mutable variant of a dictionary.")) 26 | 27 | (type transactional-dictionary 28 | (:description "Transactional variant of a dictionary.")) 29 | 30 | (type functional-dictionary 31 | (:description "Functional variant of a dictionary.")) 32 | 33 | (type transactional-dictionary 34 | (:description "Transactional variant of a dictionary.")) 35 | 36 | (type lazy-dictionary 37 | (:description "Lazy variant of a dictionary.")) 38 | 39 | (function find-content 40 | (:description "Attempts to find element under LOCATION in the the bucket." 41 | :notes "This function accepts additional key arguments. In case of hashing dictionaries, one will be :hash that is expected to be a fixnum." 42 | :arguments ((container "Container that owns bucket. Acts as passed interface for method dispatch.") 43 | (bucket "Bucket that will be searched.") 44 | (location "Location that will be searched.")) 45 | :returns ("Element" 46 | "Boolean. T if element was found, NIL otherwise."))) 47 | 48 | (function single-element-p 49 | (:description "Checks if bucket holds just one element (if not, consider rehashing)." 50 | :arguments ((bucket "Bucket that will be checked.")) 51 | :returns "Boolean. T if only single element exists in bucket, NIL otherwise." 52 | :notes "This function will return NIL if bucket is empty."))) 53 | -------------------------------------------------------------------------------- /src/dicts/hamt/docstrings.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-ds.dicts.hamt) 2 | 3 | 4 | (docs:define-docs 5 | :formatter docs.ext:rich-aggregating-formatter 6 | 7 | (function make-functional-hamt-dictionary 8 | (:syntax "make-functional-hamt-dictionary hash-fn equal-fn &key max-depth => functional-hamt-dictionary" 9 | :arguments-and-values 10 | ((hash-fn "function that will be used to hash keys. Should return fixnum and be proper hashing function.") 11 | (equal-fn "function used to resolve conflicts.")) 12 | :description 13 | "Constructs and return new functional-hamt-dictionary" 14 | 15 | :returns 16 | "new instance of functional-hamt-dictionary." 17 | 18 | :notes "In theory HAMT can use infinite length of hash but this implementation uses 60 oldest bits at most.")) 19 | 20 | (function make-mutable-hamt-dictionary 21 | (:syntax "make-mutable-hamt-dictionary hash-fn equal-fn &key max-depth => mutable-hamt-dictionary" 22 | :arguments-and-values 23 | ((hash-fn "function that will be used to hash keys. Should return fixnum and be proper hashing function.") 24 | (equal-fn "function used to resolve conflicts.")) 25 | :description 26 | "Constructs and returns a new mutable-hamt-dictionary" 27 | 28 | :returns 29 | "new instance of mutable-hamt-dictionary." 30 | 31 | :notes "In theory HAMT can use infinite length of hash but this implementation uses 60 oldest bits at most.")) 32 | 33 | (function make-transactional-hamt-dictionary 34 | (:syntax "make-transactional-hamt-dictionary hash-fn equal-fn &key max-depth => mutable-hamt-dictionary" 35 | :arguments-and-values 36 | ((hash-fn "function that will be used to hash keys. Should return fixnum and be proper hashing function.") 37 | (equal-fn "function used to resolve conflicts.")) 38 | :description 39 | "Constructs and returns a new mutable-hamt-dictionary" 40 | 41 | :returns 42 | "new instance of transactional-hamt-dictionary." 43 | 44 | :notes "In theory HAMT can use infinite length of hash but this implementation uses 60 oldest bits at most.")) 45 | 46 | (type hamt-dictionary 47 | (:description "Root HAMT dictionary class.")) 48 | 49 | (type functional-hamt-dictionary 50 | (:description "HAMT dictionary that implements functional api.")) 51 | 52 | (type mutable-hamt-dictionary 53 | (:description "HAMT dictionary that implements mutable api.")) 54 | 55 | (type transactional-hamt-dictionary 56 | (:description "Transactional HAMT dictionary that implements mutable api."))) 57 | -------------------------------------------------------------------------------- /src/dicts/hamt/notes.org: -------------------------------------------------------------------------------- 1 | * Tasks 2 | ** TODO Needs implementation for the transactional variant of this code. 3 | [2018-11-11 nie] 4 | [[file:~/quicklisp/local-projects/cl-data-structures/src/dicts/hamt/api.lisp::(defmethod%20cl-ds:whole-range%20((container%20mutable-hamt-dictionary))]] 5 | -------------------------------------------------------------------------------- /src/dicts/hamt/range-test.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cl-user) 2 | (defpackage hamt-range-tests 3 | (:use :cl :prove :cl-ds :cl-ds.dicts.hamt 4 | :cl-data-structures.aux-package) 5 | (:export :run-suite)) 6 | (cl:in-package :hamt-range-tests) 7 | 8 | (plan 14) 9 | (let ((dict (make-mutable-hamt-dictionary #'identity #'eql)) 10 | (count 0)) 11 | (setf (cl-ds:at dict 5) 1) 12 | (setf (cl-ds:at dict 6) 2) 13 | (setf (cl-ds:at dict 7) 3) 14 | (setf (cl-ds:at dict 8) 4) 15 | (let ((range (cl-ds:whole-range dict))) 16 | (iterate 17 | (for (values key.value more) = (cl-ds:consume-front range)) 18 | (while more) 19 | (incf count) 20 | (collect key.value into result) 21 | (finally (setf result (sort result #'< :key #'car)) 22 | (prove:is result 23 | '((5 . 1) (6 . 2) (7 . 3) (8 . 4)) 24 | :test #'equal) 25 | (prove:is count 4)))) 26 | (let ((range (cl-ds:whole-range dict))) 27 | (iterate 28 | (repeat 4) 29 | (for key.value = (cl-ds:peek-front range)) 30 | (collect key.value into result) 31 | (finally (setf result (sort result #'< :key #'car)) 32 | (prove:is result 33 | '((5 . 1) (5 . 1) (5 . 1) (5 . 1)) 34 | :test #'equal)))) 35 | (let ((sum (~> dict 36 | cl-ds:whole-range 37 | (cl-ds.alg:accumulate #'+ :key #'cdr)))) 38 | (is sum 10)) 39 | (let ((sum (~> dict 40 | cl-ds:whole-range 41 | (cl-ds.alg:on-each (lambda (x) (* (cdr x) 2))) 42 | (cl-ds.alg:accumulate #'+)))) 43 | (is sum 20)) 44 | (let ((sum (~> dict 45 | cl-ds:whole-range 46 | (cl-ds.alg:on-each (curry #'* 2) :key #'cdr) 47 | (cl-ds.alg:accumulate #'+)))) 48 | (is sum 20)) 49 | (let ((divided-sum (~> dict 50 | cl-ds:whole-range 51 | (cl-ds.alg:group-by :key (compose #'evenp #'cdr)) 52 | (cl-ds.alg:accumulate #'+ :key #'cdr)))) 53 | (is (cl-ds:at divided-sum nil) 4) 54 | (is (cl-ds:at divided-sum t) 6))) 55 | 56 | (let ((dict (cl-ds:make-from-traversable 57 | (cl-ds.alg:chain 58 | (cl-ds:whole-range #((1 . 1) (2 . 2) (3 . 3))) 59 | (cl-ds:whole-range #((4 . 4) (5 . 5) (6 . 6)))) 60 | 'cl-ds.dicts.hamt:mutable-hamt-dictionary 61 | :hash-fn #'identity 62 | :equal-fn #'=))) 63 | (iterate 64 | (for i from 1 to 6) 65 | (is (cl-ds:at dict i) i))) 66 | 67 | (finalize) 68 | -------------------------------------------------------------------------------- /src/dicts/hamt/transactions-tests.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cl-user) 2 | (defpackage transactional-hamt-dictionary-tests 3 | (:use :cl :prove :cl-ds :cl-ds.dicts.hamt 4 | :cl-data-structures.aux-package) 5 | (:export :run-stress-test 6 | :run-suite)) 7 | (cl:in-package :transactional-hamt-dictionary-tests) 8 | 9 | (plan 48) 10 | (diag "Testing isolation of insert") 11 | (let ((dict (make-mutable-hamt-dictionary #'identity #'eql))) 12 | (iterate 13 | (for i below 8) 14 | (setf (at dict i) i)) 15 | (iterate 16 | (for i from 64) 17 | (repeat 8) 18 | (setf (at dict i) i)) 19 | (let ((trans-dict (become-transactional dict))) 20 | (iterate 21 | (for i from 8 below 16) 22 | (setf (at trans-dict i) i)) 23 | (iterate 24 | (for i from 8 below 16) 25 | (is (at trans-dict i) i)) 26 | (iterate 27 | (for i below 8) 28 | (ok (at trans-dict i))) 29 | (iterate 30 | (for i below 8) 31 | (is (at dict i) i :test #'eql)) 32 | (iterate 33 | (for i from 8 below 16) 34 | (setf (at trans-dict i) 666)) 35 | (iterate 36 | (for i from 8 below 16) 37 | (is (at trans-dict i) 666 :test #'eql))) 38 | (iterate 39 | (for i below 8) 40 | (is (at dict i) i)) 41 | (iterate 42 | (for i from 8 below 16) 43 | (ok (not (at dict i))))) 44 | (finalize) 45 | -------------------------------------------------------------------------------- /src/dicts/notes.org: -------------------------------------------------------------------------------- 1 | * Tasks 2 | ** TODO I should consider removing this function. It shouldn't be required to achieve composable containers. 3 | [2018-10-11 czw] 4 | [[file:~/quicklisp/local-projects/cl-data-structures/src/dicts/common.lisp::(defgeneric%20find-content%20(container%20bucket%20location%20&key%20&allow-other-keys))]] 5 | -------------------------------------------------------------------------------- /src/dicts/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | 3 | 4 | (defpackage :cl-data-structures.dicts 5 | (:use #:common-lisp 6 | #:cl-data-structures.aux-package) 7 | (:nicknames #:cl-ds.dicts) 8 | (:export 9 | #:fundamental-dictionary 10 | #:fundamental-hashing-dictionary 11 | #:fundamental-sparse-vector 12 | #:functional-sparse-vector 13 | #:mutable-sparse-vector 14 | #:transactional-sparse-vector 15 | #:functional-dictionary 16 | #:functional-hashing-dictionary 17 | #:hashing-dictionary 18 | #:lazy-dictionary 19 | #:lazy-hashing-dictionary 20 | #:make-bucket 21 | #:mutable-dictionary 22 | #:mutable-hashing-dictionary 23 | #:read-equal-fn 24 | #:read-hash-fn 25 | #:transactional-dictionary 26 | #:transactional-hashing-dictionary)) 27 | 28 | 29 | (defpackage :cl-data-structures.dicts.skip-list 30 | (:use #:common-lisp 31 | #:cl-data-structures.aux-package 32 | #:cl-data-structures.common.skip-list 33 | #:cl-data-structures.common.abstract) 34 | (:nicknames #:cl-ds.dicts.skip-list) 35 | (:export 36 | #:make-mutable-skip-list-dictionary 37 | #:mutable-skip-list-dictionary)) 38 | 39 | 40 | (defpackage :cl-data-structures.dicts.hamt 41 | (:use #:common-lisp 42 | #:cl-data-structures.aux-package 43 | #:cl-data-structures.common.hamt 44 | #:cl-data-structures.common.abstract) 45 | (:nicknames #:cl-ds.dicts.hamt) 46 | (:export 47 | #:functional-hamt-dictionary 48 | #:hamt-dictionary 49 | #:hamt-dictionary-at 50 | #:hamt-dictionary-size 51 | #:make-functional-hamt-dictionary 52 | #:make-transactional-hamt-dictionary 53 | #:make-mutable-hamt-dictionary 54 | #:mutable-hamt-dictionary 55 | #:read-max-depth 56 | #:transactional-hamt-dictionary)) 57 | 58 | 59 | (defpackage :cl-data-structures.dicts.srrb 60 | (:use #:common-lisp 61 | #:cl-data-structures.aux-package) 62 | (:nicknames #:cl-ds.dicts.srrb) 63 | (:export 64 | #:access-shift 65 | #:access-tree 66 | #:access-tree-size 67 | #:access-tail-mask 68 | #:access-tail 69 | #:read-element-type 70 | #:access-tree-index-bound 71 | #:functional-sparse-rrb-vector 72 | #:functional-sparse-rrb-vector-grow 73 | #:insert-tail 74 | #:insert-tail! 75 | #:shift-for-position 76 | #:make-functional-sparse-rrb-vector 77 | #:make-mutable-sparse-rrb-vector 78 | #:make-transactional-sparse-rrb-vector 79 | #:mutable-sparse-rrb-vector 80 | #:mutable-sparse-rrb-vector-grow 81 | #:scan-index-bound 82 | #:sparse-rrb-vector-at 83 | #:transactional-insert-tail! 84 | #:transactional-sparse-rrb-vector 85 | #:transactional-sparse-rrb-vector-grow 86 | #:access-index-bound)) 87 | -------------------------------------------------------------------------------- /src/dicts/skip-list/tests.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-ds.dicts.skip-list) 2 | 3 | (prove:plan 13) 4 | 5 | (let ((dict (cl-ds:make-from-traversable 6 | '((1 . 1) (2 . 2) (3 . 3) (4 . 4) (5 . 5)) 7 | 'mutable-skip-list-dictionary 8 | #'< #'=))) 9 | (prove:is (cl-ds:size dict) 5) 10 | (iterate 11 | (for i from 1 to 5) 12 | (prove:is (cl-ds:at dict i) i)) 13 | (iterate 14 | (for i from 1 to 5) 15 | (cl-ds:update! dict i (1+ i))) 16 | (iterate 17 | (for i from 1 to 5) 18 | (prove:is (cl-ds:at dict i) (1+ i))) 19 | (prove:is (~> dict cl-ds.alg:to-list) 20 | '((1 . 2) (2 . 3) (3 . 4) (4 . 5) (5 . 6)) 21 | :test #'equal) 22 | (prove:is (cl-ds:lower-bound dict 3) 3)) 23 | 24 | (let ((dict (cl-ds:make-from-traversable 25 | (mapcar (lambda (x) (cons x x)) '(147865 138799 129983 119199 102141 11920)) 26 | 'mutable-skip-list-dictionary 27 | #'> #'=))) 28 | (prove:is (cl-ds:size dict) 6) 29 | (prove:is (cl-ds.alg:count-elements (cl-ds:between* dict :low 102141 :high 0)) 30 | 2)) 31 | 32 | (prove:finalize) 33 | -------------------------------------------------------------------------------- /src/dicts/srrb/docstrings.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-ds.dicts.srrb) 2 | 3 | 4 | (docs:define-docs 5 | :formatter docs.ext:rich-aggregating-formatter 6 | 7 | (type mutable-sparse-rrb-vector 8 | (:description "SRRB sparse vector that implements mutable api.")) 9 | 10 | (type functional-sparse-rrb-vector 11 | (:description "SRRB sparse vector that implements mutable api.")) 12 | 13 | (type transactional-sparse-rrb-vector 14 | (:description "Transactional SRRB sparse vector that implements mutable api.")) 15 | 16 | (function make-functional-sparse-rrb-vector 17 | (:description "Constructs and returns a functional variant of the sparse rrb vector.")) 18 | 19 | (function make-mutable-sparse-rrb-vector 20 | (:description "Constructs and returns a mutable variant of the sparse rrb vector.")) 21 | 22 | (function make-transactional-sparse-rrb-vector 23 | (:description "Constructs and returns a transactional variant of the sparse rrb vector.")) 24 | ) 25 | -------------------------------------------------------------------------------- /src/dicts/srrb/notes.org: -------------------------------------------------------------------------------- 1 | * Tasks 2 | ** DONE Should walk over the tree to find the right most node index! 3 | CLOSED: [2018-10-16 wto 12:24] 4 | [2018-10-11 czw] 5 | [[file:~/quicklisp/local-projects/cl-data-structures/src/dicts/srrb/internal.lisp::(defun%20scan-index-bound%20(structure)]] 6 | ** TODO Should impement destructive, transactional na functional variants of this function. 7 | [2018-10-11 czw] 8 | [[file:~/quicklisp/local-projects/cl-data-structures/src/dicts/srrb/internal.lisp::(defun%20tree-without-in-last-node%20(operation%20structure%20container%20position%20all)]] 9 | ** DONE Need to add test for this. Should be possible to do so even now. 10 | CLOSED: [2018-10-16 wto 12:22] 11 | [2018-10-15 pon] 12 | [[file:~/quicklisp/local-projects/cl-data-structures/src/dicts/srrb/internal.lisp::(defun%20scan-index-bound%20(structure)]] 13 | ** DONE Should recursivly go into the last node. Try removing, ensure that no empty nodes exist. 14 | CLOSED: [2018-10-16 wto 16:10] 15 | [2018-10-16 wto] 16 | [[file:~/quicklisp/local-projects/cl-data-structures/src/dicts/srrb/internal.lisp::(defun%20tree-without-in-last-node!%20(operation%20structure%20container%20position%20all)]] 17 | ** TODO Add tests for tree-without-in-last-node! 18 | [2018-10-16 wto] 19 | [[file:~/quicklisp/local-projects/cl-data-structures/src/dicts/srrb/internal.lisp::(defun%20tree-without-in-last-node!%20(operation%20structure%20container%20position%20all)]] 20 | ** TODO Need to correct shift (if changed). 21 | [2018-10-16 wto] 22 | [[file:~/quicklisp/local-projects/cl-data-structures/src/dicts/srrb/internal.lisp::(defun%20tree-without-in-last-node!%20(operation%20structure%20container%20position%20all)]] 23 | -------------------------------------------------------------------------------- /src/dicts/srrb/types.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.dicts.srrb) 2 | 3 | 4 | (defclass fundamental-sparse-rrb-vector (cl-ds.dicts:fundamental-sparse-vector) 5 | ((%tree :initarg :tree 6 | :initform cl-ds.meta:null-bucket 7 | :accessor access-tree) 8 | (%tail :initarg :tail 9 | :accessor access-tail 10 | :initform nil) 11 | (%tail-mask :initarg :tail-mask 12 | :initform 0 13 | :accessor access-tail-mask) 14 | (%shift :initarg :shift 15 | :accessor access-shift 16 | :initform 0) 17 | (%tree-size :initarg :tree-size 18 | :accessor access-tree-size 19 | :initform 0) 20 | (%tree-index-bound :initarg :tree-index-bound 21 | :initform 0 22 | :accessor access-tree-index-bound) 23 | (%index-bound :initarg :index-bound 24 | :accessor access-index-bound 25 | :initform cl-ds.common.rrb:+maximum-children-count+) 26 | (%element-type :initarg :element-type 27 | :reader read-element-type 28 | :reader cl-ds:type-specialization 29 | :initform t))) 30 | 31 | 32 | (defmethod cl-ds.utils:cloning-information append 33 | ((vector fundamental-sparse-rrb-vector)) 34 | '((:tree access-tree) 35 | (:tail access-tail) 36 | (:tail-mask access-tail-mask) 37 | (:shift access-shift) 38 | (:tree-size access-tree-size) 39 | (:tree-index-bound access-tree-index-bound) 40 | (:index-bound access-index-bound) 41 | (:element-type read-element-type))) 42 | 43 | 44 | (defclass mutable-sparse-rrb-vector (cl-ds:mutable 45 | cl-ds.dicts:mutable-sparse-vector 46 | fundamental-sparse-rrb-vector) 47 | ()) 48 | 49 | 50 | (defclass functional-sparse-rrb-vector (cl-ds:functional 51 | cl-ds.dicts:functional-sparse-vector 52 | fundamental-sparse-rrb-vector) 53 | ()) 54 | 55 | 56 | (defclass transactional-sparse-rrb-vector 57 | (cl-ds:transactional 58 | cl-ds.dicts:transactional-sparse-vector 59 | cl-ds.common.abstract:fundamental-ownership-tagged-object 60 | mutable-sparse-rrb-vector) 61 | () 62 | (:default-initargs :ownership-tag (cl-ds.common.abstract:make-ownership-tag))) 63 | -------------------------------------------------------------------------------- /src/dicts/trait-classes.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-ds.dicts) 2 | 3 | 4 | (defclass fundamental-dictionary (cl-ds:fundamental-container) 5 | ()) 6 | 7 | 8 | (defclass fundamental-hashing-dictionary (fundamental-dictionary) 9 | ((%hash-fn 10 | :type (-> (t) fixnum) 11 | :initarg :hash-fn 12 | :reader read-hash-fn) 13 | (%equal-fn 14 | :type (-> (t t) boolean) 15 | :initarg :equal-fn 16 | :reader read-equal-fn))) 17 | 18 | 19 | (defclass fundamental-sparse-vector (fundamental-dictionary) 20 | ()) 21 | 22 | 23 | (defclass functional-sparse-vector (fundamental-sparse-vector) 24 | ()) 25 | 26 | 27 | (defclass mutable-sparse-vector (fundamental-sparse-vector) 28 | ()) 29 | 30 | 31 | (defclass transactional-sparse-vector (mutable-sparse-vector) 32 | ()) 33 | 34 | 35 | (defclass functional-dictionary (fundamental-dictionary cl-ds:functional) 36 | ()) 37 | 38 | 39 | (defclass lazy-dictionary (cl-ds:lazy functional-dictionary) 40 | ()) 41 | 42 | 43 | (defclass mutable-dictionary (fundamental-dictionary cl-ds:mutable) 44 | ()) 45 | 46 | 47 | (defclass transactional-dictionary (mutable-dictionary cl-ds:transactional) 48 | ()) 49 | 50 | 51 | (defclass mutable-hashing-dictionary (fundamental-hashing-dictionary mutable-dictionary) 52 | ()) 53 | 54 | 55 | (defclass functional-hashing-dictionary (fundamental-hashing-dictionary functional-dictionary) 56 | ()) 57 | 58 | 59 | (defclass transactional-hashing-dictionary (fundamental-hashing-dictionary transactional-dictionary) 60 | ()) 61 | 62 | 63 | (defclass lazy-hashing-dictionary (functional-hashing-dictionary lazy-dictionary) 64 | ()) 65 | -------------------------------------------------------------------------------- /src/file-system/notes.org: -------------------------------------------------------------------------------- 1 | * Tasks 2 | ** TODO clone should be thread safe 3 | [2018-11-20 wto] 4 | [[file:~/quicklisp/local-projects/cl-data-structures/src/file-system/line-by-line.lisp::(defmethod%20cl-ds:clone%20((range%20line-by-line-range))]] 5 | -------------------------------------------------------------------------------- /src/file-system/package.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cl-user) 2 | 3 | 4 | (defpackage :cl-data-structures.file-system 5 | (:use #:cl-data-structures.aux-package #:common-lisp) 6 | (:nicknames #:cl-ds.fs) 7 | (:shadow #:find) 8 | (:export 9 | #:close-inner-stream 10 | #:find 11 | #:line-by-line 12 | #:file-range-mixin 13 | #:close-stream 14 | #:open-stream-designator 15 | #:stream-designator-p 16 | #:access-reached-end 17 | #:access-current-position 18 | #:ensure-stream 19 | #:tokenize 20 | #:command 21 | #:read-path 22 | #:words 23 | #:with-file-ranges)) 24 | -------------------------------------------------------------------------------- /src/file-system/tokenize.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.file-system) 2 | 3 | 4 | (defclass tokenizing-range (cl-ds:chunking-mixin 5 | file-range-mixin 6 | cl-ds:fundamental-forward-range) 7 | ((%path :initarg :path 8 | :type (or string pathname) 9 | :reader read-path) 10 | (%regex :initarg :regex 11 | :reader read-regex)) 12 | (:default-initargs :initial-position 0)) 13 | 14 | 15 | (defmethod cl-ds:clone ((range tokenizing-range)) 16 | (make 'tokenizing-range 17 | :path (read-path range) 18 | :regex (read-regex range) 19 | :reached-end (access-reached-end range) 20 | :initial-position (access-current-position range))) 21 | 22 | 23 | (defmethod cl-ds:peek-front ((range tokenizing-range)) 24 | (if (access-reached-end range) 25 | (values nil nil) 26 | (iterate 27 | (with stream = (ensure-stream range)) 28 | (with buffer = (make-array 0 29 | :element-type 'character 30 | :adjustable t 31 | :fill-pointer 0)) 32 | (with regex = (read-regex range)) 33 | (with file-position = (file-position stream)) 34 | (for character = (read-char stream :eof-value nil)) 35 | (when (null character) 36 | (leave (values nil nil))) 37 | (vector-push-extend character buffer) 38 | (when (cl-ppcre:all-matches regex buffer) 39 | (unless (file-position (read-stream range) 40 | file-position) 41 | (error 'cl-ds:file-releated-error 42 | :path (read-path range) 43 | :format-control "Can't change position in the stream.")) 44 | (leave (values buffer t)))))) 45 | 46 | 47 | (defmethod cl-ds:consume-front ((range tokenizing-range)) 48 | (if (access-reached-end range) 49 | (values nil nil) 50 | (iterate 51 | (with stream = (ensure-stream range)) 52 | (with buffer = (make-array 0 53 | :element-type 'character 54 | :adjustable t 55 | :fill-pointer 0)) 56 | (with regex = (read-regex range)) 57 | (for character = (read-char stream :eof-value nil)) 58 | (setf (access-current-position range) (file-position stream)) 59 | (when (null character) 60 | (setf (access-reached-end range) t) 61 | (close-stream range) 62 | (leave (values nil nil))) 63 | (vector-push-extend character buffer) 64 | (when (cl-ppcre:all-matches regex buffer) 65 | (leave (values buffer t)))))) 66 | 67 | 68 | (defmethod cl-ds:traverse ((range tokenizing-range) function) 69 | (cl-ds.fs:with-file-ranges ((r range)) 70 | (declare (ignore r)) 71 | (call-next-method))) 72 | 73 | 74 | (defun tokenize (path regex &key case-insensitive-mode) 75 | (check-type path stream-designator) 76 | (let ((scanner (cl-ppcre:create-scanner 77 | regex :case-insensitive-mode case-insensitive-mode))) 78 | (make 'tokenizing-range 79 | :path path 80 | :regex scanner))) 81 | -------------------------------------------------------------------------------- /src/file-system/unix.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.file-system) 2 | 3 | 4 | (defclass command () 5 | ((%command-string :type string 6 | :initarg :command-string 7 | :reader read-command-string))) 8 | 9 | 10 | (defmethod print-object ((object command) stream) 11 | (print-unreadable-object (object stream) 12 | (format stream "~a" (read-command-string object)))) 13 | 14 | 15 | (defmethod stream-designator-p ((designator command)) 16 | t) 17 | 18 | 19 | (defun command (format-control-string &rest format-arguments) 20 | (declare (dynamic-extent format-arguments)) 21 | (check-type format-control-string string) 22 | (make 'command 23 | :command-string (apply #'format nil 24 | format-control-string format-arguments))) 25 | 26 | 27 | (defmethod open-stream-designator ((designator command) &key (direction :input) (element-type 'character) (external-format uiop/stream:*utf-8-external-format*)) 28 | (eswitch (direction) 29 | (:input 30 | (~> designator read-command-string 31 | (uiop:launch-program :output :stream 32 | :force-shell nil 33 | :element-type element-type 34 | :external-format external-format) 35 | uiop/launch-program:process-info-output)) 36 | (:output 37 | (~> designator read-command-string 38 | (uiop:launch-program :input :stream 39 | :force-shell nil 40 | :element-type element-type 41 | :external-format external-format) 42 | uiop/launch-program:process-info-input)) 43 | (:io 44 | (bind (((:accessors uiop/launch-program:process-info-output uiop/launch-program:process-info-input) 45 | (~> designator read-command-string 46 | (uiop:launch-program :input :stream :output :stream :force-shell nil 47 | :element-type element-type 48 | :external-format external-format)))) 49 | (values (make-two-way-stream uiop/launch-program:process-info-output 50 | uiop/launch-program:process-info-input) 51 | uiop/launch-program:process-info-output 52 | uiop/launch-program:process-info-input))))) 53 | -------------------------------------------------------------------------------- /src/math/absolute-value-norm.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.math) 2 | 3 | 4 | (cl-ds.alg.meta:define-aggregation-function 5 | absolute-value-norm absolute-value-norm-function 6 | 7 | (:range &key key) 8 | 9 | (:range &key (key #'identity)) 10 | 11 | (%sum) 12 | 13 | ((setf %sum 0)) 14 | 15 | ((element) 16 | (incf %sum (abs element))) 17 | 18 | (%sum)) 19 | -------------------------------------------------------------------------------- /src/math/chi-squared-tests.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | 3 | (defpackage chi-squared-test (:use #:prove #:cl)) 4 | (cl:in-package #:chi-squared-test) 5 | 6 | (plan 1) 7 | 8 | (let* ((data (list #2A((10 50) (80 20)))) 9 | (pval (cl-ds.math:chi-squared data #'aref 10 | (list (cl-ds:field :test 'eql 11 | :classes '(0 1)) 12 | (cl-ds:field :test 'eql 13 | :classes '(0 1)))))) 14 | (ok (< pval 0.05))) 15 | 16 | (finalize) 17 | -------------------------------------------------------------------------------- /src/math/co-occurence-table.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.math) 2 | 3 | 4 | (cl-ds.alg.meta:define-aggregation-function 5 | co-occurence-table co-occurence-table-function 6 | 7 | (:range test-functions &key key after) 8 | (:range test-functions &key (key #'identity) (after #'identity)) 9 | 10 | (%result %test-functions) 11 | 12 | ((setf %test-functions test-functions 13 | %result (make-array (make-list (length %test-functions) 14 | :initial-element 2) 15 | :element-type 'non-negative-integer 16 | :initial-element 0))) 17 | 18 | ((element) 19 | (let* ((address (map 'list 20 | (lambda (fn) 21 | (if (funcall fn element) 22 | 0 1)) 23 | %test-functions))) 24 | (apply #'(setf aref) 25 | (1+ (apply #'aref %result address)) 26 | %result address) 27 | %result)) 28 | 29 | (%result)) 30 | -------------------------------------------------------------------------------- /src/math/entropy.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.math) 2 | 3 | 4 | (cl-ds.alg.meta:define-aggregation-function 5 | entropy entropy-function 6 | 7 | (:range &key key test count-fn size after) 8 | 9 | (:range &key 10 | (key #'identity) 11 | (test 'eql) 12 | (size 16) 13 | (after #'identity) 14 | (count-fn (constantly 1))) 15 | 16 | ((%table hash-table) 17 | (%total-count integer) 18 | (%count-fn function)) 19 | 20 | ((ensure-functionf count-fn) 21 | (setf %table (make-hash-table :test test :size size) 22 | %count-fn (ensure-function count-fn) 23 | %total-count 0)) 24 | 25 | ((element) 26 | (let ((count (the integer (funcall %count-fn element)))) 27 | (incf %total-count count) 28 | (incf (gethash element %table 0) count))) 29 | 30 | ((- (iterate 31 | (for (class count) in-hashtable %table) 32 | (for prob = (/ count %total-count)) 33 | (assert (<= prob 1.0)) 34 | (sum (* prob (log prob))))))) 35 | -------------------------------------------------------------------------------- /src/math/gini-impurity.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.math) 2 | 3 | 4 | (cl-ds.alg.meta:define-aggregation-function 5 | gini-impurity gini-impurity-function 6 | 7 | (:range &key key test size count-fn) 8 | 9 | (:range &key (key #'identity) (test 'eql) 10 | (size 16) (count-fn (constantly 1))) 11 | 12 | (%table %total-count %count-fn) 13 | 14 | ((ensure-functionf count-fn) 15 | (setf %table (make-hash-table :test test :size size) 16 | %count-fn count-fn 17 | %total-count 0.0)) 18 | 19 | ((element) 20 | (let ((count (funcall %count-fn element))) 21 | (incf %total-count count) 22 | (incf (gethash element %table 0.0) count))) 23 | 24 | ((iterate 25 | (for (class count) in-hashtable %table) 26 | (for prob = (/ count %total-count)) 27 | (assert (<= prob 1)) 28 | (sum (* prob (- 1.0 prob)))))) 29 | -------------------------------------------------------------------------------- /src/math/hodges-lehmann.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.math) 2 | 3 | 4 | (defun calculate-hodges-lehmann-estimator (parallel vector &aux (length (length vector))) 5 | (declare (type (cl-ds.utils:extendable-vector t) vector)) 6 | (cond ((zerop length) 0.0) 7 | ((= length 1) (first-elt vector)) 8 | (t 9 | (bind ((length (length vector)) 10 | ((:dflet index (i j)) 11 | (+ (- (* length i) 12 | (/ (* i (1+ i)) 2) 13 | i) 14 | j)) 15 | (median-length (1+ (index (1- length) (1- length)))) 16 | (middle (truncate median-length 2)) 17 | (median-buffer (make-array median-length :element-type 'double-float)) 18 | (indexes (iterate 19 | (with result = (make-array length)) 20 | (for i from 0 below length) 21 | (setf (aref result i) i) 22 | (finally (return result)))) 23 | ((:dflet average-of-pairs (i)) 24 | (iterate 25 | (for j from i below length) 26 | (for index = (index i j)) 27 | (setf (aref median-buffer index) 28 | (coerce (/ (+ (aref vector i) 29 | (aref vector j)) 30 | 2) 31 | 'double-float))))) 32 | (funcall (if parallel #'lparallel:pmap #'map) 33 | nil #'average-of-pairs indexes) 34 | (setf median-buffer (funcall (if parallel #'lparallel:psort #'sort) 35 | median-buffer #'<)) 36 | (if (oddp median-length) 37 | (aref median-buffer middle) 38 | (/ (+ (aref median-buffer middle) 39 | (aref median-buffer (1- middle))) 40 | 2)))))) 41 | 42 | 43 | (cl-ds.alg.meta:define-aggregation-function 44 | hodges-lehmann-estimator hodges-lehmann-estimator-function 45 | 46 | (:range &key key parallel after) 47 | (:range &key (key #'identity) (parallel nil) (after #'identity)) 48 | 49 | ((%data (cl-ds.utils:extendable-vector t)) (%parallel boolean)) 50 | 51 | ((setf %data (vect) 52 | %parallel parallel)) 53 | 54 | ((element) 55 | (vector-push-extend element %data)) 56 | 57 | ((calculate-hodges-lehmann-estimator %parallel %data))) 58 | -------------------------------------------------------------------------------- /src/math/median-absolute-deviation.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.math) 2 | 3 | 4 | (cl-ds.alg.meta:define-aggregation-function 5 | median-absolute-deviation median-absolute-deviation-function 6 | 7 | (:range &key key) 8 | (:range &key (key #'identity)) 9 | 10 | (%data) 11 | 12 | ((setf %data (vect))) 13 | 14 | ((element) 15 | (vector-push-extend element %data)) 16 | 17 | ((let ((vector %data)) 18 | (declare (type (cl-ds.utils:extendable-vector t) vector)) 19 | (setf vector (sort vector #'<)) 20 | (bind ((length (length vector)) 21 | (middle (truncate length 2)) 22 | (median (if (oddp length) 23 | (aref vector middle) 24 | (coerce (/ (+ (aref vector middle) 25 | (aref vector (1- middle))) 26 | 2) 27 | 'single-float)))) 28 | (declare (type real median)) 29 | (map-into vector 30 | (lambda (x) 31 | (declare (type real x)) 32 | (abs (- x median))) 33 | vector) 34 | (setf vector (sort vector #'<)) 35 | (if (oddp length) 36 | (aref vector middle) 37 | (/ (+ (aref vector middle) 38 | (aref vector (1- middle))) 39 | 2)))))) 40 | -------------------------------------------------------------------------------- /src/math/moments-tests.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | (defpackage moments-tests 3 | (:use :cl :cl-ds :prove :cl-data-structures.aux-package)) 4 | 5 | (cl:in-package #:moments-tests) 6 | 7 | 8 | (plan 4) 9 | 10 | 11 | (bind ((xpr (xpr (:x 0) 12 | (when (< x 100) 13 | (send-recur 5 :x (1+ x))))) 14 | (moments (cl-ds.math:moments xpr 2 3 5))) 15 | (is (cl-ds:size moments) 3 :test #'=) 16 | (is (cl-ds:at moments 2) 0 :test #'=) 17 | (is (cl-ds:at moments 3) 0 :test #'=) 18 | (is (cl-ds:at moments 4) 0 :test #'=)) 19 | 20 | 21 | (finalize) 22 | -------------------------------------------------------------------------------- /src/math/moments.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.math) 2 | 3 | 4 | (cl-ds.alg.meta:define-aggregation-function 5 | moments moments-function 6 | 7 | (:range from count about &key key after) 8 | 9 | (:range from count about &key (key #'identity) (after #'identity)) 10 | 11 | (%moments %start %count %lambdas) 12 | 13 | ((setf %lambdas (make-array count) 14 | %moments (make-array count :initial-element 0.0 15 | :element-type 'single-float) 16 | %count 0 17 | %start from) 18 | (iterate 19 | (for i from from) 20 | (for index from 0 below count) 21 | (setf (aref %lambdas index) (let ((power i)) 22 | (lambda (value) 23 | (expt (- value about) power)))))) 24 | 25 | ((element) 26 | (incf %count) 27 | (iterate 28 | (for i from 0 below (length %lambdas)) 29 | (incf (aref %moments i) (funcall (aref %lambdas i) element)))) 30 | 31 | ((map-into %moments (rcurry #'/ %count) %moments) 32 | (make-instance 'cl-ds.adapters:offset-vector-range 33 | :vector %moments 34 | :offset %start 35 | :upper-bound (length %moments)))) 36 | -------------------------------------------------------------------------------- /src/math/mutual-information-tests.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | (defpackage mutual-information-tests 3 | (:use :cl :prove :cl-data-structures.aux-package)) 4 | 5 | (cl:in-package #:mutual-information-tests) 6 | 7 | (plan 3) 8 | 9 | (let* ((data #((1 . 2) (3 . 2) (4 . 2) (5 . 2))) 10 | (mi (cl-ds.math:mutual-information data 11 | (list 12 | (cl-ds:field :name :first 13 | :type :discrete 14 | :key #'car) 15 | (cl-ds:field :name :second 16 | :type :discrete 17 | :key #'cdr))))) 18 | (is (cl-ds:at mi :second) 0.0 :test #'=)) 19 | 20 | (let* ((data #((1 . 2) (3 . 2) (4 . 2) (5 . 2))) 21 | (mi (cl-ds.math:mutual-information data 22 | (list 23 | (cl-ds:field :name :first 24 | :type :continues 25 | :split-points-count 8 26 | :key #'car) 27 | (cl-ds:field :name :second 28 | :type :discrete 29 | :key #'cdr))))) 30 | (is (cl-ds:at mi :second) 0.0 :test #'=)) 31 | 32 | (let* ((data #((1 . 2) (2 . 3) (3 . 2) (4 . 1) (2 . 3) (2 . 3))) 33 | (mi (cl-ds.math:optimal-split-point data 34 | (list 35 | (cl-ds:field :name :first 36 | :type :continues 37 | :split-points-count 3 38 | :key #'car) 39 | (cl-ds:field :name :second 40 | :type :discrete 41 | :key #'cdr))))) 42 | (is (car (cl-ds:at mi :second)) 3 :test #'=)) 43 | 44 | (finalize) 45 | -------------------------------------------------------------------------------- /src/math/package.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | 3 | 4 | (defpackage :cl-data-structures.math 5 | (:use #:common-lisp #:cl-data-structures.aux-package) 6 | (:shadow #:variance #:standard-deviation) 7 | (:nicknames #:cl-ds.math) 8 | (:export 9 | #:absolute-value-norm 10 | #:array-average 11 | #:array-geometric-average 12 | #:array-harmonic-average 13 | #:array-sum 14 | #:average 15 | #:beta0 16 | #:beta1 17 | #:bootstrap 18 | #:co-occurence-table 19 | #:entropy 20 | #:fast-map 21 | #:geometric-average 22 | #:gini-impurity 23 | #:harmonic-average 24 | #:harmonic-average-mutual-information 25 | #:hidden-markov-model-generator 26 | #:hodges-lehmann-estimator 27 | #:median-absolute-deviation 28 | #:moments 29 | #:moving-average 30 | #:mutual-information 31 | #:mutual-information-matrix 32 | #:optimal-split-point 33 | #:simple-linear-regression 34 | #:standard-deviation 35 | #:sum 36 | #:variance)) 37 | -------------------------------------------------------------------------------- /src/math/simple-linear-regression-tests.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | (defpackage simple-linear-regression-tests 3 | (:use :cl-ds :cl :prove :cl-data-structures.aux-package)) 4 | 5 | (cl:in-package #:simple-linear-regression-tests) 6 | 7 | 8 | (plan 2) 9 | 10 | 11 | (bind ((xpr (xpr (:x 0) 12 | (when (< x 100) 13 | (send-recur (list x (1+ (* 2 x))) 14 | :x (1+ x))))) 15 | (result (cl-ds.math::simple-linear-regression 16 | xpr 17 | #'first 18 | (cl-ds.math:average xpr :key #'first) 19 | #'second 20 | (cl-ds.math:average xpr :key #'second)))) 21 | (is (cl-ds.math:beta1 result) 2 :test #'=) 22 | (is (cl-ds.math:beta0 result) 1 :test #'=)) 23 | 24 | 25 | (finalize) 26 | -------------------------------------------------------------------------------- /src/math/simple-linear-regression.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.math) 2 | 3 | 4 | (defclass linear-regression-fit (c2mop:funcallable-standard-object) 5 | ((%beta1 :initarg :beta1 6 | :accessor beta1) 7 | (%beta0 :initarg :beta0 8 | :accessor beta0)) 9 | (:metaclass c2mop:funcallable-standard-class)) 10 | 11 | 12 | (defmethod initialize-instance :after ((obj linear-regression-fit) &rest rest) 13 | (declare (ignore rest)) 14 | (c2mop:set-funcallable-instance-function obj (lambda (x) 15 | (+ (* (beta1 obj) x) 16 | (beta0 obj))))) 17 | 18 | 19 | (cl-ds.alg.meta:define-aggregation-function 20 | simple-linear-regression 21 | simple-linear-regression-function 22 | 23 | (:range x-key average-x y-key average-y &key key) 24 | (:range x-key average-x y-key average-y &key (key #'identity)) 25 | 26 | (%x-key %y-key %average-x %average-y %yy %xy %xx) 27 | 28 | ((setf %x-key x-key 29 | %y-key y-key 30 | %average-x average-x 31 | %average-y average-y 32 | %yy 0 33 | %xy 0 34 | %xx 0)) 35 | 36 | ((element) 37 | (let ((x (funcall %x-key element)) 38 | (y (funcall %y-key element))) 39 | (incf %yy (expt (- y %average-y) 2)) 40 | (incf %xy (* (- y %average-y) (- x %average-x))) 41 | (incf %xx (expt (- x %average-x) 2)))) 42 | 43 | ((let* ((beta1 (/ %xy %xx)) 44 | (beta0 (- %average-y (* beta1 %average-x)))) 45 | (make 'linear-regression-fit 46 | :beta0 beta0 47 | :beta1 beta1)))) 48 | -------------------------------------------------------------------------------- /src/math/standard-deviation.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.math) 2 | 3 | 4 | (cl-ds.alg.meta:define-aggregation-function 5 | standard-deviation 6 | standard-deviation-function 7 | 8 | (:range around &key key after) 9 | (:range around &key (key #'identity) (after #'identity)) 10 | 11 | (%count %sum %average) 12 | 13 | ((setf %count 0 14 | %average around 15 | %sum 0)) 16 | 17 | ((element) 18 | (incf %count) 19 | (incf %sum (expt (- element %average) 2))) 20 | 21 | ((sqrt (/ %sum %count)))) 22 | -------------------------------------------------------------------------------- /src/math/sum.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.math) 2 | 3 | 4 | (cl-ds.alg.meta:define-aggregation-function sum sum-function 5 | (:range &key key sum after) 6 | (:range &key (key #'identity) (sum 0) (after #'identity)) 7 | ((%sum number)) 8 | ((setf %sum sum)) 9 | ((element) 10 | (check-type element number) 11 | (incf %sum element)) 12 | (%sum)) 13 | 14 | 15 | (cl-ds.alg.meta:define-aggregation-function array-sum array-sum-function 16 | (:range &key key sum after) 17 | (:range &key (key #'identity) (sum nil) (after #'identity)) 18 | ((%sum (or null array))) 19 | ((if (null sum) 20 | (setf %sum nil) 21 | (setf %sum (copy-array sum)))) 22 | ((element) 23 | (check-type element array) 24 | (if (null %sum) 25 | (setf %sum (copy-array element)) 26 | (iterate 27 | (for i from 0 below (array-total-size %sum)) 28 | (incf (row-major-aref %sum i) (row-major-aref element i))))) 29 | (%sum)) 30 | -------------------------------------------------------------------------------- /src/math/variance.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.math) 2 | 3 | 4 | (cl-ds.alg.meta:define-aggregation-function variance variance-function 5 | (:range around &key key biased) 6 | (:range around &key (key #'identity) (biased t)) 7 | ((%count integer) (%sum number) (%biased t) (%average number)) 8 | 9 | ((setf %count 0 10 | %average around 11 | %sum 0 12 | %biased biased)) 13 | 14 | ((element) 15 | (incf %count) 16 | (incf %sum (expt (- element %average) 2))) 17 | 18 | ((/ %sum (if %biased %count (1- %count))))) 19 | -------------------------------------------------------------------------------- /src/metric-space/api.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.metric-space) 2 | 3 | 4 | (defmethod cl-ds:put! ((container mutable-metric-space-set) item) 5 | (cl-ds.meta:position-modification #'cl-ds:put! container container item)) 6 | 7 | 8 | (defmethod cl-ds:erase! ((container mutable-metric-space-set) item) 9 | (cl-ds.meta:position-modification #'cl-ds:erase! container container item)) 10 | -------------------------------------------------------------------------------- /src/metric-space/common.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.metric-space) 2 | 3 | 4 | (defgeneric distance (container bucket element) 5 | (:method ((container metric-space-set) 6 | (bucket t) 7 | (element t)) 8 | (funcall (read-metric-fn container) bucket element))) 9 | -------------------------------------------------------------------------------- /src/metric-space/docstrings.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.metric-space) 2 | 3 | 4 | (docs:define-docs 5 | :formatter docs.ext:rich-aggregating-formatter 6 | 7 | (type metric-space-dictionary 8 | (:description "Fundamental class for all metric-space-dictionaries")) 9 | 10 | (type mutable-metric-space-dictionary 11 | (:description "Fundamental class for all mutable metric space dictionaries")) 12 | 13 | (type metric-space-set 14 | (:description "Fundamental class for all metric space sets.")) 15 | 16 | (type mutable-metric-space-set 17 | (:description "Fundamental class for all mutable metric space sets."))) 18 | -------------------------------------------------------------------------------- /src/metric-space/egnat/api.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.metric-space.egnat) 2 | 3 | 4 | (defclass egnat-metric-set (cl-ds.ms:metric-space-set 5 | cl-ds.common.egnat:fundamental-egnat-container) 6 | ()) 7 | 8 | 9 | (defclass mutable-egnat-metric-set (cl-ds.ms:mutable-metric-space-set 10 | cl-ds.common.egnat:mutable-egnat-container) 11 | ()) 12 | 13 | 14 | (defmethod cl-ds.common.egnat:distance ((container egnat-metric-set) 15 | bucket item) 16 | (cl-ds.ms:distance container bucket item)) 17 | 18 | 19 | (defun make-mutable-egnat-metric-set (distance-function distance-type 20 | &key (branching-factor 20) (node-size 50) (samples-count 5) 21 | &allow-other-keys) 22 | (ensure-functionf distance-function) 23 | (make 'egnat-metric-set 24 | :metric-fn distance-function 25 | :metric-type distance-type 26 | :branching-factor branching-factor 27 | :samples-count samples-count 28 | :content-count-in-node node-size)) 29 | 30 | 31 | (defmethod cl-ds:make-from-traversable ((sequence vector) 32 | (class (eql 'mutable-egnat-metric-set)) 33 | &rest arguments) 34 | (bind ((container (apply #'make-mutable-egnat-metric-set arguments)) 35 | (root (cl-ds.common.egnat:make-egnat-tree container 36 | #'cl-ds:put! 37 | (cddr arguments) 38 | sequence 39 | (second (member :parallel arguments))))) 40 | (setf (cl-ds.common.egnat:access-root container) root 41 | (cl-ds.common.egnat:access-size container) (cl-ds:size sequence)) 42 | container)) 43 | 44 | 45 | (defmethod cl-ds:make-from-traversable ((sequence cl-ds:fundamental-random-access-range) 46 | (class (eql 'mutable-egnat-metric-set)) 47 | &rest arguments) 48 | (bind ((container (apply #'make-mutable-egnat-metric-set arguments)) 49 | (root (cl-ds.common.egnat:make-egnat-tree container 50 | #'cl-ds:put! 51 | (cddr arguments) 52 | sequence 53 | (second (member :parallel arguments))))) 54 | (setf (cl-ds.common.egnat:access-root container) root 55 | (cl-ds.common.egnat:access-size container) (cl-ds:size sequence)) 56 | container)) 57 | 58 | 59 | (defmethod cl-ds:make-from-traversable ((sequence cl-ds:fundamental-forward-range) 60 | (class (eql 'mutable-egnat-metric-set)) 61 | &rest arguments) 62 | (let ((vector (vect))) 63 | (cl-ds:across sequence (rcurry #'vector-push-extend vector)) 64 | (apply #'cl-ds:make-from-traversable vector class arguments))) 65 | -------------------------------------------------------------------------------- /src/metric-space/egnat/tests.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cl-user) 2 | (defpackage metric-egnat-tests 3 | (:use :prove :cl :iterate)) 4 | (cl:in-package :metric-egnat-tests) 5 | 6 | (plan 45) 7 | 8 | (defun levenshtein (str1 str2) 9 | (check-type str1 string) 10 | (check-type str2 string) 11 | (let ((n (length str1)) 12 | (m (length str2))) 13 | (cond ((= 0 n) (return-from levenshtein m)) 14 | ((= 0 m) (return-from levenshtein n))) 15 | (let ((col (make-array (1+ m) :element-type 'fixnum)) 16 | (prev-col (make-array (1+ m) :element-type 'fixnum))) 17 | (iterate 18 | (for i from 0 below (1+ m)) 19 | (setf (aref prev-col i) i)) 20 | (iterate 21 | (for i below n) 22 | (setf (aref col 0) (1+ i)) 23 | (iterate 24 | (for j below m) 25 | (setf (aref col (1+ j)) 26 | (min (1+ (aref col j)) 27 | (1+ (aref prev-col (1+ j))) 28 | (+ (aref prev-col j) 29 | (if (char-equal (aref str1 i) (aref str2 j)) 0 1))))) 30 | (rotatef col prev-col)) 31 | (aref prev-col m)))) 32 | 33 | (let* ((path (asdf:system-relative-pathname :cl-data-structures "test/files/words.txt")) 34 | (data (serapeum:vect)) 35 | (count 0)) 36 | (with-open-file (stream path) 37 | (iterate 38 | (for word = (read-line stream nil nil)) 39 | (until (null word)) 40 | (vector-push-extend word data))) 41 | (let* ((set (cl-ds:make-from-traversable 42 | data 43 | 'cl-ds.ms.egnat:mutable-egnat-metric-set 44 | (lambda (a b) 45 | (incf count) 46 | (levenshtein a b)) 47 | 'non-negative-fixnum 48 | :branching-factor 50 49 | :parallel t 50 | :samples-count 5)) 51 | (whole-content (cl-ds.alg:to-vector (cl-ds:whole-range set)))) 52 | (is (length whole-content) (length data)) 53 | (is (sort whole-content #'string<) (sort data #'string<) 54 | :test 'equalp) 55 | (setf count 0) 56 | (iterate 57 | (with near = (cl-ds:near set "rose" 1)) 58 | (for n = (cl-ds:consume-front near)) 59 | (while n) 60 | (for distance = (levenshtein n "rose")) 61 | (ok (<= distance 1)) 62 | (count t into result) 63 | (finally (is result 40))) 64 | (ok (null (zerop count))) 65 | (ok (< count (length data))))) 66 | 67 | (finalize) 68 | -------------------------------------------------------------------------------- /src/metric-space/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage :cl-data-structures.metric-space 2 | (:use #:common-lisp 3 | #:cl-data-structures.aux-package) 4 | (:nicknames #:cl-ds.ms) 5 | (:export 6 | #:distance 7 | #:metric-space-dictionary 8 | #:metric-space-set 9 | #:mutable-metric-space-dictionary 10 | #:mutable-metric-space-set)) 11 | 12 | 13 | (cl:defpackage :cl-data-structures.metric-space.egnat 14 | (:use #:common-lisp 15 | #:cl-data-structures.aux-package) 16 | (:nicknames #:cl-ds.ms.egnat) 17 | (:export 18 | #:make-mutable-egnat-metric-set 19 | #:mutable-egnat-metric-set 20 | #:egnat-metric-set)) 21 | -------------------------------------------------------------------------------- /src/metric-space/trait-classes.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.metric-space) 2 | 3 | 4 | (defclass metric-space-set (cl-ds:fundamental-container) 5 | ((%metric-fn :reader read-metric-fn 6 | :initarg :metric-fn))) 7 | 8 | 9 | (defclass metric-space-dictionary (cl-ds:fundamental-container) 10 | ()) 11 | 12 | 13 | (defclass mutable-metric-space-set (metric-space-set) 14 | ()) 15 | 16 | 17 | (defclass mutable-metric-space-dictionary (metric-space-dictionary) 18 | ()) 19 | -------------------------------------------------------------------------------- /src/queues/2-3-tree/docstrings.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.queues.2-3-tree) 2 | 3 | 4 | (docs:define-docs 5 | :formatter docs.ext:rich-aggregating-formatter 6 | 7 | (function make-functional-2-3-queue 8 | (:returns "Empty functional-2-3-queue")) 9 | 10 | (function make-mutable-2-3-queue 11 | (:returns "Empty mutable-2-3-queue")) 12 | 13 | (function make-transactional-2-3-queue 14 | (:returns "Empty transactional-2-3-queue")) 15 | 16 | (type functional-2-3-queue 17 | (:description "An functional queue based around 2-3 tree data structur.")) 18 | 19 | (type mutable-2-3-queue 20 | (:description "An mutable queue based around 2-3 tree data structur.")) 21 | 22 | (type transactional-2-3-queue 23 | (:description "An transactional queue based around 2-3 tree data structure."))) 24 | -------------------------------------------------------------------------------- /src/queues/2-3-tree/notes.org: -------------------------------------------------------------------------------- 1 | * Tasks 2 | ** DONE Can simply become-functional and wrap that to form forward-range! 3 | CLOSED: [2018-11-23 pią 20:09] 4 | [2018-10-11 czw] 5 | [[file:~/quicklisp/local-projects/cl-data-structures/src/queues/2-3-tree/api.lisp::cl-ds.utils:todo)]] 6 | *** Even better: become-transactional. 7 | -------------------------------------------------------------------------------- /src/queues/2-3-tree/tests.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cl-user) 2 | (defpackage 2-3-queue-tests (:use :cl :prove :cl-data-structures.aux-package)) 3 | (cl:in-package :2-3-queue-tests) 4 | 5 | (plan 1495) 6 | 7 | (let ((queue (make 'cl-ds.queues.2-3-tree::mutable-2-3-queue))) 8 | (iterate 9 | (for i from 0 below 100) 10 | (is (cl-ds:size queue) i) 11 | (cl-ds:put! queue i) 12 | (is (cl-ds:at queue :back) i)) 13 | (iterate 14 | (for i from 0 below 100) 15 | (is (cl-ds:size queue) (- 100 i)) 16 | (cl-ds:mod-bind (container found value) (cl-ds:take-out! queue) 17 | (is value i)))) 18 | 19 | (let* ((queue (make 'cl-ds.queues.2-3-tree:functional-2-3-queue)) 20 | (og-queue nil) 21 | (empty queue)) 22 | (iterate 23 | (for i from 0 below 100) 24 | (is (cl-ds:size queue) i) 25 | (setf queue (cl-ds:put queue i)) 26 | (is (cl-ds:at queue :back) i)) 27 | (let ((i 0)) 28 | (cl-ds:across queue 29 | (lambda (s) (is s i) (incf i))) 30 | (is i 100)) 31 | (let ((i 0)) 32 | (cl-ds:traverse queue 33 | (lambda (s) (is s i) (incf i))) 34 | (is i 100)) 35 | (let ((i 0)) 36 | (cl-ds:across (cl-ds:whole-range queue) 37 | (lambda (s) (is s i) (incf i))) 38 | (is i 100)) 39 | (let ((i 0)) 40 | (cl-ds:traverse (cl-ds:whole-range queue) 41 | (lambda (s) (is s i) (incf i))) 42 | (is i 100)) 43 | (is (cl-ds:size empty) 0) 44 | (setf og-queue queue) 45 | (iterate 46 | (for i from 0 below 100) 47 | (is (cl-ds:size queue) (- 100 i)) 48 | (cl-ds:mod-bind (container found value) (cl-ds:take-out queue) 49 | (setf queue container) 50 | (is value i))) 51 | (setf queue og-queue) 52 | (iterate 53 | (for i from 0 below 100) 54 | (is (cl-ds:size queue) (- 100 i)) 55 | (cl-ds:mod-bind (container found value) (cl-ds:take-out queue) 56 | (setf queue container) 57 | (is value i)))) 58 | 59 | (let ((queue (make 'cl-ds.queues.2-3-tree::mutable-2-3-queue))) 60 | (iterate 61 | (for i from 0 below 20) 62 | (is (cl-ds:size queue) i) 63 | (cl-ds:put! queue i) 64 | (is (cl-ds:at queue :back) i)) 65 | (iterate 66 | (for i from 0 below 5) 67 | (cl-ds:mod-bind (container found value) (cl-ds:take-out! queue) 68 | (is value i))) 69 | (iterate 70 | (for i from 0 below 15) 71 | (cl-ds:put! queue i) 72 | (is (cl-ds:at queue :back) i)) 73 | (iterate 74 | (for i from 5 below 20) 75 | (cl-ds:mod-bind (container found value) (cl-ds:take-out! queue) 76 | (is value i))) 77 | (iterate 78 | (for i from 0 below 15) 79 | (cl-ds:mod-bind (container found value) (cl-ds:take-out! queue) 80 | (is value i)))) 81 | 82 | (finalize) 83 | -------------------------------------------------------------------------------- /src/queues/common.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.queues) 2 | 3 | 4 | (defclass fundamental-queue (cl-ds:fundamental-container) 5 | ((%size :initarg :size 6 | :initform 0 7 | :reader cl-ds:size 8 | :accessor access-size))) 9 | 10 | 11 | (defclass fundamental-mutable-queue (cl-ds:mutable fundamental-queue) 12 | ()) 13 | 14 | 15 | (defclass fundamental-transactional-queue (cl-ds:transactional fundamental-queue) 16 | ()) 17 | 18 | 19 | (defclass fundamental-functional-queue (cl-ds:functional fundamental-queue) 20 | ()) 21 | 22 | 23 | (defmethod cl-ds:put! ((container fundamental-mutable-queue) 24 | item) 25 | (cl-ds.meta:position-modification #'cl-ds:put! container 26 | container item)) 27 | 28 | 29 | (defmethod cl-ds:put! ((container fundamental-transactional-queue) 30 | item) 31 | (cl-ds.meta:position-modification #'cl-ds:put! container 32 | container item)) 33 | 34 | 35 | (defmethod cl-ds:take-out! ((container fundamental-mutable-queue)) 36 | (cl-ds.meta:position-modification #'cl-ds:take-out! container 37 | container nil)) 38 | 39 | 40 | (defmethod cl-ds:take-out! ((container fundamental-transactional-queue)) 41 | (cl-ds.meta:position-modification #'cl-ds:take-out! container 42 | container nil)) 43 | 44 | 45 | (defmethod cl-ds:take-out ((container fundamental-functional-queue)) 46 | (cl-ds.meta:position-modification #'cl-ds:take-out container 47 | container nil)) 48 | 49 | 50 | (defmethod cl-ds:put ((container fundamental-functional-queue) 51 | item) 52 | (cl-ds.meta:position-modification #'cl-ds:put container 53 | container item)) 54 | 55 | 56 | (defmethod cl-ds:take-out! ((container fundamental-functional-queue)) 57 | (cl-ds.meta:position-modification #'cl-ds:take-out container 58 | container nil)) 59 | -------------------------------------------------------------------------------- /src/queues/docstrings.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.queues) 2 | 3 | 4 | (docs:define-docs 5 | :formatter docs.ext:rich-aggregating-formatter 6 | 7 | (type fundamental-queue 8 | (:description "A fundamental base class of all queues.")) 9 | 10 | (type fundamental-mutable-queue 11 | (:description "A fundamental base class of all mutable queues.")) 12 | 13 | (type fundamental-functional-queue 14 | (:description "A fundamental base class of all functional queues."))) 15 | -------------------------------------------------------------------------------- /src/queues/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | 3 | 4 | (defpackage :cl-data-structures.queues 5 | (:use #:cl 6 | #:cl-data-structures.aux-package) 7 | (:nicknames #:cl-ds.queues) 8 | (:export 9 | #:access-size 10 | #:fundamental-functional-queue 11 | #:fundamental-mutable-queue 12 | #:fundamental-transactional-queue 13 | #:fundamental-queue)) 14 | 15 | (defpackage :cl-data-structures.queues.2-3-tree 16 | (:use #:cl 17 | #:cl-data-structures.aux-package) 18 | (:nicknames #:cl-ds.queues.2-3-tree) 19 | (:export 20 | #:fixed-capacity-synchronized-mutable-2-3-queue 21 | #:fixed-capacity-synchronized-transactional-2-3-queue 22 | #:functional-2-3-queue 23 | #:make-functional-2-3-queue 24 | #:make-mutable-2-3-queue 25 | #:make-synchronized-mutable-2-3-queue 26 | #:make-synchronized-transactional-2-3-queue 27 | #:make-transactional-2-3-queue 28 | #:mutable-2-3-queue 29 | #:synchronized-mutable-2-3-queue 30 | #:synchronized-transactional-2-3-queue 31 | #:transactional-2-3-queue)) 32 | -------------------------------------------------------------------------------- /src/sequences/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | 3 | 4 | (defpackage :cl-data-structures.sequences 5 | (:use #:common-lisp 6 | #:cl-data-structures.aux-package) 7 | (:nicknames #:cl-ds.seqs) 8 | (:export 9 | #:fundamental-sequence 10 | #:functional-sequence 11 | #:mutable-sequence 12 | #:transactional-sequence)) 13 | 14 | 15 | (defpackage :cl-data-structures.sequences.rrb-vector 16 | (:use #:common-lisp 17 | #:cl-data-structures.common.rrb 18 | #:cl-data-structures.aux-package) 19 | (:nicknames #:cl-ds.seqs.rrb) 20 | (:export 21 | #:functional-rrb-vector 22 | #:make-functional-rrb-vector 23 | #:make-mutable-rrb-vector 24 | #:make-transactional-rrb-vector 25 | #:mutable-rrb-vector 26 | #:transactional-rrb-vector)) 27 | -------------------------------------------------------------------------------- /src/sequences/rrb/docstrings.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.sequences.rrb-vector) 2 | 3 | (docs:define-docs 4 | :formatter docs.ext:rich-aggregating-formatter 5 | 6 | (type functional-rrb-vector 7 | (:description "Functional variant of the RRB vector.")) 8 | 9 | (type mutable-rrb-vector 10 | (:description "Mutable variant of the RRB vector.")) 11 | 12 | (type transactional-rrb-vector 13 | (:description "Transactional variant of the RRB vector.")) 14 | 15 | (function make-transactional-rrb-vector 16 | (:description "Creates and returns a new instance of transactional-rrb-vector")) 17 | 18 | (function make-functional-rrb-vector 19 | (:description "Creates and returns a new instance of functiona-rrb-vector")) 20 | 21 | (function make-mutable-rrb-vector 22 | (:description "Creates and returns a new instance of mutable-rrb-vector."))) 23 | -------------------------------------------------------------------------------- /src/sets/common.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.sets) 2 | 3 | 4 | (defclass fundamental-set (cl-ds:fundamental-container) 5 | ()) 6 | 7 | 8 | (defclass mutable-set (fundamental-set cl-ds:mutable) 9 | ()) 10 | 11 | 12 | (defmethod cl-ds:put! ((container mutable-set) item) 13 | (cl-ds.meta:position-modification #'cl-ds:put! 14 | container 15 | container 16 | item)) 17 | 18 | 19 | (defmethod cl-ds:erase! ((container mutable-set) location) 20 | (cl-ds.meta:position-modification #'cl-ds:erase! 21 | container 22 | container 23 | location)) 24 | 25 | (defmethod cl-ds:erase*! ((container mutable-set) range) 26 | (cl-ds.meta:position-modification #'cl-ds:erase*! 27 | container 28 | container 29 | range)) 30 | -------------------------------------------------------------------------------- /src/sets/docstrings.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.sets) 2 | 3 | 4 | (docs:define-docs 5 | :formatter docs.ext:rich-aggregating-formatter 6 | 7 | ) 8 | -------------------------------------------------------------------------------- /src/sets/packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | 3 | 4 | (defpackage :cl-data-structures.sets 5 | (:use #:common-lisp 6 | #:cl-data-structures.aux-package) 7 | (:nicknames #:cl-ds.sets) 8 | (:export 9 | #:fundamental-set 10 | #:mutable-set)) 11 | 12 | 13 | (defpackage cl-data-structures.sets.qp-trie 14 | (:use #:common-lisp 15 | #:cl-data-structures.aux-package) 16 | (:nicknames #:cl-ds.sets.qp-trie) 17 | (:export 18 | #:empty-array-key 19 | #:fundamental-qp-trie-set 20 | #:make-mutable-qp-trie-set 21 | #:mutable-qp-trie-set)) 22 | 23 | 24 | (defpackage cl-data-structures.sets.skip-list 25 | (:use #:common-lisp 26 | #:cl-data-structures.aux-package) 27 | (:nicknames #:cl-ds.sets.skip-list) 28 | (:export 29 | #:mutable-skip-list-set 30 | #:make-mutable-skip-list-set)) 31 | -------------------------------------------------------------------------------- /src/sets/qp-trie/docstrings.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.sets.qp-trie) 2 | 3 | 4 | (docs:define-docs 5 | :formatter docs.ext:rich-aggregating-formatter 6 | 7 | (function make-mutable-qp-trie-set 8 | (:description "Constructs and returns a new instance of the mutable-qp-trie-set")) 9 | 10 | (type mutable-qp-trie-set 11 | (:description "Mutable variant of the mutable-qp-trie-set."))) 12 | -------------------------------------------------------------------------------- /src/sets/qp-trie/tests.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.sets.qp-trie) 2 | 3 | (prove:plan 508) 4 | 5 | (let ((trie (make-mutable-qp-trie-set)) 6 | (sort (curry #'cl-ds.utils:lexicographic-compare #'< #'=)) 7 | (data (make-array 500))) 8 | (map-into data (lambda () (map-into (make-array 4 :element-type '(unsigned-byte 8)) 9 | (lambda () (random #.(expt 2 8)))))) 10 | (setf data (sort data sort)) 11 | (iterate 12 | (for vect in-vector data) 13 | (cl-ds:put! trie vect)) 14 | (iterate 15 | (for vect in-vector data) 16 | (prove:ok (cl-ds:at trie vect))) 17 | (prove:is (cl-ds.alg:count-elements trie) 18 | (~> data (remove-duplicates :test #'vector=) length)) 19 | (prove:is (cl-ds:size trie) (cl-ds.alg:count-elements trie)) 20 | (prove:is 21 | (~> trie cl-ds:whole-range cl-ds.alg:to-vector 22 | (sort sort)) 23 | data 24 | :test #'equalp) 25 | (let ((reference-point (cl-ds.utils:lower-bound data (aref data 10) sort))) 26 | (prove:is 27 | (~> (cl-ds:between* trie :high (aref data reference-point)) 28 | cl-ds.alg:to-vector 29 | (sort sort)) 30 | (take reference-point data) 31 | :test #'equalp) 32 | (prove:is 33 | (~> (cl-ds:between* trie :low (aref data reference-point)) 34 | cl-ds.alg:to-vector 35 | (sort sort)) 36 | (drop reference-point data) 37 | :test #'equalp))) 38 | 39 | 40 | (bind ((trie (make-mutable-qp-trie-set)) 41 | (sort (curry #'cl-ds.utils:lexicographic-compare #'< #'=)) 42 | (data (vect)) 43 | ((:flet point (&rest points)) 44 | (vector-push-extend (map-into (make-array 4 :element-type '(unsigned-byte 8)) 45 | #'identity 46 | points) 47 | data))) 48 | (point 0 1 2) 49 | (point 0 1 3) 50 | (point 0 1 4) 51 | (point 0 1 5) 52 | (point 0 2 5) 53 | (point 0 3 5) 54 | (iterate 55 | (for point in-vector data) 56 | (cl-ds:put! trie point)) 57 | (prove:is (cl-ds:size trie) 6) 58 | (prove:is (~> trie cl-ds.alg:to-vector) 59 | data 60 | :test #'equalp) 61 | (let ((range (cl-ds:between* trie :low (aref data 2)))) 62 | (cl-ds:erase*! trie range) 63 | (prove:is (~> trie cl-ds.alg:to-vector 64 | (sort sort)) 65 | (~> (serapeum:take 2 data) 66 | (sort sort)) 67 | :test #'equalp))) 68 | 69 | 70 | (prove:finalize) 71 | -------------------------------------------------------------------------------- /src/sets/skip-list/docstrings.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.sets.skip-list) 2 | 3 | 4 | (docs:define-docs 5 | :formatter docs.ext:rich-aggregating-formatter 6 | 7 | (function make-mutable-skip-list-set 8 | (:description "Constructs and returns a new instance of mutable-skip-list.")) 9 | 10 | (type mutable-skip-list-set 11 | (:description "Mutable skip list set."))) 12 | -------------------------------------------------------------------------------- /src/streaming-algorithms/approximated-histogram-tests.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-ds.sa) 2 | 3 | 4 | (prove:plan 24) 5 | 6 | (let ((histogram (make 'approximated-histogram))) 7 | (let ((count-lower (first (approximated-histogram-count-lower histogram 30)))) 8 | (prove:is count-lower 0.0d0)) 9 | (iterate 10 | (for i from 1 below 100) 11 | (approximated-histogram-add histogram (coerce i 'double-float))) 12 | (let ((count-lower (first (approximated-histogram-count-lower histogram 30)))) 13 | (prove:ok (< 29 count-lower 31))) 14 | (let ((median (first (approximated-histogram-quantile histogram 0.5)))) 15 | (prove:ok (< 49 median 51))) 16 | (let ((high (first (approximated-histogram-quantile histogram 0.95)))) 17 | (prove:ok (< 94 high 96))) 18 | (bind (((median high) (approximated-histogram-quantile histogram 0.5 0.95))) 19 | (prove:ok (< 49 median 51)) 20 | (prove:ok (< 94 high 96))) 21 | (prove:is (access-count (union histogram histogram)) 22 | (* 2 (access-count histogram))) 23 | (prove:ok (< 0.28 24 | (first (approximated-histogram-rank-order histogram 30)) 25 | 0.31))) 26 | 27 | (let ((histogram (make 'approximated-histogram))) 28 | (let ((count-lower (first (approximated-histogram-count-lower histogram 30)))) 29 | (prove:is count-lower 0.0d0)) 30 | (iterate 31 | (for i from 99 downto 1) 32 | (approximated-histogram-add histogram (coerce i 'double-float))) 33 | (let ((count-lower (first (approximated-histogram-count-lower histogram 30)))) 34 | (prove:ok (< 29 count-lower 31))) 35 | (let ((median (first (approximated-histogram-quantile histogram 0.5)))) 36 | (prove:ok (< 49 median 51))) 37 | (let ((high (first (approximated-histogram-quantile histogram 0.95)))) 38 | (prove:ok (< 94 high 96))) 39 | (bind (((median high) (approximated-histogram-quantile histogram 0.5 0.95))) 40 | (prove:ok (< 49 median 51)) 41 | (prove:ok (< 94 high 96))) 42 | (prove:is (access-count (union histogram histogram)) 43 | (* 2 (access-count histogram))) 44 | (prove:ok (< 0.28 45 | (first (approximated-histogram-rank-order histogram 30)) 46 | 0.31))) 47 | 48 | (let ((histogram (make 'approximated-histogram)) 49 | (data (shuffle (iota 99 :start 1)))) 50 | (let ((count-lower (first (approximated-histogram-count-lower histogram 30)))) 51 | (prove:is count-lower 0.0d0)) 52 | (iterate 53 | (for i in data) 54 | (approximated-histogram-add histogram (coerce i 'double-float))) 55 | (let ((count-lower (first (approximated-histogram-count-lower histogram 30)))) 56 | (prove:ok (< 29 count-lower 31))) 57 | (let ((median (first (approximated-histogram-quantile histogram 0.5)))) 58 | (prove:ok (< 49 median 51))) 59 | (let ((high (first (approximated-histogram-quantile histogram 0.95)))) 60 | (prove:ok (< 94 high 96))) 61 | (bind (((median high) (approximated-histogram-quantile histogram 0.5 0.95))) 62 | (prove:ok (< 49 median 51)) 63 | (prove:ok (< 94 high 96))) 64 | (prove:is (access-count (union histogram histogram)) 65 | (* 2 (access-count histogram))) 66 | (prove:ok (< 0.28 67 | (first (approximated-histogram-rank-order histogram 30)) 68 | 0.31))) 69 | 70 | (prove:finalize) 71 | -------------------------------------------------------------------------------- /src/streaming-algorithms/approximated-set-cardinality.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.streaming-algorithms) 2 | 3 | 4 | (defclass approximated-set-cardinality (fundamental-data-sketch) 5 | ((%registers :initarg :registers 6 | :reader internal-array 7 | :accessor access-registers))) 8 | 9 | 10 | (defmethod cl-ds.utils:cloning-information append 11 | ((sketch approximated-set-cardinality)) 12 | '((:registers access-registers))) 13 | 14 | 15 | (defmethod cl-ds:clone ((object approximated-set-cardinality)) 16 | (cl-ds.utils:quasi-clone* object 17 | :registers (~> object access-registers copy-array))) 18 | 19 | 20 | (defmethod compatiblep ((first-sketch approximated-set-cardinality) 21 | &rest more-sketches) 22 | (push first-sketch more-sketches) 23 | (cl-ds.utils:homogenousp more-sketches :key #'class-of)) 24 | 25 | 26 | (defmethod union ((first approximated-set-cardinality) &rest more) 27 | (cl-ds.utils:quasi-clone* first 28 | :registers (apply #'hll:union 29 | (access-registers first) 30 | (mapcar #'access-registers more)))) 31 | 32 | 33 | (defmethod initialize-instance :after ((object approximated-set-cardinality) 34 | &rest all) 35 | (declare (ignore all)) 36 | (check-type (access-registers object) hll:sketch)) 37 | 38 | 39 | (defmethod cl-ds:value ((state approximated-set-cardinality)) 40 | (~> state access-registers hll:cardinality)) 41 | 42 | 43 | (defun approximated-set-cardinality-add (data-sketch element) 44 | (bind (((:slots %hash-fn %registers) data-sketch) 45 | (hash-fn (ensure-function %hash-fn)) 46 | (hash (ldb (byte 64 0) (funcall hash-fn element)))) 47 | (declare (optimize (speed 3) (debug 0) (safety 1) (space 0))) 48 | (hll:add-hash %registers hash))) 49 | 50 | 51 | (cl-ds.alg.meta:define-aggregation-function 52 | approximated-set-cardinality approximated-set-cardinality-function 53 | 54 | (:range &key hash-fn key data-sketch) 55 | (:range &key (hash-fn #'sxhash) (key #'identity) 56 | (data-sketch 57 | (clean-sketch #'approximated-set-cardinality 58 | :hash-fn hash-fn))) 59 | 60 | (%data-sketch) 61 | 62 | ((check-type data-sketch approximated-set-cardinality) 63 | (setf %data-sketch (cl-ds:clone data-sketch))) 64 | 65 | ((element) 66 | (bind (((:slots %hash-fn %registers) %data-sketch) 67 | (hash-fn (ensure-function %hash-fn)) 68 | (hash (ldb (byte 64 0) (funcall hash-fn element)))) 69 | (declare (optimize (speed 3) (debug 0) (safety 1) (space 0))) 70 | (hll:add-hash %registers hash))) 71 | 72 | (%data-sketch)) 73 | 74 | 75 | (defmethod clean-sketch ((function approximated-set-cardinality-function) 76 | &rest all &key hash-fn) 77 | (declare (ignore all)) 78 | (ensure-functionf hash-fn) 79 | (make 'approximated-set-cardinality 80 | :registers (hll:new-sketch) 81 | :hash-fn hash-fn)) 82 | 83 | 84 | (defun hyperloglog-jaccard (a b) 85 | (check-type a approximated-set-cardinality) 86 | (check-type b approximated-set-cardinality) 87 | (hll:jaccard (access-registers a) (access-registers b))) 88 | -------------------------------------------------------------------------------- /src/streaming-algorithms/common.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.streaming-algorithms) 2 | 3 | 4 | (defclass fundamental-data-sketch () 5 | ((%hash-fn :initarg :hash-fn 6 | :accessor access-hash-fn))) 7 | 8 | 9 | (defmethod cl-ds.utils:cloning-information append 10 | ((sketch fundamental-data-sketch)) 11 | '((:hash-fn access-hash-fn))) 12 | 13 | 14 | (defmethod initialize-instance :after ((sketch fundamental-data-sketch) 15 | &rest all) 16 | (declare (ignore all)) 17 | (ensure-functionf (access-hash-fn sketch))) 18 | 19 | 20 | (defgeneric compatiblep (first-sketch &rest more-sketches) 21 | (:method :around ((a fundamental-data-sketch) &rest more-sketches) 22 | (unless (every (curry #'eq (class-of a)) 23 | (mapcar #'class-of more-sketches)) 24 | (return-from compatiblep nil)) 25 | (unless (every (curry #'eq (access-hash-fn a)) 26 | (mapcar #'access-hash-fn more-sketches)) 27 | (warn "Hashing function objects in the sketches mismatches. This may be a problem…")) 28 | (call-next-method))) 29 | 30 | 31 | (defgeneric clean-sketch (function &rest arguments &key &allow-other-keys)) 32 | 33 | 34 | (defgeneric union (first-sketch &rest more-sketches) 35 | (:method :around ((sketch fundamental-data-sketch) &rest more-sketches) 36 | (unless (apply #'compatiblep sketch more-sketches) 37 | (error 'cl-ds:incompatible-arguments 38 | :parameters '(sketch more-sketches) 39 | :values `(,sketch ,more-sketches) 40 | :format-control "Sketches passed to the union are not compatible.")) 41 | (call-next-method))) 42 | 43 | 44 | (defgeneric internal-array (sketch)) 45 | -------------------------------------------------------------------------------- /src/streaming-algorithms/package.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage :cl-data-structures.streaming-algorithms 2 | (:use #:common-lisp #:cl-data-structures.aux-package) 3 | (:nicknames #:cl-ds.sa) 4 | (:shadow cl:union) 5 | (:local-nicknames 6 | (#:hll #:cl-data-structures.streaming-algorithms.hyperloglog) 7 | (#:ph #:cl-data-structures.streaming-algorithms.polynomial-hashing)) 8 | (:export 9 | #:approximated-counts 10 | #:approximated-counts-distance 11 | #:approximated-histogram 12 | #:approximated-histogram-add 13 | #:approximated-histogram-count 14 | #:approximated-histogram-bin-count 15 | #:approximated-histogram-bin-position 16 | #:approximated-histogram-bin-sum 17 | #:approximated-histogram-bin-value 18 | #:approximated-histogram-bins 19 | #:approximated-histogram-bounds 20 | #:approximated-histogram-count-lower 21 | #:approximated-histogram-count-rank-order 22 | #:approximated-histogram-cumulant-sum 23 | #:approximated-histogram-truncated-mean 24 | #:approximated-histogram-mean 25 | #:approximated-histogram-trim 26 | #:approximated-histogram-median 27 | #:approximated-histogram-quantile 28 | #:approximated-histogram-rank-order 29 | #:approximated-histogram-sum 30 | #:approximated-histogram-values 31 | #:approximated-histogram-counts 32 | #:approximated-histogram-variance 33 | #:approximated-histogram-mode 34 | #:approximated-histogram-standard-deviation 35 | #:approximated-set-cardinality 36 | #:approximated-top-k 37 | #:bloom-filter 38 | #:bloom-filter-jaccard 39 | #:clean-sketch 40 | #:fundamental-data-sketch 41 | #:gather-minhash-corpus 42 | #:hyperloglog-jaccard 43 | #:internal-array 44 | #:make-approximated-histogram 45 | #:make-hash-array 46 | #:make-minhash 47 | #:make-one-bit-minhash 48 | #:minhash 49 | #:minhash-jaccard/double-float 50 | #:approximated-set-cardinality-add 51 | #:simhash 52 | #:minhash-jaccard/fixnum 53 | #:minhash-jaccard/single-float 54 | #:one-bit-minhash-jaccard/double-float 55 | #:one-bit-minhash-jaccard/fixnum 56 | #:one-bit-minhash-jaccard/single-float 57 | #:union)) 58 | -------------------------------------------------------------------------------- /src/streaming-algorithms/polynomial-hashing.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage #:cl-data-structures.streaming-algorithms.polynomial-hashing 2 | (:use #:cl #:cl-data-structures.aux-package) 3 | (:export 4 | #:hashval-no-depth 5 | #:hashval 6 | #:hash-array 7 | #:hash 8 | #:+max-64-bits+ 9 | #:make-hash-array)) 10 | 11 | (cl:in-package #:cl-data-structures.streaming-algorithms.polynomial-hashing) 12 | 13 | 14 | (eval-always 15 | (define-constant +long-prime+ 4294967311) 16 | (define-constant +max-64-bits+ #xFFFFFFFFFFFFFFFF)) 17 | 18 | 19 | (deftype hash () 20 | `(integer 0 ,+long-prime+)) 21 | 22 | 23 | (deftype hash-array () 24 | `(simple-array hash (* 2))) 25 | 26 | 27 | (-> hashval-no-depth (hash-array fixnum (unsigned-byte 64)) hash) 28 | (defun hashval-no-depth (hashes j hash) 29 | (declare (optimize (speed 3) (safety 0)) 30 | (type hash-array hashes) 31 | (type non-negative-fixnum j hash)) 32 | (~> (aref hashes j 0) 33 | (* hash) 34 | (ldb (byte 32 0) _) 35 | (+ (aref hashes j 1)) 36 | (ldb (byte 32 0) _) 37 | (rem +long-prime+))) 38 | 39 | 40 | (-> hashval (hash-array positive-fixnum non-negative-fixnum (unsigned-byte 64)) hash) 41 | (defun hashval (hashes depth j hash) 42 | (declare (type hash-array hashes) 43 | (type non-negative-fixnum depth j hash)) 44 | (~> (hashval-no-depth hashes j hash) 45 | (rem depth))) 46 | 47 | 48 | (defun make-hash-array (count) 49 | (iterate 50 | (with result = (~> (list count 2) 51 | (make-array :element-type 'hash))) 52 | (for i from 0 below count) 53 | (setf (aref result i 0) (random-in-range 1 +long-prime+) 54 | (aref result i 1) (random-in-range 0 +long-prime+)) 55 | (finally (return result)))) 56 | -------------------------------------------------------------------------------- /src/streaming-algorithms/simhash.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.streaming-algorithms) 2 | 3 | 4 | (cl-ds.alg.meta:define-aggregation-function 5 | simhash simhash-function 6 | 7 | (:range &key hash-fn) 8 | (:range &key hash-fn) 9 | 10 | (%counters %hash-fn) 11 | 12 | ((setf %hash-fn hash-fn 13 | %counters (make-array 64 :element-type '(unsigned-byte 32)))) 14 | 15 | ((element) 16 | (iterate 17 | (declare (type (unsigned-byte 64) hash) 18 | (type fixnum i) 19 | (type (simple-array fixnum (64)) %counters)) 20 | (with hash = (ldb (byte 64 0) (funcall %hash-fn element))) 21 | (for i from 0 below 64) 22 | (if (ldb-test (byte 1 i) hash) 23 | (incf (aref %counters i)) 24 | (decf (aref %counters i))))) 25 | 26 | ((iterate 27 | (declare (type fixnum i) 28 | (type (unsigned-byte 32) counter) 29 | (type (unsigned-byte 64) result) 30 | (type integer result)) 31 | (with result = 0) 32 | (for i from 0 below 64) 33 | (for counter = (aref %counters i)) 34 | (setf (ldb (byte 1 i) result) (the bit (clamp counter 0 1))) 35 | (finally (return result))))) 36 | -------------------------------------------------------------------------------- /src/threads/contains.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.threads) 2 | 3 | 4 | (defun parallel-contains-p (object test-function &key (chunk-size 64) (maximum-queue-size 128)) 5 | (bind ((found nil) 6 | (found-lock (bt2:make-lock)) 7 | (tasks (make-instance 'task-queue 8 | :queue-size maximum-queue-size 9 | :callback (lambda (x &aux (p (funcall test-function x))) 10 | (when p 11 | (bt2:with-lock-held (found-lock) 12 | (setf found t)))) 13 | :batch-size chunk-size))) 14 | (block nil 15 | (cl-ds:across object 16 | (lambda (x) 17 | (bt2:with-lock-held (found-lock) 18 | (when found 19 | (return t))) 20 | (task-queue-push tasks x)))) 21 | (task-queue-finalize tasks) 22 | found)) 23 | -------------------------------------------------------------------------------- /src/threads/package.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage #:cl-data-structures.threads 2 | (:use #:cl-data-structures.aux-package #:common-lisp) 3 | (:nicknames #:cl-ds.threads) 4 | (:export 5 | #:thread-buffer 6 | #:parallel-multiplex 7 | #:parallel-on-each 8 | #:parallel-group-by 9 | #:parallel-traverse 10 | #:parallel-across 11 | #:parallel-contains-p 12 | )) 13 | -------------------------------------------------------------------------------- /src/threads/traverse.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.threads) 2 | 3 | 4 | (defun parallel-traverse (object function &key (chunk-size 64) (maximum-queue-size 128)) 5 | (bind ((tasks (make-instance 'task-queue 6 | :queue-size maximum-queue-size 7 | :callback function 8 | :batch-size chunk-size))) 9 | (cl-ds:traverse object (lambda (x) (task-queue-push tasks x))) 10 | (task-queue-finalize tasks) 11 | object)) 12 | 13 | (defun parallel-across (object function &key (chunk-size 64) (maximum-queue-size 128)) 14 | (bind ((tasks (make-instance 'task-queue 15 | :queue-size maximum-queue-size 16 | :callback function 17 | :batch-size chunk-size))) 18 | (cl-ds:across object (lambda (x) (task-queue-push tasks x))) 19 | (task-queue-finalize tasks) 20 | object)) 21 | -------------------------------------------------------------------------------- /src/utils/bind.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :metabang-bind) 2 | 3 | 4 | (defbinding-form (:vectors :use-values-p nil :accept-multiple-forms-p t) 5 | `(cl-ds.utils:with-vectors ,(mapcar #'list variables values))) 6 | 7 | 8 | (defbinding-form (:hash-table :use-values-p nil :accept-multiple-forms-p nil) 9 | (let* ((tables (list (gensym) values)) 10 | (at-arguments (mapcar (lambda (x) (list (gensym) (second x))) variables)) 11 | (at-forms (mapcar (lambda (x argument) 12 | (list (first x) 13 | `(gethash ,(first argument) 14 | ,(first tables)))) 15 | variables at-arguments))) 16 | `(serapeum:nest 17 | (let* (,tables ,@at-arguments)) 18 | (symbol-macrolet ,at-forms)))) 19 | -------------------------------------------------------------------------------- /src/utils/cartesian.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.utils) 2 | 3 | 4 | (defun cartesian (sequence-of-sequences result-callback) 5 | (unless (some #'emptyp sequence-of-sequences) 6 | (let* ((lengths (map 'list #'length sequence-of-sequences)) 7 | (generator (cycle-over-address lengths))) 8 | (iterate 9 | (for adr = (funcall generator)) 10 | (while adr) 11 | (apply result-callback 12 | (map 'list #'elt sequence-of-sequences adr)))))) 13 | 14 | 15 | (defun cartesian-table (sequence-of-sequences fn) 16 | (unless (some #'emptyp sequence-of-sequences) 17 | (let* ((lengths (map 'list #'length sequence-of-sequences)) 18 | (generator (cycle-over-address lengths)) 19 | (result-table (make-array lengths))) 20 | (iterate 21 | (for adr = (funcall generator)) 22 | (while adr) 23 | (apply #'(setf aref) 24 | (apply fn (map 'list #'elt sequence-of-sequences adr)) 25 | result-table 26 | adr)) 27 | result-table))) 28 | -------------------------------------------------------------------------------- /src/utils/cloning.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.utils) 2 | 3 | 4 | (defgeneric cloning-information (object) 5 | (:method-combination append :most-specific-last)) 6 | 7 | 8 | (defun cloning-list (instance) 9 | (iterate 10 | (for (initarg reader) in (cloning-information instance)) 11 | (collect initarg) 12 | (collect (funcall reader instance)))) 13 | 14 | 15 | (defun clone (instance) 16 | (apply #'make-instance 17 | (class-of instance) 18 | (cloning-list instance))) 19 | 20 | 21 | (defmacro quasi-clone-other-class* (instance class &body arguments) 22 | (once-only (instance) 23 | `(apply #'make-instance ,class 24 | ,@arguments 25 | (cloning-list ,instance)))) 26 | 27 | 28 | (defmacro quasi-clone* (instance &body arguments) 29 | (once-only (instance) 30 | `(apply #'make-instance (class-of ,instance) 31 | ,@arguments 32 | (cloning-list ,instance)))) 33 | 34 | 35 | (defun quasi-clone (instance initarg initval) 36 | (quasi-clone* instance initarg initval)) 37 | 38 | 39 | (defun quasi-clone-other-class (instance class initarg initval) 40 | (quasi-clone-other-class* instance class initarg initval)) 41 | -------------------------------------------------------------------------------- /src/utils/distances-tests.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cl-user) 2 | (defpackage :distances-test-suite (:use :cl :prove :iterate)) 3 | (cl:in-package :distances-test-suite) 4 | 5 | (defun jaccard-metric (a b) 6 | (if (eql a b) 7 | 1.0 8 | (coerce (/ (logcount (logand a b)) 9 | (logcount (logior a b))) 10 | 'single-float))) 11 | 12 | (plan 26) 13 | 14 | (iterate 15 | (for i from 0 below 5) 16 | (with prev = -1) 17 | (iterate (for j from (1+ i) below 5) 18 | (for next = (cl-ds.utils::index-in-content-of-distance-matrix 5 i j)) 19 | (is next (1+ prev)) 20 | (setf prev next))) 21 | 22 | 23 | (cl-ds.utils:with-vectors ((data #(0 1 2 3 4 5))) 24 | (let ((matrix (cl-ds.utils:make-distance-matrix-from-vector 'single-float #'jaccard-metric data))) 25 | (iterate 26 | (for i below 5) 27 | (is-error (cl-ds.utils:mref matrix i i) 'simple-error)) 28 | (iterate 29 | (for i below 5) 30 | (iterate 31 | (for j from (1+ i) below 5) 32 | (is (cl-ds.utils:mref matrix i j) 33 | (jaccard-metric (data i) 34 | (data j)) 35 | :test #'=))) 36 | (setf (cl-ds.utils:mref matrix 1 2) 5.0) 37 | (is (cl-ds.utils:mref matrix 1 2) 5.0))) 38 | 39 | (finalize) 40 | -------------------------------------------------------------------------------- /src/utils/docstrings.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-ds.utils) 2 | 3 | 4 | (docs:define-docs 5 | :formatter docs.ext:rich-aggregating-formatter 6 | 7 | (type half-matrix 8 | (:description "Matrix container suitable for storing symetric data (like distances). Does not store diagonal values.")) 9 | 10 | (function mref 11 | (:description "Matrix reference. Accessor for values in matrices.")) 12 | 13 | (function if-else 14 | (:description "Construct function out of PREDICATE function, TRUE function and FALSE function. Checks if PREDICATE returns true, if yes: pass arguments to the TRUE function, if no: pass arguments to the FALSE function." 15 | :returns "Function.")) 16 | 17 | (function lower-bound 18 | (:description "Find position in the VECTOR of the first element not larger then ELEMENT.")) 19 | 20 | (function normalize-sequence-to-sum 21 | (:description "Normalizes SEQUENCE of numbers so sum of elements is equal to SUM." 22 | :returns "SEQUENCE" 23 | :side-effects "Mutates SEQUENCE.")) 24 | 25 | (function normalize-sequence-to-span 26 | (:description "Normalizes SEQUENCE of numbers so every element is between MIN and MAX" 27 | :returns "SEQUENCE" 28 | :exceptional-situations "Assert: (< MIN MAX)" 29 | :side-effects "Mutates SEQUENCE.")) 30 | 31 | (function remove-fill-pointer 32 | (:description "Accepts vector. Will return vector with the same content, but without fill-pointer." 33 | :exceptional-situations "TYPE-ERROR if VECTOR is not of type CL:VECTOR." 34 | :returns "VECTOR")) 35 | 36 | (function all-parents 37 | (:description "Scans tree with CHILDREN-FN (is supposed to return children of the PARENT as CL:SEQUENCE). Will return ALIST mapping node to list of all parents of nodes. Resulting data structure is useful as a way to lookup for partial order in the tree.")) 38 | 39 | (function ancestor-p 40 | (:description "Checks if ANCESTOR is ancestor of CHILD in tree represented as ALL-ANCESTORS-VECTOR. ALL-ANCESTORS-VECTOR should be constructed by ALL-PARENTS function.")) 41 | 42 | (function select-top 43 | (:description "Selects top elements from the vector, using heap select algorithm." 44 | :returns "Vector containing COUNT of top elements from the vector." 45 | :arguments-and-values ((vector "Input data.") 46 | (count "Number of elements to select.") 47 | (predicate "Function used to compare elements.") 48 | (:key "Key function used to extract element for the predicate.")) 49 | :side-effects "Will mutate orderd of elements in the VECTOR.")) 50 | 51 | (function as-cons-tree 52 | (:description "Scans tree of arbitrary objects (CHILDREN-FN is supposed to return CL:SEQUENCE of children nodes) and returns it as a tree composed of cons cells."))) 53 | -------------------------------------------------------------------------------- /src/utils/embedding.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-ds.utils) 2 | 3 | 4 | (defun bourgain-embedding (vector-of-elements distance-fn &key (metric-type 'single-float)) 5 | (declare (type vector vector-of-elements)) 6 | (ensure-functionf distance-fn) 7 | (bind ((length (length vector-of-elements)) 8 | (m1 (floor (/ (log length) (log 2)))) 9 | (m2 (ceiling (log length))) 10 | (embeddings (make-array (list length (* m1 m2)) 11 | :element-type metric-type)) 12 | (embeddings-view (make-array (list length m1 m2) 13 | :element-type metric-type 14 | :displaced-to embeddings)) 15 | ((:flet random-sample (count)) 16 | (iterate 17 | (with result = (make-array count)) 18 | (for i from 0 below count) 19 | (setf (aref result i) 20 | (aref vector-of-elements (random length))) 21 | (finally (return result))))) 22 | (declare (type fixnum length m1 m2) 23 | (type (simple-array * (* *)) embeddings)) 24 | (iterate 25 | (for i from 0 below m1) 26 | (iterate 27 | (for j from 0 below m2) 28 | (for s = (random-sample (expt 2 i))) 29 | (iterate 30 | (for k from 0 below length) 31 | (for x = (aref vector-of-elements k)) 32 | (for distance = (reduce #'min s 33 | :key (curry distance-fn x))) 34 | (setf (aref embeddings-view k i j) distance)))) 35 | embeddings)) 36 | -------------------------------------------------------------------------------- /src/utils/hashing.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.utils) 2 | 3 | 4 | (declaim (inline xorshift)) 5 | (-> xorshift (integer integer) integer) 6 | (defun xorshift (n i) 7 | (declare (optimize (speed 3) (safety 0))) 8 | (logxor n (ash n (- i)))) 9 | 10 | 11 | (declaim (inline rol64)) 12 | (-> rol64 ((unsigned-byte 64) (unsigned-byte 64)) (unsigned-byte 64)) 13 | (defun rol64 (x k) 14 | (declare (optimize (speed 3) (safety 0))) 15 | (logior (ldb (byte 64 0) (ash x k)) 16 | (ldb (byte 64 k) x))) 17 | 18 | 19 | (declaim (inline hash-integer)) 20 | (-> hash-integer (integer &optional (unsigned-byte 64)) (values (unsigned-byte 64) 21 | (unsigned-byte 64))) 22 | (defun hash-integer (n &optional (multi #x2545F4914F6CDD1D)) 23 | "Attempts to randomize bits. Uses xorshift* algorithm." 24 | (declare (optimize (speed 3) (safety 0) (debug 0))) 25 | (let* ((new-state (~> (xorshift n 12) (xorshift -25) (ldb (byte 64 0) _) 26 | (xorshift 27) (ldb (byte 64 0) _)))) 27 | (values (ldb (byte 64 0) (* new-state multi)) 28 | new-state))) 29 | 30 | 31 | (declaim (inline xoshiro256**)) 32 | (defun xoshiro256** (state) 33 | (declare (optimize (speed 3) (safety 0)) 34 | (type (simple-array (unsigned-byte 64) (*)) state)) 35 | (let ((result (ldb (byte 64 0) (* 9 (rol64 (ldb (byte 64 0) 36 | (* 5 (aref state 1))) 37 | 7)))) 38 | (temp (ldb (byte 64 0) (ash (aref state 1) 17)))) 39 | (macrolet ((sxor (first second) 40 | `(setf (aref state ,first) 41 | (logxor (aref state ,first) 42 | (aref state ,second))))) 43 | (sxor 2 0) 44 | (sxor 3 1) 45 | (sxor 1 2) 46 | (sxor 0 3) 47 | (setf (aref state 2) (logxor (aref state 2) temp) 48 | (aref state 3) (rol64 (aref state 3) 45))) 49 | result)) 50 | 51 | 52 | (declaim (inline splitmix64)) 53 | (-> splitmix64 ((unsigned-byte 64)) (values (unsigned-byte 64) 54 | (unsigned-byte 64))) 55 | (defun splitmix64 (state) 56 | (declare (optimize (speed 3) (safety 0))) 57 | (let ((new-state (ldb (byte 64 0) (+ state #x9E3779B97f4A7C15)))) 58 | (values 59 | (~> (xorshift state 30) 60 | (* #xBF58476D1CE4E5B9) (ldb (byte 64 0) _) 61 | (xorshift 27) 62 | (* #x94D049BB133111EB) (ldb (byte 64 0) _) 63 | (xorshift 31)) 64 | new-state))) 65 | 66 | 67 | (-> fixnum-hash (fixnum) (unsigned-byte 32)) 68 | (defun fixnum-hash (a) 69 | (declare (optimize (speed 3) (safety 0))) 70 | (flet ((op1 (a f1 f2) 71 | (declare (type fixnum a f1 f2)) 72 | (ldb (byte 32 0) (+ a f1 (ash a f2)))) 73 | (op2 (a f1 f2) 74 | (declare (type fixnum a f1 f2)) 75 | (ldb (byte 32 0) (logxor a f1 (ash a f2))))) 76 | (declare (inline op1 op2)) 77 | (~> a (op1 #x7ed55d16 12) (op2 #xc761c23c -19) 78 | (op1 #x165667b1 5) (op2 #xd3a2646c 9) 79 | (op1 #xfd7046c5 3) (op2 #xb55a4f09 -16)))) 80 | -------------------------------------------------------------------------------- /src/utils/higher-order.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-ds.utils) 2 | 3 | 4 | (defun or* (&rest functions) 5 | (lambda (&rest rest) 6 | (iterate 7 | (for function in functions) 8 | (for result = (apply function rest)) 9 | (when result 10 | (leave result))))) 11 | 12 | 13 | (defun and* (&rest functions) 14 | (lambda (&rest rest) 15 | (iterate 16 | (for function in functions) 17 | (for result = (apply function rest)) 18 | (always result) 19 | (finally (return result))))) 20 | 21 | 22 | (defun if-else (predicate true false) 23 | (ensure-functionf predicate true false) 24 | (lambda (&rest all) 25 | (if (apply predicate all) 26 | (apply true all) 27 | (apply false all)))) 28 | 29 | 30 | (defun cycle-over-address (dimensions &rest pinned) 31 | (bind ((address (make-array (length dimensions) 32 | :element-type 'fixnum 33 | :initial-element 0)) 34 | (pointers (list)) 35 | (skipped 0) 36 | (pointer nil) 37 | (total-count 1) 38 | (result nil)) 39 | (when (oddp (length pinned)) 40 | (error "Passed odd number of arguments as dimensions to pin")) 41 | (iterate 42 | (with batches = (batches pinned 2)) 43 | (for (axis position) in batches) 44 | (setf (ldb (byte 1 axis) skipped) 1) 45 | (setf (elt address axis) position)) 46 | (iterate 47 | (for i from 0) 48 | (for dim in dimensions) 49 | (unless (ldb-test (byte 1 i) skipped) 50 | (setf total-count (* total-count dim)) 51 | (push i pointers))) 52 | (setf result (coerce address 'list)) 53 | (setf pointers (nreverse pointers)) 54 | (setf pointer pointers) 55 | (setf dimensions (coerce dimensions '(vector fixnum))) 56 | (lambda () 57 | (labels ((cycle (pointers &aux (pointer (first pointers))) 58 | (unless (endp pointers) 59 | (or (cycle (rest pointers)) 60 | (when (< (1+ #1=(aref address pointer)) 61 | #2=(aref dimensions pointer)) 62 | (iterate 63 | (for i in (rest pointers)) 64 | (setf (aref address i) 0)) 65 | (incf #1#) 66 | pointers))))) 67 | (unless (zerop total-count) 68 | (setf pointer (or (cycle pointer) 69 | (cycle pointers))) 70 | (decf total-count) 71 | (shiftf result (coerce address 'list))))))) 72 | 73 | 74 | (defun ignore-errors* (function) 75 | (lambda (&rest all) 76 | (ignore-errors (apply function all)))) 77 | 78 | 79 | (defun generator (function initial-state) 80 | (ensure-functionf function) 81 | (lambda (&rest all) 82 | (declare (ignore all)) 83 | (shiftf initial-state (funcall function initial-state)))) 84 | 85 | 86 | (defun prevent-duplicates (&key (test 'eql) (key #'identity)) 87 | (let ((table (make-hash-table :test test))) 88 | (lambda (value &aux (data (funcall key value))) 89 | (ensure (gethash data table) data)))) 90 | -------------------------------------------------------------------------------- /src/utils/lambda-lists.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.utils) 2 | 3 | 4 | (eval-always 5 | (defun method-lambda-list-to-function-lambda-list (lambda-list) 6 | (~>> lambda-list 7 | (mapcar (lambda (x) (if (listp x) (car x) x)))))) 8 | 9 | 10 | (eval-always 11 | (defun lambda-list-to-bindings (lambda-list) 12 | (~>> lambda-list 13 | (remove-if (rcurry #'member lambda-list-keywords)) 14 | method-lambda-list-to-function-lambda-list))) 15 | 16 | 17 | (eval-always 18 | (defun lambda-list-to-call-form (function-symbol lambda-list) 19 | (let* ((rest nil) 20 | (symbols 21 | (iterate 22 | (with mode = nil) 23 | (for symbol-or-list in lambda-list) 24 | (for symbol = (if (listp symbol-or-list) 25 | (car symbol-or-list) 26 | symbol-or-list)) 27 | (for keyword = (car (member symbol-or-list 28 | lambda-list-keywords))) 29 | (if keyword 30 | (setf mode keyword) 31 | (cond 32 | ((eql mode 'cl:&key) (progn 33 | (collect (make-keyword symbol)) 34 | (collect symbol))) 35 | ((eql mode 'cl:&aux) nil) 36 | ((eql mode 'cl:&rest) (setf rest symbol)) 37 | (t (collect symbol))))))) 38 | (if (null rest) 39 | (cons function-symbol symbols) 40 | `(apply (function ,function-symbol) 41 | ,@symbols 42 | ,rest))))) 43 | -------------------------------------------------------------------------------- /src/utils/lazy-shuffle-tests.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cl-user) 2 | (defpackage :lazy-shuffe-test-suite (:use :prove :cl :iterate)) 3 | (cl:in-package :lazy-shuffe-test-suite) 4 | 5 | (prove:plan 1) 6 | 7 | (let* ((generator (cl-ds.utils:lazy-shuffle 0 5)) 8 | (data (iterate 9 | (for elt = (funcall generator)) 10 | (while elt) 11 | (collect elt)))) 12 | (is '(0 1 2 3 4) (sort data #'<) :test #'equal)) 13 | 14 | (prove:finalize) 15 | -------------------------------------------------------------------------------- /src/utils/lazy-shuffle.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.utils) 2 | 3 | 4 | (-> lazy-shuffle (integer integer) function) 5 | (defun lazy-shuffle (from to) 6 | (let ((table (make-hash-table)) 7 | (index from)) 8 | (lambda (&rest rest) 9 | (declare (ignore rest)) 10 | (cond ((eql (- to 1) index) 11 | (ensure (gethash index table) index) 12 | (gethash (finc index) table)) 13 | ((< index to) 14 | (let ((next-random (random-in-range index to))) 15 | (ensure (gethash index table) index) 16 | (ensure (gethash next-random table) next-random) 17 | (rotatef (gethash index table) 18 | (gethash next-random table)) 19 | (gethash (finc index) table))) 20 | (t nil))))) 21 | 22 | 23 | (-> draw-sample-vector (vector positive-fixnum &optional vector) vector) 24 | (defun draw-sample-vector (input size 25 | &optional (result (make-array (min size (length input)) 26 | :element-type (array-element-type input)))) 27 | (when (array-has-fill-pointer-p result) 28 | (setf (fill-pointer result) size)) 29 | (iterate 30 | (with generator = (lazy-shuffle 0 (length input))) 31 | (for i from 0 below (min size (length result))) 32 | (setf (aref result i) (aref input (funcall generator))) 33 | (finally (return result)))) 34 | 35 | 36 | (-> draw-random-vector (vector positive-fixnum &optional vector) vector) 37 | (defun draw-random-vector (input size 38 | &optional (result (make-array size 39 | :element-type (array-element-type input)))) 40 | (when (array-has-fill-pointer-p result) 41 | (setf (fill-pointer result) size)) 42 | (let ((length (length input))) 43 | (map-into result (lambda () (aref input (random length)))))) 44 | -------------------------------------------------------------------------------- /src/utils/numbers.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.utils) 2 | 3 | 4 | (declaim (inline square)) 5 | (defun square (number) 6 | (* number number)) 7 | -------------------------------------------------------------------------------- /src/utils/ordered-algorithms-tests.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package :cl-user) 2 | (defpackage :ordered-algorithms-test-suite (:use :cl :prove)) 3 | (cl:in-package :ordered-algorithms-test-suite) 4 | 5 | (plan 4) 6 | 7 | (let ((data #(1 4 8 16))) 8 | (is (cl-ds.utils:lower-bound data 3 #'<) 1) 9 | (is (cl-ds.utils:lower-bound data 20 #'<) 4) 10 | (is (cl-ds.utils:lower-bound data 0 #'<) 0)) 11 | 12 | (let ((data #())) 13 | (is (cl-ds.utils:lower-bound data 3 #'<) 0)) 14 | 15 | (finalize) 16 | -------------------------------------------------------------------------------- /src/utils/package.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | 3 | 4 | (defpackage :cl-data-structures.utils 5 | (:use #:common-lisp #:cl-data-structures.aux-package) 6 | (:nicknames #:cl-ds.utils) 7 | (:export 8 | #:add-into-queue 9 | #:add-sinks 10 | #:add-to-list 11 | #:adjust-size-to-fill-pointer 12 | #:all-parents 13 | #:ancestor-p 14 | #:and* 15 | #:as-cons-tree 16 | #:binary-search 17 | #:bind-lambda 18 | #:bucket-sort 19 | #:cartesian 20 | #:cartesian-table 21 | #:cases 22 | #:clone 23 | #:cloning-information 24 | #:cloning-list 25 | #:cond+ 26 | #:cond-compare 27 | #:copy-slots 28 | #:copy-without 29 | #:cycle-over-address 30 | #:define-list-of-slots 31 | #:draw-random-vector 32 | #:draw-sample-vector 33 | #:each-in-matrix 34 | #:end-execution 35 | #:ensure-call-ahead-of 36 | #:erase-from-vector 37 | #:extendable-vector 38 | #:fill-distance-matrix-from-vector 39 | #:fixnum-hash 40 | #:future-carousel 41 | #:generator 42 | #:check-value 43 | #:half-matrix 44 | #:hash-integer 45 | #:homogenousp 46 | #:if-else 47 | #:square 48 | #:ignore-errors* 49 | #:import-all-package-symbols 50 | #:index 51 | #:insert-or-replace 52 | #:inverted-hash-table 53 | #:lambda-list-to-bindings 54 | #:lambda-list-to-call-form 55 | #:lazy-let 56 | #:lazy-shuffle 57 | #:let-generator 58 | #:lexicographic-compare 59 | #:lolol 60 | #:lower-bound 61 | #:lparallel-future 62 | #:make-distance-matrix-from-vector 63 | #:make-future-carousel 64 | #:make-half-matrix 65 | #:make-new-skip-vector 66 | #:make-pipe-fragment 67 | #:merge-ordered-vectors 68 | #:method-lambda-list-to-function-lambda-list 69 | #:mref 70 | #:mutate-matrix 71 | #:normalize-sequence-to-span 72 | #:normalize-sequence-to-sum 73 | #:on-ordered-intersection 74 | #:optimize-value 75 | #:or* 76 | #:ordered-exclusion 77 | #:ordered-intersection 78 | #:ordered-p 79 | #:parallel-fill-distance-matrix-from-vector 80 | #:parallel-make-distance-matrix-from-vector 81 | #:pipe-fragment 82 | #:pop-last 83 | #:prevent-duplicates 84 | #:quasi-clone 85 | #:quasi-clone* 86 | #:quasi-other-class 87 | #:quasi-other-class* 88 | #:read-size 89 | #:rebind 90 | #:remove-fill-pointer 91 | #:rol64 92 | #:scan 93 | #:select-top 94 | #:skip-vector-without 95 | #:start-execution 96 | #:swap-if 97 | #:swapop 98 | #:todo 99 | #:transform 100 | #:try-find 101 | #:try-find-cell 102 | #:try-remove 103 | #:unfold-table 104 | #:with-keys 105 | #:with-rebind 106 | #:with-slots-for 107 | #:with-vectors 108 | #:xorshift)) 109 | -------------------------------------------------------------------------------- /src/utils/trees.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-ds.utils) 2 | 3 | 4 | (defun all-parents (root children-fn) 5 | (let ((result nil)) 6 | (labels ((impl (parent stack) 7 | (push (list* parent stack) result) 8 | (let ((children (funcall children-fn parent))) 9 | (if (emptyp children) 10 | parent 11 | (map 'list 12 | (rcurry #'impl (cons parent stack)) 13 | children))))) 14 | (impl root nil) 15 | result))) 16 | 17 | 18 | (defun as-cons-tree (root children-fn) 19 | (labels ((impl (parent) 20 | (let ((children (funcall children-fn parent))) 21 | (if (emptyp children) 22 | parent 23 | (list parent 24 | (map 'list #'impl children)))))) 25 | (impl root))) 26 | 27 | 28 | (defun ancestor-p (all-ancestors-vector test-fn child ancestor) 29 | (let ((list-of-ancestors (find child all-ancestors-vector :test test-fn))) 30 | (when (null list-of-ancestors) 31 | (error 'program-error "No such node")) 32 | (null (eq (find ancestor 33 | (rest list-of-ancestors) 34 | :test test-fn) 35 | nil)))) 36 | -------------------------------------------------------------------------------- /src/utils/trivial.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-data-structures.utils) 2 | 3 | 4 | (define-symbol-macro todo 5 | (error 'cl-ds:not-implemented :format-control "Not implemented")) 6 | -------------------------------------------------------------------------------- /src/utils/types.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-ds.utils) 2 | 3 | 4 | (deftype extendable-vector (&optional (type '*)) 5 | `(and (vector ,type) 6 | (satisfies adjustable-array-p) 7 | (satisfies array-has-fill-pointer-p))) 8 | 9 | 10 | (deftype index () 11 | `(integer 0 ,ARRAY-TOTAL-SIZE-LIMIT)) 12 | -------------------------------------------------------------------------------- /test/dicts/.gitignore: -------------------------------------------------------------------------------- 1 | result.txt -------------------------------------------------------------------------------- /todo.org: -------------------------------------------------------------------------------- 1 | * Redesign 2 | ** DONE Currently traverse is designed to not change traversable object. This is strong assumption, and should be removed. 3 | CLOSED: [2018-03-04 nie 18:24] 4 | ** DONE Aggregate functions should not change range (because it makes things complicated). 5 | CLOSED: [2018-02-12 pon 10:30] 6 | *** DONE Add clone-and-traverse (like traverse, but will never alter passed range). 7 | CLOSED: [2018-02-12 pon 10:30] 8 | **** It is called across 9 | * DONE remove morep 10 | CLOSED: [2018-02-14 śro 08:06] 11 | * DONE turn xpr into correct forward range 12 | CLOSED: [2018-02-16 pią 13:54] 13 | * DONE specialized RRB-vector! 14 | CLOSED: [2018-05-04 pią 11:26] 15 | * TODO metric-space dictionary 16 | * DONE metric-space set 17 | CLOSED: [2018-04-27 pią 17:49] 18 | * DONE egnat range... 19 | CLOSED: [2018-03-06 Tue 15:58] 20 | * DONE egnat near function 21 | CLOSED: [2018-03-07 Wed 13:13] 22 | * DONE egnat grow functions 23 | CLOSED: [2018-04-04 śro 13:42] 24 | * DONE egnat shrink functions 25 | CLOSED: [2018-04-04 śro 13:42] 26 | * DONE make-bucket should create just single value tuple 27 | CLOSED: [2018-03-05 pon 21:11] 28 | * DONE fix clone for RRB range 29 | CLOSED: [2018-03-07 Wed 13:13] 30 | * TODO Validate input to make-egnat-tree (scan for duplication) 31 | * DONE some sort of filter algorithm (aka: without) 32 | CLOSED: [2018-05-03 czw 12:26] 33 | * DONE Use whole content of node as bucket for egnat 34 | CLOSED: [2018-04-05 czw 06:49] 35 | * DONE Programmable layer symbols should be in separate package from API 36 | CLOSED: [2018-04-27 pią 17:49] 37 | * TODO Add having function (for use with group-by). 38 | * TODO Add function for changing final result of aggregation. 39 | * DONE Add batches function (divides range into partitions of fixed size for aggregation) 40 | CLOSED: [2020-01-14 wto 10:31] 41 | * DONE Add some sort of data frame. 42 | CLOSED: [2020-01-14 wto 10:31] 43 | * closure compilation 44 | ** TODO Rewrite all multistage aggregations into single stage aggregations so the whole concept can be scrapped 45 | *** started today, finished with math <2020-01-14 wto> 46 | *** finished with clara <2020-01-15 śro> 47 | ** TODO Add additional argument: element-type to the aggregation functions. 48 | ** TODO remove aggregator protocol, design the new protocol based around closures. 49 | --------------------------------------------------------------------------------