Skip to content

Commit 4b6ff30

Browse files
EngelbergEngelberg
committed
New permutation functions, improved combinations
1 parent 2a5fc6d commit 4b6ff30

File tree

2 files changed

+334
-59
lines changed

2 files changed

+334
-59
lines changed

‎src/main/clojure/clojure/math/combinatorics.clj

Lines changed: 272 additions & 59 deletions
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,10 @@ of items.
3939
Example: (permutations [1 2 3]) -> ((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1))
4040
Example: (permutations [1 1 2]) -> ((1 1 2) (1 2 1) (2 1 1))
4141
42+
(count-permutations items) - (count (permutations items)), but computed more directly
43+
(nth-permutation items) - (nth (permutations items)), but computed more directly
44+
(permutation-index items) - Returns the number n where (nth-permutation (sort items) n) is items
45+
4246
(partitions items) - A lazy sequence of all the partitions
4347
of items.
4448
Example: (partitions [1 2 3]) -> (([1 2 3])
@@ -71,31 +75,57 @@ Most of these algorithms are derived from algorithms found in Knuth's wonderful
7175
[n cnt]
7276
(lazy-seq
7377
(let [c (vec (cons nil (for [j (range 1 (inc n))] (+ j cnt (- (inc n)))))),
74-
iter-comb
75-
(fn iter-comb [c j]
76-
(if (> j n) nil
77-
(let [c (assoc c j (dec (c j)))]
78-
(if (< (c j) j) [c (inc j)]
79-
(loop [c c, j j]
80-
(if (= j 1) [c j]
81-
(recur (assoc c (dec j) (dec (c j))) (dec j)))))))),
82-
step
83-
(fn step [c j]
84-
(cons (rseq (subvec c 1 (inc n)))
85-
(lazy-seq (let [next-step (iter-comb c j)]
86-
(when next-step (step (next-step 0) (next-step 1)))))))]
87-
(step c 1))))
78+
iter-comb
79+
(fn iter-comb [c j]
80+
(if (> j n) nil
81+
(let [c (assoc c j (dec (c j)))]
82+
(if (< (c j) j) [c (inc j)]
83+
(loop [c c, j j]
84+
(if (= j 1) [c j]
85+
(recur (assoc c (dec j) (dec (c j))) (dec j)))))))),
86+
step
87+
(fn step [c j]
88+
(cons (rseq (subvec c 1 (inc n)))
89+
(lazy-seq (let [next-step (iter-comb c j)]
90+
(when next-step (step (next-step 0) (next-step 1)))))))]
91+
(step c 1))))
92+
93+
(defn- index-combinations2 ;Algorithm T
94+
[n cnt]
95+
(lazy-seq
96+
(let [c (vec (concat [nil]
97+
(for [j (range 1 (inc n))] (dec j))
98+
[cnt 0]))
99+
iter-comb
100+
(fn iter-comb [c j x]
101+
(let [c1+1 (inc (c 1))]
102+
(if (< c1+1 (c 2))
103+
[(assoc c 1 c1+1) (c 2) x]
104+
(loop [c c, j j, x x]
105+
(let [c (assoc c (dec j) (- j 2)),
106+
x (inc (c j))]
107+
(cond
108+
(= x (c (inc j))) (recur c (inc j) x)
109+
(> j n) nil
110+
:else [(assoc c j x) (dec j) x]))))))
111+
step
112+
(fn step [c j x]
113+
(cons (subvec c 1 (inc n))
114+
(lazy-seq (let [next-step (iter-comb c j x)]
115+
(when next-step (step (next-step 0) (next-step 1) (next-step 2)))))))]
116+
(step c n n))))
88117

89118
(defn combinations
90119
"All the unique ways of taking n different elements from items"
91120
[items n]
92-
(let [v-items (vec (reverse items))]
121+
(let [v-items (vec items)]
93122
(if (zero? n) (list ())
94-
(let [cnt (count items)]
95-
(cond (> n cnt) nil
96-
(= n cnt) (list (seq items))
97-
:else
98-
(map #(map v-items %) (index-combinations n cnt)))))))
123+
(let [cnt (count items)]
124+
(cond (> n cnt) nil
125+
(= n 1) (for [item items] (list item))
126+
(= n cnt) (list (seq items))
127+
:else
128+
(map #(map v-items %) (index-combinations2 n cnt)))))))
99129

100130
(defn- unchunk
101131
"Given a sequence that may have chunks, return a sequence that is 1-at-a-time
@@ -106,31 +136,31 @@ which increases the amount of memory in use that cannot be garbage
106136
collected."
107137
[s]
108138
(lazy-seq
109-
(when (seq s)
110-
(cons (first s) (unchunk (rest s))))))
139+
(when (seq s)
140+
(cons (first s) (unchunk (rest s))))))
111141

112142
(defn subsets
113143
"All the subsets of items"
114144
[items]
115145
(mapcat (fn [n] (combinations items n))
116-
(unchunk (range (inc (count items))))))
146+
(unchunk (range (inc (count items))))))
117147

118148
(defn cartesian-product
119149
"All the ways to take one item from each sequence"
120150
[& seqs]
121151
(let [v-original-seqs (vec seqs)
122-
step
123-
(fn step [v-seqs]
124-
(let [increment
125-
(fn [v-seqs]
126-
(loop [i (dec (count v-seqs)), v-seqs v-seqs]
127-
(if (= i -1) nil
128-
(if-let [rst (next (v-seqs i))]
129-
(assoc v-seqs i rst)
130-
(recur (dec i) (assoc v-seqs i (v-original-seqs i)))))))]
131-
(when v-seqs
132-
(cons (map first v-seqs)
133-
(lazy-seq (step (increment v-seqs)))))))]
152+
step
153+
(fn step [v-seqs]
154+
(let [increment
155+
(fn [v-seqs]
156+
(loop [i (dec (count v-seqs)), v-seqs v-seqs]
157+
(if (= i -1) nil
158+
(if-let [rst (next (v-seqs i))]
159+
(assoc v-seqs i rst)
160+
(recur (dec i) (assoc v-seqs i (v-original-seqs i)))))))]
161+
(when v-seqs
162+
(cons (map first v-seqs)
163+
(lazy-seq (step (increment v-seqs)))))))]
134164
(when (every? seq seqs)
135165
(lazy-seq (step v-original-seqs)))))
136166

@@ -143,18 +173,18 @@ collected."
143173

144174
(defn- iter-perm [v]
145175
(let [len (count v),
146-
j (loop [i (- len 2)]
147-
(cond (= i -1) nil
148-
(< (v i) (v (inc i))) i
149-
:else (recur (dec i))))]
176+
j (loop [i (- len 2)]
177+
(cond (= i -1) nil
178+
(< (v i) (v (inc i))) i
179+
:else (recur (dec i))))]
150180
(when j
151181
(let [vj (v j),
152-
l (loop [i (dec len)]
153-
(if (< vj (v i)) i (recur (dec i))))]
154-
(loop [v (assoc v j (v l) l vj), k (inc j), l (dec len)]
155-
(if (< k l)
156-
(recur (assoc v k (v l) l (v k)) (inc k) (dec l))
157-
v))))))
182+
l (loop [i (dec len)]
183+
(if (< vj (v i)) i (recur (dec i))))]
184+
(loop [v (assoc v j (v l) l vj), k (inc j), l (dec len)]
185+
(if (< k l)
186+
(recur (assoc v k (v l) l (v k)) (inc k) (dec l))
187+
v))))))
158188

159189
(defn- vec-lex-permutations [v]
160190
(when v (cons v (lazy-seq (vec-lex-permutations (iter-perm v))))))
@@ -166,10 +196,10 @@ In prior versions of the combinatorics library, there were two similar functions
166196
{:deprecated "1.3"}
167197
[c]
168198
(lazy-seq
169-
(let [vec-sorted (vec (sort c))]
170-
(if (zero? (count vec-sorted))
171-
(list [])
172-
(vec-lex-permutations vec-sorted)))))
199+
(let [vec-sorted (vec (sort c))]
200+
(if (zero? (count vec-sorted))
201+
(list [])
202+
(vec-lex-permutations vec-sorted)))))
173203

174204
(defn- sorted-numbers?
175205
"Returns true iff s is a sequence of numbers in non-decreasing order"
@@ -181,24 +211,207 @@ In prior versions of the combinatorics library, there were two similar functions
181211
"Handles the case when you want the permutations of a list with duplicate items."
182212
[l]
183213
(let [f (frequencies l),
184-
v (vec (keys f)),
214+
v (vec (distinct l)),
185215
indices (apply concat
186216
(for [i (range (count v))]
187217
(repeat (f (v i)) i)))]
188218
(map (partial map v) (lex-permutations indices))))
189-
219+
190220
(defn permutations
191-
"All the distinct permutations of items, lexicographic by index."
221+
"All the distinct permutations of items, lexicographic by index
222+
(special handling for duplicate items)."
192223
[items]
193224
(cond
194-
(sorted-numbers? items) (lex-permutations items),
195-
196-
(apply distinct? items)
197-
(let [v (vec items)]
198-
(map #(map v %) (lex-permutations (range (count v)))))
225+
(sorted-numbers? items) (lex-permutations items),
226+
227+
(apply distinct? items)
228+
(let [v (vec items)]
229+
(map #(map v %) (lex-permutations (range (count v)))))
230+
231+
:else
232+
(multi-perm items)))
233+
234+
;; Jumping directly to a given permutation
235+
236+
;; First, let's deal with the case where all items are distinct
237+
;; This is the easier case.
238+
239+
(defn- factorial-numbers
240+
"Input is a non-negative base 10 integer, output is the number in the
241+
factorial number system (http://en.wikipedia.org/wiki/Factorial_number_system)
242+
expressed as a list of 'digits'"
243+
[n]
244+
{:pre [(integer? n) (not (neg? n))]}
245+
(loop [n n, digits (), divisor 1]
246+
(if (zero? n)
247+
digits
248+
(let [q (quot n divisor), r (rem n divisor)]
249+
(recur q (cons r digits) (inc divisor))))))
250+
251+
(defn- factorial [n]
252+
{:pre [(integer? n) (not (neg? n))]}
253+
(loop [acc 1, n n]
254+
(if (zero? n) acc (recur (*' acc n) (dec n)))))
255+
256+
(defn- remove-nth [l n]
257+
(loop [acc [], l l, n n]
258+
(if (zero? n) (into acc (rest l))
259+
(recur (conj acc (first l)) (rest l) (dec n)))))
260+
261+
(defn- nth-permutation-distinct
262+
"Input should be a sorted sequential collection l of distinct items,
263+
output is nth-permutation (0-based)"
264+
[l n]
265+
(assert (< n (factorial (count l)))
266+
(format "%s is too large. Input has only %s permutations."
267+
(str n) (str (factorial (count l)))))
268+
(let [length (count l)
269+
fact-nums (factorial-numbers n)]
270+
(loop [indices (concat (repeat (- length (count fact-nums)) 0)
271+
fact-nums),
272+
l l
273+
perm []]
274+
(if (empty? indices) perm
275+
(let [i (first indices),
276+
item (nth l i)]
277+
(recur (rest indices) (remove-nth l i) (conj perm item)))))))
278+
279+
;; Now we generalize to collections with duplicates
280+
281+
(defn- count-permutations-from-frequencies [freqs]
282+
(let [counts (vals freqs)]
283+
(reduce / (factorial (apply + counts))
284+
(map factorial counts ))))
285+
286+
(defn count-permutations
287+
"Counts the number of distinct permutations of l"
288+
[l]
289+
(count-permutations-from-frequencies (frequencies l)))
290+
291+
(defn- initial-perm-numbers
292+
"Takes a sorted frequency map and returns how far into the sequence of
293+
lexicographic permutations you get by varying the first item"
294+
[freqs]
295+
(reductions + 0
296+
(for [[k v] freqs]
297+
(count-permutations-from-frequencies (assoc freqs k (dec v))))))
298+
299+
;; Explanation of initial-perm-numbers:
300+
; (initial-perm-numbers (sorted-map 1 2, 2 1)) => (0 2 3) because when
301+
; doing the permutations of [1 1 2], there are 2 permutations starting with 1
302+
; and 1 permutation starting with 2.
303+
; So the permutations starting with 1 begin with the 0th permutation
304+
; and the permutations starting with 2 begin with the 2nd permutation
305+
; (The final 3 denotes the total number of permutations).
306+
307+
(defn- index-remainder
308+
"Finds the index and remainder from the initial-perm-numbers."
309+
[perm-numbers n]
310+
(loop [perm-numbers perm-numbers
311+
index 0]
312+
(if (and (<= (first perm-numbers) n)
313+
(< n (second perm-numbers)))
314+
[index (- n (first perm-numbers))]
315+
(recur (rest perm-numbers) (inc index)))))
316+
317+
;; Explanation of index-remainder:
318+
; (index-remainder [0 6 9 11] 8) => [1 2]
319+
; because 8 is (+ (nth [0 6 9 11] 1) 2)
320+
; i.e., 1 gives us the index into the largest number smaller than n
321+
; and 2 is the remaining amount needed to sum up to n.
322+
323+
(defn- dec-key [m k]
324+
(if (= 1 (m k))
325+
(dissoc m k)
326+
(update-in m [k] dec)))
327+
328+
(defn- factorial-numbers-with-duplicates
329+
"Input is a non-negative base 10 integer n, and a sorted frequency map freqs.
330+
Output is a list of 'digits' in this wacky duplicate factorial number system"
331+
[n freqs]
332+
(loop [n n, digits [], freqs freqs]
333+
(if (zero? n) (into digits (repeat (apply + (vals freqs)) 0))
334+
(let [[index remainder]
335+
(index-remainder (initial-perm-numbers freqs) n)]
336+
(recur remainder (conj digits index)
337+
(let [nth-key (nth (keys freqs) index)]
338+
(dec-key freqs nth-key)))))))
339+
340+
(defn- nth-permutation-duplicates
341+
"Input should be a sorted sequential collection l of distinct items,
342+
output is nth-permutation (0-based)"
343+
[l n]
344+
(assert (< n (count-permutations l))
345+
(format "%s is too large. Input has only %s permutations."
346+
(str n) (str (count-permutations l))))
347+
(loop [freqs (into (sorted-map) (frequencies l)),
348+
indices (factorial-numbers-with-duplicates n freqs)
349+
perm []]
350+
(if (empty? indices) perm
351+
(let [i (first indices),
352+
item (nth (keys freqs) i)]
353+
(recur (dec-key freqs item)
354+
(rest indices)
355+
(conj perm item))))))
356+
357+
;; Now we create the public version, which detects which underlying algorithm to call
199358

200-
:else
201-
(multi-perm items)))
359+
(defn nth-permutation
360+
"(nth (permutations items)) but calculated more directly."
361+
[items n]
362+
(if (sorted-numbers? items)
363+
(if (apply distinct? items)
364+
(nth-permutation-distinct items n)
365+
(nth-permutation-duplicates items n))
366+
(if (apply distinct? items)
367+
(let [v (vec items),
368+
perm-indices (nth-permutation-distinct (range (count items)) n)]
369+
(vec (map v perm-indices)))
370+
(let [v (vec (distinct items)),
371+
f (frequencies items),
372+
indices (apply concat
373+
(for [i (range (count v))]
374+
(repeat (f (v i)) i)))]
375+
(vec (map v (nth-permutation-duplicates indices n)))))))
376+
377+
;; Now let's go the other direction, from a sortable collection to the nth
378+
;; position in which we would find the collection in the lexicographic sequence
379+
;; of permutations
380+
381+
(defn- list-index
382+
"The opposite of nth, i.e., from an item in a list, find the n"
383+
[l item]
384+
(loop [l l, n 0]
385+
(assert (seq l))
386+
(if (= item (first l)) n
387+
(recur (rest l) (inc n)))))
388+
389+
(defn- permutation-index-distinct
390+
[l]
391+
(loop [l l, index 0, n (dec (count l))]
392+
(if (empty? l) index
393+
(recur (rest l)
394+
(+ index (* (factorial n) (list-index (sort l) (first l))))
395+
(dec n)))))
396+
397+
(defn- permutation-index-duplicates
398+
[l]
399+
(loop [l l, index 0, freqs (into (sorted-map) (frequencies l))]
400+
(if (empty? l) index
401+
(recur (rest l)
402+
(reduce + index
403+
(for [k (take-while #(neg? (compare % (first l))) (keys freqs))]
404+
(count-permutations-from-frequencies (dec-key freqs k))))
405+
(dec-key freqs (first l))))))
406+
407+
(defn permutation-index
408+
"Input must be a sortable collection of items. Returns the n such that
409+
(nth-permutation (sort items) n) is items."
410+
[items]
411+
(if (apply distinct? items)
412+
(permutation-index-distinct items)
413+
(permutation-index-duplicates items)))
414+
202415

203416
;;;;; Partitions, written by Alex Engelberg; adapted from Knuth Volume 4A
204417

0 commit comments

Comments
 (0)
pFad - Phonifier reborn

Pfad - The Proxy pFad of © 2024 Garber Painting. All rights reserved.

Note: This service is not intended for secure transactions such as banking, social media, email, or purchasing. Use at your own risk. We assume no liability whatsoever for broken pages.


Alternative Proxies:

Alternative Proxy

pFad Proxy

pFad v3 Proxy

pFad v4 Proxy