branch: externals/dash commit 0c49a33a61c739eb12e4c3680138c1659926202d Author: Basil L. Contovounesios <conto...@tcd.ie> Commit: Basil L. Contovounesios <conto...@tcd.ie>
Fix -permutations for multisets * NEWS.md (2.20.0): Announce -frequencies and changes in -permutations. * README.md: * dash.texi: Regenerate docs. * dash.el (dash--assoc-fn, -frequencies, dash--numbers<=) (dash--next-lex-perm, dash--lex-perms, dash--uniq-perms) (dash--multi-perms): New functions (#209, #214). (-permutations): Rewrite in terms of them, to support multisets (#390). (-powerset): Return a fresh list on empty input. Simplify. * dev/examples.el (-frequencies, dash--assoc-fn, dash--numbers<=) (dash--next-lex-perm, dash--lex-perms): New tests. (-powerset, -permutations): Extend tests. Closes #209, closes #214, fixes #390. --- NEWS.md | 12 ++-- README.md | 27 ++++++++- dash.el | 169 ++++++++++++++++++++++++++++++++++++++++++++++++++++---- dash.texi | 41 +++++++++++++- dev/examples.el | 166 +++++++++++++++++++++++++++++++++++++++++++++++++++++-- 5 files changed, 391 insertions(+), 24 deletions(-) diff --git a/NEWS.md b/NEWS.md index 00f240938e..6d2553f7c7 100644 --- a/NEWS.md +++ b/NEWS.md @@ -14,19 +14,23 @@ See the end of the file for license conditions. prematurely signal an error on improper lists (#393). - The functions `-union`, `-intersection`, and `-difference` now return proper sets, without duplicate elements (#397). -- The function `-same-items?` now works on multisets (lists with - duplicate elements and/or different lengths) (#397). +- The functions `-same-items?` and `-permutations` now work on + multisets (lists with duplicate elements) (#390, #397, #399). - For example, the following now returns non-`nil`: + For example: ```el - (-same-items? '(1 1 2 3) '(1 2 3)) + (-same-items? '(1 1 2 3) '(3 1 2)) ; => t + (-permutations '(1 1 2)) ; => '((1 1 2) (1 2 1) (2 1 1)) ``` #### New features - The function `-contains?` now returns the matching tail of the list instead of just `t`, similarly to `member` (#397). +- New function `-frequencies` that takes a list and counts how many + times each distinct element occurs in it (suggested by @ebpa, #209, + #214, #399). ### From 2.19.0 to 2.19.1 diff --git a/README.md b/README.md index ea48cd53db..f98ae44829 100644 --- a/README.md +++ b/README.md @@ -202,6 +202,7 @@ Functions reducing lists to a single value (which may also be a list). * [`-min-by`](#-min-by-comparator-list) `(comparator list)` * [`-max`](#-max-list) `(list)` * [`-max-by`](#-max-by-comparator-list) `(comparator list)` +* [`-frequencies`](#-frequencies-list) `(list)` ### Unfolding @@ -1241,6 +1242,24 @@ comparing them. (--max-by (> (length it) (length other)) '((1 2 3) (2) (3 2))) ;; => (1 2 3) ``` +#### -frequencies `(list)` + +Count the occurrences of each distinct element of `list`. + +Return an alist of (`element` . `n`), where each `element` occurs `n` +times in `list`. + +The test for equality is done with `equal`, or with `-compare-fn` +if that is non-`nil`. + +See also [`-count`](#-count-pred-list) and [`-group-by`](#-group-by-fn-list). + +```el +(-frequencies ()) ;; => () +(-frequencies '(1 2 3 1 2 1)) ;; => ((1 . 3) (2 . 2) (3 . 1)) +(let ((-compare-fn #'string=)) (-frequencies '(a "a"))) ;; => ((a . 2)) +``` + ## Unfolding Operations dual to reductions, building lists from a seed @@ -1806,16 +1825,20 @@ Return the power set of `list`. ```el (-powerset ()) ;; => (nil) +(-powerset '(x y)) ;; => ((x y) (x) (y) nil) (-powerset '(x y z)) ;; => ((x y z) (x y) (x z) (x) (y z) (y) (z) nil) ``` #### -permutations `(list)` -Return the permutations of `list`. +Return the distinct permutations of `list`. + +Duplicate elements of `list` are determined by `equal`, or by +`-compare-fn` if that is non-`nil`. ```el (-permutations ()) ;; => (nil) -(-permutations '(1 2)) ;; => ((1 2) (2 1)) +(-permutations '(a a b)) ;; => ((a a b) (a b a) (b a a)) (-permutations '(a b c)) ;; => ((a b c) (a c b) (b a c) (b c a) (c a b) (c b a)) ``` diff --git a/dash.el b/dash.el index 739e4864ae..04c3ca1d5e 100644 --- a/dash.el +++ b/dash.el @@ -2714,6 +2714,24 @@ example: (pop list)) list))))) +(defun dash--assoc-fn () + "Return the flavor of `assoc' that goes best with `-compare-fn'." + (declare (side-effect-free error-free)) + (let ((cmp -compare-fn)) + (cond ((memq cmp '(nil equal)) #'assoc) + ((eq cmp #'eq) #'assq) + ;; Since Emacs 26, `assoc' accepts a custom `testfn'. + ;; Version testing would be simpler here, but feature + ;; testing gets more brownie points, I guess. + ((condition-case nil + (with-no-warnings (assoc nil () #'eql)) + (wrong-number-of-arguments t)) + (lambda (key alist) + (--first (and (consp it) (funcall cmp (car it) key)) alist))) + ((with-no-warnings + (lambda (key alist) + (assoc key alist cmp))))))) + (defun dash--hash-test-fn () "Return the hash table test function corresponding to `-compare-fn'. Return nil if `-compare-fn' is not a known test function." @@ -2833,19 +2851,150 @@ if that is non-nil." (defun -powerset (list) "Return the power set of LIST." - (if (null list) '(()) + (if (null list) (list ()) (let ((last (-powerset (cdr list)))) - (append (mapcar (lambda (x) (cons (car list) x)) last) - last)))) + (nconc (mapcar (lambda (x) (cons (car list) x)) last) + last)))) + +(defun -frequencies (list) + "Count the occurrences of each distinct element of LIST. + +Return an alist of (ELEMENT . N), where each ELEMENT occurs N +times in LIST. + +The test for equality is done with `equal', or with `-compare-fn' +if that is non-nil. + +See also `-count' and `-group-by'." + (let (test len freqs) + (cond ((null list)) + ((and (setq test (dash--hash-test-fn)) + (> (setq len (length list)) dash--short-list-length)) + (let ((ht (make-hash-table :test test :size len))) + ;; Share structure between hash table and returned list. + ;; This affords a single pass that preserves the input + ;; order, conses less garbage, and is faster than a + ;; second traversal (e.g., with `maphash'). + (--each list + (let ((freq (gethash it ht))) + (if freq + (setcdr freq (1+ (cdr freq))) + (push (puthash it (cons it 1) ht) freqs)))))) + ((let ((assoc (dash--assoc-fn))) + (--each list + (let ((freq (funcall assoc it freqs))) + (if freq + (setcdr freq (1+ (cdr freq))) + (push (cons it 1) freqs))))))) + (nreverse freqs))) + +(defun dash--numbers<= (nums) + "Return non-nil if NUMS is a list of non-decreasing numbers." + (declare (pure t) (side-effect-free t)) + (or (null nums) + (let ((prev (pop nums))) + (and (numberp prev) + (--every (and (numberp it) (<= prev (setq prev it))) nums))))) + +(defun dash--next-lex-perm (array n) + "Update ARRAY of N numbers with its next lexicographic permutation. +Return nil if there is no such successor. N should be nonzero. + +This implements the salient steps of Algorithm L (Lexicographic +permutation generation) as described in DE Knuth's The Art of +Computer Programming, Volume 4A / Combinatorial Algorithms, +Part I, Addison-Wesley, 2011, ยง 7.2.1.2, p. 319." + (setq n (1- n)) + (let* ((l n) + (j (1- n)) + (al (aref array n)) + (aj al)) + ;; L2. [Find j]. + ;; Decrement j until a[j] < a[j+1]. + (while (and (<= 0 j) + (<= aj (setq aj (aref array j)))) + (setq j (1- j))) + ;; Terminate algorithm if j not found. + (when (>= j 0) + ;; L3. [Increase a[j]]. + ;; Decrement l until a[j] < a[l]. + (while (>= aj al) + (setq l (1- l) al (aref array l))) + ;; Swap a[j] and a[l]. + (aset array j al) + (aset array l aj) + ;; L4. [Reverse a[j+1]...a[n]]. + (setq l n) + (while (< (setq j (1+ j)) l) + (setq aj (aref array j)) + (aset array j (aref array l)) + (aset array l aj) + (setq l (1- l))) + array))) + +(defun dash--lex-perms (vec &optional original) + "Return a list of permutations of VEC in lexicographic order. +Specifically, return only the successors of VEC in lexicographic +order. Each returned permutation is a list. VEC should comprise +one or more numbers, and may be destructively modified. + +If ORIGINAL is a vector, then VEC is interpreted as a set of +indices into ORIGINAL. In this case, the indices are permuted, +and the resulting index permutations are used to dereference +elements of ORIGINAL." + (let ((len (length vec)) perms) + (while vec + (push (if original + (--map (aref original it) vec) + (append vec ())) + perms) + (setq vec (dash--next-lex-perm vec len))) + (nreverse perms))) + +(defun dash--uniq-perms (list) + "Return a list of permutations of LIST. +LIST is treated as if all its elements are distinct." + (let* ((vec (vconcat list)) + (idxs (copy-sequence vec))) + ;; Just construct a vector of the list's indices and permute that. + (dotimes (i (length idxs)) + (aset idxs i i)) + (dash--lex-perms idxs vec))) + +(defun dash--multi-perms (list freqs) + "Return a list of permutations of the multiset LIST. +FREQS should be an alist describing the frequency of each element +in LIST, as returned by `-frequencies'." + (let (;; Distinct items in `list', aka the cars of `freqs'. + (uniq (make-vector (length freqs) nil)) + ;; Indices into `uniq'. + (idxs (make-vector (length list) nil)) + ;; Current index into `idxs'. + (i 0)) + (--each freqs + (aset uniq it-index (car it)) + ;; Populate `idxs' with as many copies of each `it-index' as + ;; there are corresponding duplicates. + (dotimes (_ (cdr it)) + (aset idxs i it-index) + (setq i (1+ i)))) + (dash--lex-perms idxs uniq))) (defun -permutations (list) - "Return the permutations of LIST." - (if (null list) '(()) - (apply #'append - (mapcar (lambda (x) - (mapcar (lambda (perm) (cons x perm)) - (-permutations (remove x list)))) - list)))) + "Return the distinct permutations of LIST. + +Duplicate elements of LIST are determined by `equal', or by +`-compare-fn' if that is non-nil." + (cond ((null list) (list ())) + ;; Optimization: a traversal of `list' is faster than the + ;; round trip via `dash--uniq-perms' or `dash--multi-perms'. + ((dash--numbers<= list) + (dash--lex-perms (vconcat list))) + ((let ((freqs (-frequencies list))) + ;; Is each element distinct? + (unless (--every (= (cdr it) 1) freqs) + (dash--multi-perms list freqs)))) + ((dash--uniq-perms list)))) (defun -inits (list) "Return all prefixes of LIST." diff --git a/dash.texi b/dash.texi index 72ecbe65a8..9f2f05a5c4 100644 --- a/dash.texi +++ b/dash.texi @@ -1663,6 +1663,34 @@ comparing them. @end example @end defun +@anchor{-frequencies} +@defun -frequencies (list) +Count the occurrences of each distinct element of @var{list}. + +Return an alist of (@var{element} . @var{n}), where each @var{element} occurs @var{n} +times in @var{list}. + +The test for equality is done with @code{equal}, or with @code{-compare-fn} +if that is non-@code{nil}. + +See also @code{-count} (@pxref{-count}) and @code{-group-by} (@pxref{-group-by}). + +@example +@group +(-frequencies ()) + @result{} () +@end group +@group +(-frequencies '(1 2 3 1 2 1)) + @result{} ((1 . 3) (2 . 2) (3 . 1)) +@end group +@group +(let ((-compare-fn #'string=)) (-frequencies '(a "a"))) + @result{} ((a . 2)) +@end group +@end example +@end defun + @node Unfolding @section Unfolding @@ -2621,6 +2649,10 @@ Return the power set of @var{list}. @result{} (nil) @end group @group +(-powerset '(x y)) + @result{} ((x y) (x) (y) nil) +@end group +@group (-powerset '(x y z)) @result{} ((x y z) (x y) (x z) (x) (y z) (y) (z) nil) @end group @@ -2629,7 +2661,10 @@ Return the power set of @var{list}. @anchor{-permutations} @defun -permutations (list) -Return the permutations of @var{list}. +Return the distinct permutations of @var{list}. + +Duplicate elements of @var{list} are determined by @code{equal}, or by +@code{-compare-fn} if that is non-@code{nil}. @example @group @@ -2637,8 +2672,8 @@ Return the permutations of @var{list}. @result{} (nil) @end group @group -(-permutations '(1 2)) - @result{} ((1 2) (2 1)) +(-permutations '(a a b)) + @result{} ((a a b) (a b a) (b a a)) @end group @group (-permutations '(a b c)) diff --git a/dev/examples.el b/dev/examples.el index 086dc15777..d858e203ce 100644 --- a/dev/examples.el +++ b/dev/examples.el @@ -654,7 +654,24 @@ new list." (defexamples -max-by (-max-by '> '(4 3 6 1)) => 6 (--max-by (> (car it) (car other)) '((1 2 3) (2) (3 2))) => '(3 2) - (--max-by (> (length it) (length other)) '((1 2 3) (2) (3 2))) => '(1 2 3))) + (--max-by (> (length it) (length other)) '((1 2 3) (2) (3 2))) => '(1 2 3)) + + (defexamples -frequencies + (-frequencies '()) => '() + (-frequencies '(1 2 3 1 2 1)) => '((1 . 3) (2 . 2) (3 . 1)) + (let ((-compare-fn #'string=)) (-frequencies '(a "a"))) => '((a . 2)) + (let ((-compare-fn #'string=)) (-frequencies '("a" a))) => '(("a" . 2)) + (-frequencies '(1)) => '((1 . 1)) + (-frequencies '(1 1)) => '((1 . 2)) + (-frequencies '(2 1 1)) => '((2 . 1) (1 . 2)) + (let ((-compare-fn #'eq) + (a (string ?a))) + (-frequencies `(,a ,(string ?a) ,a))) + => '(("a" . 2) ("a" . 1)) + (let ((-compare-fn #'eq) + (a (string ?a))) + (-frequencies `(,(string ?a) ,a ,a))) + => '(("a" . 1) ("a" . 2)))) (def-example-group "Unfolding" "Operations dual to reductions, building lists from a seed @@ -1189,13 +1206,72 @@ related predicates." (let ((-compare-fn #'string=)) (-intersection '("a") '(a)) => '("a"))) (defexamples -powerset - (-powerset '()) => '(nil) - (-powerset '(x y z)) => '((x y z) (x y) (x z) (x) (y z) (y) (z) nil)) + (-powerset '()) => '(()) + (-powerset '(x y)) => '((x y) (x) (y) ()) + (-powerset '(x y z)) => '((x y z) (x y) (x z) (x) (y z) (y) (z) ()) + (let ((p (-powerset '()))) (setcar p t) (-powerset '())) => '(())) (defexamples -permutations - (-permutations '()) => '(nil) + (-permutations '()) => '(()) + (-permutations '(a a b)) => '((a a b) (a b a) (b a a)) + (-permutations '(a b c)) + => '((a b c) (a c b) (b a c) (b c a) (c a b) (c b a)) + (-permutations '(1)) => '((1)) + (-permutations '(a)) => '((a)) + (-permutations '(())) => '((())) + (-permutations '(1 1)) => '((1 1)) (-permutations '(1 2)) => '((1 2) (2 1)) - (-permutations '(a b c)) => '((a b c) (a c b) (b a c) (b c a) (c a b) (c b a))) + (-permutations '(2 1)) => '((2 1) (1 2)) + (-permutations '(1 a)) => '((1 a) (a 1)) + (-permutations '(a 1)) => '((a 1) (1 a)) + (-permutations '(a a)) => '((a a)) + (-permutations '(a b)) => '((a b) (b a)) + (-permutations '(b a)) => '((b a) (a b)) + (-permutations '(1 1 1)) => '((1 1 1)) + (-permutations '(1 1 2)) => '((1 1 2) (1 2 1) (2 1 1)) + (-permutations '(1 2 1)) => '((1 1 2) (1 2 1) (2 1 1)) + (-permutations '(2 1 1)) => '((2 1 1) (1 2 1) (1 1 2)) + (-permutations '(1 1 a)) => '((1 1 a) (1 a 1) (a 1 1)) + (-permutations '(1 a 1)) => '((1 1 a) (1 a 1) (a 1 1)) + (-permutations '(a 1 1)) => '((a 1 1) (1 a 1) (1 1 a)) + (-permutations '(a a 1)) => '((a a 1) (a 1 a) (1 a a)) + (-permutations '(a 1 a)) => '((a a 1) (a 1 a) (1 a a)) + (-permutations '(1 a a)) => '((1 a a) (a 1 a) (a a 1)) + (-permutations '(1 2 3)) + => '((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1)) + (-permutations '(3 2 1)) + => '((3 2 1) (3 1 2) (2 3 1) (2 1 3) (1 3 2) (1 2 3)) + (-permutations '(1 2 a)) + => '((1 2 a) (1 a 2) (2 1 a) (2 a 1) (a 1 2) (a 2 1)) + (-permutations '(1 a 2)) + => '((1 a 2) (1 2 a) (a 1 2) (a 2 1) (2 1 a) (2 a 1)) + (-permutations '(a 1 2)) + => '((a 1 2) (a 2 1) (1 a 2) (1 2 a) (2 a 1) (2 1 a)) + (-permutations '(a b 1)) + => '((a b 1) (a 1 b) (b a 1) (b 1 a) (1 a b) (1 b a)) + (-permutations '(a 1 b)) + => '((a 1 b) (a b 1) (1 a b) (1 b a) (b a 1) (b 1 a)) + (-permutations '(1 a b)) + => '((1 a b) (1 b a) (a 1 b) (a b 1) (b 1 a) (b a 1)) + (-permutations '(a a a)) => '((a a a)) + (-permutations '(a b a)) => '((a a b) (a b a) (b a a)) + (-permutations '(b a a)) => '((b a a) (a b a) (a a b)) + (-permutations '(c b a)) + => '((c b a) (c a b) (b c a) (b a c) (a c b) (a b c)) + (let ((-compare-fn #'string=)) (-permutations '(a "a"))) => '((a a)) + (let ((-compare-fn #'string=)) (-permutations '("a" a))) => '(("a" "a")) + (let ((-compare-fn #'string=)) (-permutations '(a "a" b))) + => '((a a b) (a b a) (b a a)) + (let ((-compare-fn #'string=)) (-permutations '(a b "a"))) + => '((a a b) (a b a) (b a a)) + (let ((-compare-fn #'string=)) (-permutations '(b a "a"))) + => '((b a a) (a b a) (a a b)) + (let ((-compare-fn #'string=)) (-permutations '("a" a b))) + => '(("a" "a" b) ("a" b "a") (b "a" "a")) + (let ((-compare-fn #'string=)) (-permutations '("a" b a))) + => '(("a" "a" b) ("a" b "a") (b "a" "a")) + (let ((-compare-fn #'string=)) (-permutations '(b "a" a))) + => '((b "a" "a") ("a" b "a") ("a" "a" b))) (defexamples -distinct (-distinct '()) => '() @@ -2271,6 +2347,24 @@ or readability." (should (equal (funcall member "foo" '(foo bar)) '(foo bar))) (should (equal (funcall member "foo" '(bar foo)) '(foo))))) +(ert-deftest dash--assoc-fn () + "Test `dash--assoc-fn'." + (dolist (cmp '(nil equal)) + (let ((-compare-fn cmp)) + (should (eq (dash--assoc-fn) #'assoc)))) + (let ((-compare-fn #'eq)) + (should (eq (dash--assoc-fn) #'assq))) + (let* ((-compare-fn #'string=) + (assoc (dash--assoc-fn))) + (should-not (memq assoc '(assoc assq))) + (should-not (funcall assoc 'foo ())) + (should-not (funcall assoc 'foo '(foo))) + (should-not (funcall assoc 'foo '((bar)))) + (should-not (funcall assoc 'bar '((foo) bar))) + (should (equal (funcall assoc 'foo '((foo))) '(foo))) + (should (equal (funcall assoc 'bar '((foo) (bar))) '(bar))) + (should (equal (funcall assoc 'foo '((foo 1) (foo 2))) '(foo 1))))) + (ert-deftest dash--hash-test-fn () "Test `dash--hash-test-fn'." (let ((-compare-fn nil)) @@ -2297,4 +2391,66 @@ or readability." (should (= (dash--size+ most-positive-fixnum i) most-positive-fixnum)))) +(ert-deftest dash--numbers<= () + "Test `dash--numbers<='." + (should (dash--numbers<= ())) + (should (dash--numbers<= '(0))) + (should (dash--numbers<= '(0 0))) + (should (dash--numbers<= '(0 1))) + (should (dash--numbers<= '(0 0 0))) + (should (dash--numbers<= '(0 0 1))) + (should (dash--numbers<= '(0 1 1))) + (should-not (dash--numbers<= '(a))) + (should-not (dash--numbers<= '(0 a))) + (should-not (dash--numbers<= '(a 0))) + (should-not (dash--numbers<= '(0 0 a))) + (should-not (dash--numbers<= '(0 a 0))) + (should-not (dash--numbers<= '(1 0))) + (should-not (dash--numbers<= '(1 0 0))) + (should-not (dash--numbers<= '(1 1 0)))) + +(ert-deftest dash--next-lex-perm () + "Test `dash--next-lex-perm'." + (dolist (vecs '(([0]) + ([0 0]) + ([0 1] . [1 0]) + ([0 0 0]) + ([0 0 1] . [0 1 0]) + ([0 1 0] . [1 0 0]) + ([0 1 1] . [1 0 1]) + ([1 0 0]) + ([1 0 1] . [1 1 0]) + ([1 1 0]) + ([1 1 1]) + ([0 1 2] . [0 2 1]) + ([0 2 1] . [1 0 2]) + ([1 0 2] . [1 2 0]) + ([1 2 0] . [2 0 1]) + ([2 0 1] . [2 1 0]) + ([2 1 0]))) + (let* ((prev (copy-sequence (car vecs))) + (copy (copy-sequence prev)) + (next (cdr vecs))) + (should (equal (dash--next-lex-perm prev (length prev)) next)) + ;; Vector should either be updated in place, or left alone. + (should (equal prev (or next copy)))))) + +(ert-deftest dash--lex-perms () + "Test `dash--lex-perms'." + (dolist (perms '(([0] (0)) + ([0 0] (0 0)) + ([0 1] (0 1) (1 0)) + ([1 0] (1 0)))) + (should (equal (dash--lex-perms (copy-sequence (car perms))) + (cdr perms)))) + (should (equal (dash--lex-perms (vector 0 1) (vector 2 3)) + '((2 3) (3 2)))) + (should (equal (dash--lex-perms (vector 0 1 2) (vector 5 4 3)) + '((5 4 3) + (5 3 4) + (4 5 3) + (4 3 5) + (3 5 4) + (3 4 5))))) + ;;; examples.el ends here