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

@@ -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
 

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))
 ```
 

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)
+      (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."

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))

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