Commit | Line | Data |
---|---|---|
d3f33b9a MW |
1 | ;;; -*-lisp-*- |
2 | ||
3 | ;;; This file isn't a program as such: rather, it's a collection of handy | |
4 | ;;; functions which can be used in an interactive session. | |
5 | ||
6 | ;;;-------------------------------------------------------------------------- | |
7 | ;;; General permutation utilities. | |
8 | ||
9 | (defun shuffle (v) | |
10 | "Randomly permute the elements of the vector V. Return V." | |
11 | (let ((n (length v))) | |
12 | (do ((k n (1- k))) | |
13 | ((<= k 1) v) | |
14 | (let ((i (random k))) | |
15 | (unless (= i (1- k)) | |
16 | (rotatef (aref v i) (aref v (1- k)))))))) | |
17 | ||
18 | (defun identity-permutation (n) | |
19 | "Return the do-nothing permutation on N elements." | |
20 | (let ((v (make-array n :element-type 'fixnum))) | |
21 | (dotimes (i n v) (setf (aref v i) i)))) | |
22 | ||
23 | (defun invert-permutation (p) | |
24 | "Given a permutation P, return its inverse." | |
25 | (let* ((n (length p)) (p-inv (make-array n :element-type 'fixnum))) | |
26 | (dotimes (i n) (setf (aref p-inv (aref p i)) i)) | |
27 | p-inv)) | |
28 | ||
29 | (defun next-permutation (v) | |
30 | "Adjust V so that it reflects the next permutation in ascending order. | |
31 | ||
32 | V should be a vector of real numbers. Returns V if successful, or nil if | |
33 | there are no more permutations." | |
34 | ||
35 | ;; The tail of the vector consists of a sequence ... A, Z, Y, X, ..., where | |
36 | ;; Z > Y > X ... is in reverse order, and A < Z. The next permutation is | |
37 | ;; then the smallest out of Z, Y, X, ... which is larger than A, followed | |
38 | ;; by the remaining elements in ascending order. | |
39 | ;; | |
40 | ;; Equivalently, reverse the tail Z, Y, X, ... so we have A, ... X, Y, Z, | |
41 | ;; and swap A with the next larger element. | |
42 | ||
43 | (let ((n (length v))) | |
44 | (cond ((< n 2) nil) | |
45 | (t (let* ((k (1- n)) | |
46 | (x (aref v k))) | |
47 | (loop (when (zerop k) (return-from next-permutation nil)) | |
48 | (decf k) | |
49 | (let ((y (aref v k))) | |
50 | (when (prog1 (< y x) | |
51 | (setf x y)) | |
52 | (return)))) | |
53 | (do ((i (1+ k) (1+ i)) | |
54 | (j (1- n) (1- j))) | |
55 | ((> i j)) | |
56 | (rotatef (aref v i) (aref v j))) | |
57 | (do ((i (- n 2) (1- i))) | |
58 | ((or (<= i k) (< (aref v i) x)) | |
59 | (rotatef (aref v k) (aref v (1+ i))))) | |
60 | v))))) | |
61 | ||
62 | (defun make-index-mask (w mask-expr) | |
63 | "Construct a bitmask based on bitwise properties of the bit indices. | |
64 | ||
65 | The function returns a W-bit mask in which each bit is set if MASK-EXPR | |
66 | of true of the bit's index. MASK-EXPR may be one of the following: | |
67 | ||
68 | * I -- an integer I is true if bit I of the bit index is set; | |
69 | * (not EXPR) -- is true if EXPR is false; | |
70 | * (and EXPR EXPR ...) -- is true if all of the EXPRs are true; and | |
71 | * (or EXPR EXPR ...) -- is true if any of the EXPRs is true." | |
72 | ||
73 | (let ((max-bit (1- (integer-length (1- w)))) | |
74 | (mask 0)) | |
75 | (dotimes (i w mask) | |
76 | (labels ((interpret (expr) | |
77 | (cond ((and (integerp expr) (<= 0 expr max-bit)) | |
78 | (logbitp expr i)) | |
79 | ((and (consp expr) (eq (car expr) 'not) | |
80 | (null (cddr expr))) | |
81 | (not (interpret (cadr expr)))) | |
82 | ((and (consp expr) (eq (car expr) 'and)) | |
83 | (every #'interpret (cdr expr))) | |
84 | ((and (consp expr) (eq (car expr) 'or)) | |
85 | (some #'interpret (cdr expr))) | |
86 | (t | |
87 | (error "unknown mask expression ~S" expr))))) | |
88 | (when (interpret mask-expr) | |
89 | (setf (ldb (byte 1 i) mask) 1)))))) | |
90 | ||
91 | (defun make-permutation-network (w steps) | |
92 | "Construct a permutation network. | |
93 | ||
94 | The integer W gives the number of bits to be acted upon. The STEPS are a | |
95 | list of instructions of the following forms: | |
96 | ||
97 | * (SHIFT . MASK) -- a pair of integers is treated literally; | |
98 | ||
99 | * (SHIFT MASK-EXPR) -- the SHIFT is literal, but the MASK-EXPR is | |
100 | processed by `make-index-mask' to calculate the mask; | |
101 | ||
102 | * (:invert I) -- make an instruction which inverts the sense of the | |
103 | index bit I; | |
104 | ||
105 | * (:exchange I J) -- make an instruction which exchanges index bits I | |
106 | and J; or | |
107 | ||
108 | * (:exchange-invert I J) -- make an instruction which exchanges and | |
109 | inverts index bits I and J. | |
110 | ||
111 | The output is a list of primitive (SHIFT . MASK) steps, indicating that | |
112 | the bits of the input selected by MASK are to be swapped with the bits | |
113 | selected by (ash MASK SHIFT)." | |
114 | ||
115 | (let ((max-mask (1- (ash 1 w))) | |
116 | (max-shift (1- w)) | |
117 | (max-bit (1- (integer-length (1- w)))) | |
118 | (list nil)) | |
119 | (dolist (step steps) | |
120 | (cond ((and (consp step) | |
121 | (integerp (car step)) (<= 0 (car step) max-shift) | |
122 | (integerp (cdr step)) (<= 0 (cdr step) max-mask)) | |
123 | (push step list)) | |
124 | ((and (consp step) | |
125 | (integerp (car step)) (<= 0 (car step) max-shift) | |
126 | (null (cddr step))) | |
127 | (push (cons (car step) (make-index-mask w (cadr step))) list)) | |
128 | ((and (consp step) | |
129 | (eq (car step) :invert) | |
130 | (integerp (cadr step)) (<= 0 (cadr step) max-bit) | |
131 | (null (cddr step))) | |
132 | (let ((i (cadr step))) | |
133 | (push (cons (ash 1 i) (make-index-mask w `(not ,i))) list))) | |
134 | ((and (consp step) | |
135 | (eq (car step) :exchange) | |
136 | (integerp (cadr step)) (integerp (caddr step)) | |
137 | (<= 0 (cadr step) (caddr step) max-bit) | |
138 | (null (cdddr step))) | |
139 | (let ((i (cadr step)) (j (caddr step))) | |
140 | (push (cons (- (ash 1 j) (ash 1 i)) | |
141 | (make-index-mask w `(and ,i (not ,j)))) | |
142 | list))) | |
143 | ((and (consp step) | |
144 | (eq (car step) :exchange-invert) | |
145 | (integerp (cadr step)) (integerp (caddr step)) | |
146 | (<= 0 (cadr step) (caddr step) max-bit) | |
147 | (null (cdddr step))) | |
148 | (let ((i (cadr step)) (j (caddr step))) | |
149 | (push (cons (+ (ash 1 i) (ash 1 j)) | |
150 | (make-index-mask w `(and (not ,i) (not ,j)))) | |
151 | list))) | |
152 | (t | |
153 | (error "unknown permutation step ~S" step)))) | |
154 | (nreverse list))) | |
155 | ||
156 | ;;;-------------------------------------------------------------------------- | |
157 | ;;; Permutation network diagnostics. | |
158 | ||
159 | (defun print-permutation-network (steps &optional (stream *standard-output*)) | |
160 | "Print a description of the permutation network STEPS to STREAM. | |
161 | ||
162 | A permutation network consists of a list of pairs | |
163 | ||
164 | (SHIFT . MASK) | |
165 | ||
166 | indicating that the bits selected by MASK, and those SHIFT bits to the | |
167 | left, should be exchanged. | |
168 | ||
169 | The output is intended to be human-readable and is subject to change." | |
170 | ||
171 | (let ((shiftwd 1) (maskwd 2)) | |
172 | ||
173 | ;; Determine suitable print widths for shifts and masks. | |
174 | (dolist (step steps) | |
175 | (let ((shift (car step)) (mask (cdr step))) | |
176 | (let ((swd (1+ (floor (log shift 10)))) | |
177 | (mwd (ash 1 (- (integer-length (1- (integer-length mask))) | |
178 | 2)))) | |
179 | (when (> swd shiftwd) (setf shiftwd swd)) | |
180 | (when (> mwd maskwd) (setf maskwd mwd))))) | |
181 | ||
182 | ;; Print the display. | |
183 | (pprint-logical-block (stream steps :prefix "(" :suffix ")") | |
184 | (let ((first t)) | |
185 | (dolist (step steps) | |
186 | (let ((shift (car step)) (mask (cdr step))) | |
187 | ||
188 | ;; Separate entries with newlines. | |
189 | (cond (first (setf first nil)) | |
190 | (t (pprint-newline :mandatory stream))) | |
191 | ||
192 | (let ((swaps nil)) | |
193 | ||
194 | ;; Determine the list of exchanges implied by the mask. | |
195 | (dotimes (i (integer-length mask)) | |
196 | (when (logbitp i mask) | |
197 | (push (cons i (+ i shift)) swaps))) | |
198 | (setf swaps (nreverse swaps)) | |
199 | ||
200 | ;; Print the entry. | |
201 | (format stream "~@<(~;~vD #x~(~v,'0X~) ~8I~:@_~W~;)~:>" | |
202 | shiftwd shift maskwd mask swaps)))))) | |
203 | ||
204 | ;; Print a final newline following the close parenthesis. | |
205 | (terpri stream))) | |
206 | ||
207 | (defun demonstrate-permutation-network | |
208 | (n steps &optional reference (stream *standard-output*)) | |
209 | "Print, on STREAM, a demonstration of the permutation STEPS. | |
210 | ||
211 | Begin, on the left, with the integers from 0 up to N - 1. For each | |
212 | (SHIFT . MASK) element in STEPS, print an additional column showing the | |
213 | effect of that step on the vector. If REFERENCE is not nil, then it | |
214 | should be a vector of length at least N: on the right, print the REFERENCE | |
215 | vector, showing where the result of the permutation STEPS differs from the | |
216 | REFERENCE. Return non-nil if the output matches the reference; return nil | |
217 | if the output doesn't match, or no reference was supplied." | |
218 | ||
219 | (let ((v (make-array n))) | |
220 | ||
221 | ;; Initialize a vector of lists which will record, for each step in the | |
222 | ;; permutation network, which value is in that position. The lists are | |
223 | ;; reversed, so the `current' value is at the front. | |
224 | (dotimes (i n) (setf (aref v i) (cons i nil))) | |
225 | ||
226 | ;; Work through the permutation steps updating the vector. | |
227 | (dolist (step steps) | |
228 | (let ((shift (car step)) (mask (cdr step))) | |
229 | ||
230 | (dotimes (i n) (push (car (aref v i)) (aref v i))) | |
231 | ||
232 | (dotimes (i n) | |
233 | (when (logbitp i mask) | |
234 | (rotatef (car (aref v i)) | |
235 | (car (aref v (+ i shift)))))))) | |
236 | ||
237 | ;; Print the result. | |
238 | (let ((ok (not (null reference)))) | |
239 | (dotimes (i n) | |
240 | (let* ((entry (aref v i)) | |
241 | (final (car entry))) | |
242 | (format stream "~{ ~7D~}" (reverse entry)) | |
243 | (when reference | |
244 | (let* ((want (aref reference i)) | |
245 | (match (eql final want))) | |
246 | (format stream " ~:[/=~;==~] ~7D" match want) | |
247 | (unless match (setf ok nil)))) | |
248 | (terpri stream))) | |
249 | (when reference | |
250 | (format stream "~:[FAIL~;pass~]~%" ok)) | |
251 | ok))) | |
252 | ||
253 | ;;;-------------------------------------------------------------------------- | |
c7c44436 MW |
254 | ;;; Beneš networks. |
255 | ||
256 | (defun compute-benes-step (n p p-inv bit clear-input) | |
257 | "Compute a single layer of a Beneš network. | |
258 | ||
259 | N is a fixnum. P is a vector of fixnums defining a permutation: for each | |
260 | output bit position i (numbering the least significant bit 0), element i | |
261 | gives the number of the input which should end up in that position; P-INV | |
262 | gives the inverse permutation in the same form. BIT is a power of 2 which | |
263 | gives the distance between bits we should consider. CLEAR-INPUT is | |
264 | a (generalized) boolean: if true, we attempt to do no work on the input | |
265 | side; if false, we try to do no work on the output side. The length of P | |
266 | must be at least (logior N BIT). | |
267 | ||
268 | The output consists of a pair of masks M0 and M1, to be used on the input | |
269 | and output sides respectively. The permutation stage, applied to an input | |
270 | X, is as follows: | |
271 | ||
272 | (let ((tmp (logand (logxor x (ash x (- bit))) mask))) | |
273 | (logxor x tmp (ash tmp bit))) | |
274 | ||
275 | The critical property of the masks is that it's possible to compute an | |
276 | inner permutation, mapping the output of the M0 stage to the input of the | |
277 | M1 stage, such that (a) the overall composition of the three permutations | |
278 | is the given permutation P, and (b) the distances that the bits need to | |
279 | be moved by the inner permutation all have BIT clear. | |
280 | ||
281 | The resulting permutation will attempt to avoid touching elements at | |
282 | indices greater than N. This attempt will succeed if all such elements | |
283 | contain values equal to their indices. | |
284 | ||
285 | By appropriately composing layers computed by this function, then, it's | |
286 | possible to perform an arbitrary permutation of 2^n bits in 2 n - 1 simple | |
287 | steps like the one above." | |
288 | ||
289 | ;; Consider the following problem. You're given two equally-sized | |
290 | ;; collections of things, called `left' and `right'. Each left thing is | |
291 | ;; attached to exactly one right thing with a string, and /vice versa/. | |
292 | ;; Furthermore, the left things, and the right things, are each linked | |
293 | ;; together in pairs, so each pair has two strings coming out of it. Our | |
294 | ;; job is to paint the strings so that each linked pair of things has one | |
295 | ;; red string and one blue string. | |
296 | ;; | |
297 | ;; This is quite straightforward. Pick a pair whose strings aren't yet | |
298 | ;; coloured, and colour one of its strings, chosen arbitrarily, red. Find | |
299 | ;; the pair at the other end of this red string. If the two other things | |
300 | ;; in these two pairs are connected, then paint that string blue and move | |
301 | ;; on. Otherwise, both things have an uncoloured string, so paint both of | |
302 | ;; them blue and trace along these now blue strings to find two more thing | |
303 | ;; pairs. Again, the other thing in each pair has an uncoloured string. | |
304 | ;; If these things share the /same/ string, paint it red and move on. | |
305 | ;; Otherwise, paint both strings red, trace, and repeat. Eventually, we'll | |
306 | ;; find two things joined by the same string, each paired with another | |
307 | ;; thing whose strings we've just painted the same colour. Once we're | |
308 | ;; done, we'll have painted a cycle's worth of strings, and each pair of | |
309 | ;; things will have either both of its strings painted different colours, | |
310 | ;; or neither of them. | |
311 | ;; | |
312 | ;; The right things are the integers 0, 1, ..., n - 1, where n is some | |
313 | ;; power of 2, paired according to whether they differ only in BIT. The | |
314 | ;; left things are the same integers, connected to the right things | |
315 | ;; according to the permutation P: the right thing labelled i is connected | |
316 | ;; to the left thing labelled P(i). Similarly, two left things are paired | |
317 | ;; if their labels P(i) and P(j) differ only in BIT. We're going to paint | |
318 | ;; a string red if we're going to arrange to clear BIT in the labels at | |
319 | ;; both ends, possibly by swapping the two labels, and paint it red if | |
320 | ;; we're going to arrange to set BIT. Once we've done this, later stages | |
321 | ;; of the filter will permute the red- and blue-painted things | |
322 | ;; independently. | |
323 | ||
324 | (let ((m0 0) (m1 0) (done 0)) | |
325 | ||
326 | ;; Now work through the permutation cycles. | |
327 | (do ((i (1- n) (1- i))) | |
328 | ((minusp i)) | |
329 | ||
330 | ;; Skip if we've done this one already. | |
331 | (unless (or (plusp (logand i bit)) | |
332 | (logbitp i done)) | |
333 | ||
334 | ;; Find the other associated values. | |
335 | (let* ((i0 i) (i1 (aref p-inv i)) | |
336 | (sense (cond ((>= (logior i0 bit) n) 0) | |
337 | (clear-input (logand i0 bit)) | |
338 | (t (logand i1 bit))))) | |
339 | ||
340 | #+noise | |
341 | (format t ";; new cycle: i0 = ~D, j0 = ~D; i1 = ~D, j1 = ~D~%" | |
342 | i0 (logxor i0 bit) | |
343 | i1 (logxor i1 bit)) | |
344 | ||
345 | ;; Mark this index as done. | |
346 | (setf (ldb (byte 1 i0) done) 1) | |
347 | #+noise (format t ";; done = #x~2,'0X~%" done) | |
348 | ||
349 | ;; Now trace round the cycle. | |
350 | (loop | |
351 | ||
352 | ;; Mark this index as done. | |
353 | (setf (ldb (byte 1 (logandc2 i0 bit)) done) 1) | |
354 | #+noise (format t ";; done = #x~2,'0X~%" done) | |
355 | ||
356 | ;; Swap the input and output pairs if necessary. | |
357 | (unless (= (logand i0 bit) sense) | |
358 | #+noise | |
359 | (format t ";; swap input: ~D <-> ~D~%" | |
360 | (logandc2 i0 bit) (logior i0 bit)) | |
361 | (setf (ldb (byte 1 (logandc2 i0 bit)) m0) 1)) | |
362 | (unless (= (logand i1 bit) sense) | |
363 | #+noise | |
364 | (format t ";; swap output: ~D <-> ~D~%" | |
365 | (logandc2 i1 bit) (logior i1 bit)) | |
366 | (setf (ldb (byte 1 (logandc2 i1 bit)) m1) 1)) | |
367 | ||
368 | ;; Advance around the cycle. | |
369 | (let* ((j0 (logxor i0 bit)) | |
370 | (j1 (logxor i1 bit)) | |
371 | (next-i1 (aref p-inv j0)) | |
372 | (next-i0 (aref p j1))) | |
373 | (when (= next-i0 j0) (return)) | |
374 | (setf i0 next-i0 | |
375 | i1 next-i1 | |
376 | sense (logxor sense bit))) | |
377 | ||
378 | #+noise | |
379 | (format t ";; advance: i0 = ~D, j0 = ~D; i1 = ~D, j1 = ~D~%" | |
380 | i0 (logxor i0 bit) | |
381 | i1 (logxor i1 bit)))))) | |
382 | ||
383 | (values m0 m1))) | |
384 | ||
385 | (defun compute-final-benes-step (n p p-inv bit) | |
386 | "Determine the innermost stage of a Beneš network. | |
387 | ||
388 | N is a fixnum. P is a vector of fixnums defining a permutation: for each | |
389 | output bit position i (numbering the least significant bit 0), element i | |
390 | gives the number of the input which should end up in that position; P-INV | |
391 | gives the inverse permutation in the same form. BIT is a power of 2 which | |
392 | gives the distance between bits we should consider. The length of P must | |
393 | be at least (logior N BIT). | |
394 | ||
395 | Furthermore, the ith element of P must be equal either to i or to | |
396 | (logxor i BIT); and therefore P-INV must be equal to P. | |
397 | ||
398 | Return the mask such that | |
399 | ||
400 | (let ((tmp (logand (logxor x (ash x (- bit))) mask))) | |
401 | (logxor x tmp (ash tmp bit))) | |
402 | ||
403 | applies the permutation P to the bits of x." | |
404 | ||
405 | (declare (ignorable p-inv)) | |
406 | ||
407 | (let ((m 0)) | |
408 | (dotimes (i n) | |
409 | (unless (plusp (logand i bit)) | |
410 | (let ((x (aref p i))) | |
411 | #+paranoid | |
412 | (assert (= (logandc2 x bit) i)) | |
413 | #+paranoid | |
414 | (assert (= x (aref p-inv i))) | |
415 | ||
416 | (unless (= x i) | |
417 | (setf (ldb (byte 1 i) m) 1))))) | |
418 | m)) | |
419 | ||
420 | (defun apply-benes-step (p p-inv bit m0 m1) | |
421 | "Apply input and output steps for a Beneš network to a permutation. | |
422 | ||
423 | Given the permutation P and its inverse, and the distance BIT, as passed | |
424 | to `compute-benes-step', and the masks M0 and M1 returned, determine and | |
425 | return the necessary `inner' permutation to be applied between these | |
426 | steps, and its inverse. | |
427 | ||
428 | A permutation-network step, and, in particular, a Beneš step, is an | |
429 | involution, so the change to the vectors P and P-INV can be undone by | |
430 | calling the function again with the same arguments." | |
431 | ||
432 | (flet ((swaps (p p-inv mask) | |
433 | (dotimes (i0 (length p)) | |
434 | (when (logbitp i0 mask) | |
435 | (let* ((j0 (logior i0 bit)) | |
436 | (i1 (aref p-inv i0)) | |
437 | (j1 (aref p-inv j0))) | |
438 | (setf (aref p i1) j0 | |
439 | (aref p j1) i0) | |
440 | (rotatef (aref p-inv i0) (aref p-inv j0))))))) | |
441 | (swaps p p-inv m0) | |
442 | (swaps p-inv p m1) | |
443 | ||
444 | #+paranoid | |
445 | (let* ((n (length p))) | |
446 | (dotimes (i n) | |
447 | (assert (= (aref p (aref p-inv i)) i)) | |
448 | (assert (= (aref p-inv (aref p i)) i)))))) | |
449 | ||
450 | (defun benes-search (p) | |
451 | "Given a bit permutation P, describe a Beneš network implementing P. | |
452 | ||
453 | P is a sequence of fixnums defining a permutation: for each output bit | |
454 | position i (numbering the least significant bit 0), element i gives the | |
455 | number of the input which should end up in that position. | |
456 | ||
457 | The return value is a list of steps of the form | |
458 | ||
459 | (BIT MASK (X . Y) (X' . Y') ...) | |
460 | ||
461 | To implement this permutation step: | |
462 | ||
463 | * given an input X, compute | |
464 | ||
465 | (let ((tmp (logand (logxor x (ash x (- bit))) mask))) | |
466 | (logxor x tmp (ash tmp bit))) | |
467 | ||
468 | or, equivalently, | |
469 | ||
470 | * exchange the bits in the positions given in each of the pairs X, Y, | |
471 | ..., where each Y = X + BIT." | |
472 | ||
473 | (let* ((n (length p)) | |
474 | (w (ash 1 (integer-length (1- n)))) | |
475 | (p (let ((new (make-array w :element-type 'fixnum))) | |
476 | (replace new p) | |
477 | (do ((i n (1+ i))) | |
478 | ((>= i w)) | |
479 | (setf (aref new i) i)) | |
480 | new)) | |
481 | (p-inv (invert-permutation p))) | |
482 | ||
483 | (labels ((recurse (todo) | |
484 | ;; Main recursive search. DONE is a mask of the bits which | |
485 | ;; have been searched. Return the number of skipped stages | |
486 | ;; and a list of steps (BIT M0 M1), indicating that (BIT M0) | |
487 | ;; should be performed before the following stages, and | |
488 | ;; (BIT M1) should be performed afterwards. | |
489 | ;; | |
490 | ;; The permutation `p' and its inverse `p-inv' will be | |
491 | ;; modified and restored. | |
492 | ||
493 | (cond ((zerop (logand todo (1- todo))) | |
494 | ;; Only one more bit left. Use the more efficient | |
495 | ;; final-step computation. | |
496 | ||
497 | (let ((m (compute-final-benes-step n p p-inv todo))) | |
498 | (values (if m 0 1) (list (list todo m 0))))) | |
499 | ||
500 | (t | |
501 | ;; More searching to go. We'll keep the result which | |
502 | ;; maximizes the number of skipped stages. | |
503 | (let ((best-list nil) | |
504 | (best-skips -1)) | |
505 | ||
506 | (flet ((try (bit clear-input) | |
507 | ;; Try a permutation with the given BIT and | |
508 | ;; CLEAR-INPUT arguments to | |
509 | ;; `compute-benes-step'. | |
510 | ||
511 | ;; Compute the next step. | |
512 | (multiple-value-bind (m0 m1) | |
513 | (compute-benes-step n p p-inv | |
514 | bit clear-input) | |
515 | ||
516 | ;; Apply the step and recursively | |
517 | ;; determine the inner permutation. | |
518 | (apply-benes-step p p-inv bit m0 m1) | |
519 | (multiple-value-bind (nskip tail) | |
520 | (recurse (logandc2 todo bit)) | |
521 | (apply-benes-step p p-inv bit m0 m1) | |
522 | ||
523 | ;; Work out how good this network is. | |
524 | ;; Keep it if it improves over the | |
525 | ;; previous attempt. | |
526 | (when (zerop m0) (incf nskip)) | |
527 | (when (zerop m1) (incf nskip)) | |
528 | (when (> nskip best-skips) | |
529 | (setf best-list | |
530 | (cons (list bit m0 m1) | |
531 | tail) | |
532 | best-skips | |
533 | nskip)))))) | |
534 | ||
535 | ;; Work through each bit that we haven't done | |
536 | ;; already, and try skipping both the start and end | |
537 | ;; steps. | |
538 | (do ((bit 1 (ash bit 1))) | |
539 | ((>= bit w)) | |
540 | (when (plusp (logand bit todo)) | |
541 | (try bit nil) | |
542 | (try bit t)))) | |
543 | (values best-skips best-list)))))) | |
544 | ||
545 | ;; Find the best permutation network. | |
546 | (multiple-value-bind (nskip list) (recurse (1- w)) | |
547 | (declare (ignore nskip)) | |
548 | ||
549 | ;; Turn the list returned by `recurse' into a list of (SHIFT MASK) | |
550 | ;; entries as expected by everything else. | |
551 | (let ((head nil) (tail nil)) | |
552 | (dolist (step list (nconc (nreverse head) tail)) | |
553 | (destructuring-bind (bit m0 m1) step | |
554 | (when (plusp m0) (push (cons bit m0) head)) | |
555 | (when (plusp m1) (push (cons bit m1) tail))))))))) | |
556 | ||
557 | ;;;-------------------------------------------------------------------------- | |
558 | ;;; Special functions for DES permutations. | |
559 | ||
560 | (defun benes-search-des (p &optional attempts) | |
561 | "Search for a Beneš network for a DES 64-bit permutation. | |
562 | ||
563 | P must be a sequence of 64 fixnums, each of which is between 0 and 64 | |
564 | inclusive. In the DES convention, bits are numbered with the most- | |
565 | significant bit being bit 1, and increasing towards the least-significant | |
566 | bit, which is bit 64. Each nonzero number must appear at most once, and | |
567 | specifies which input bit must appear in that output position. There may | |
568 | also be any number of zero entries, which mean `don't care'. | |
569 | ||
570 | This function searches for and returns a Beneš network which implements a | |
571 | satisfactory permutation. If ATTEMPTS is nil or omitted, then search | |
572 | exhaustively, returning the shortest network. Otherwise, return the | |
573 | shortest network found after considering ATTEMPTS randomly chosen | |
574 | matching permutations." | |
575 | ||
576 | (let* ((n (length p)) | |
577 | (p (map '(vector fixnum) | |
578 | (lambda (x) | |
579 | (if (zerop x) -1 | |
580 | (- 64 x))) | |
581 | (reverse p))) | |
582 | (seen (make-hash-table)) | |
583 | (nmissing 0) (missing nil) (indices nil)) | |
584 | ||
585 | ;; Find all of the `don't care' slots, and keep track of the bits which | |
586 | ;; have homes to go to. | |
587 | (dotimes (i n) | |
588 | (let ((x (aref p i))) | |
589 | (cond ((minusp x) | |
590 | (push i indices) | |
591 | (incf nmissing)) | |
592 | (t (setf (gethash x seen) t))))) | |
593 | ||
594 | ;; Fill in numbers of the input bits which don't have fixed places to go. | |
595 | (setf missing (make-array nmissing :element-type 'fixnum)) | |
596 | (let ((j 0)) | |
597 | (dotimes (i n) | |
598 | (unless (gethash i seen) | |
599 | (setf (aref missing j) i) | |
600 | (incf j))) | |
601 | (assert (= j nmissing))) | |
602 | ||
603 | ;; Run the search, printing successes as we find them to keep the user | |
604 | ;; amused. | |
605 | (let ((best nil) (best-length nil)) | |
606 | (loop | |
607 | (cond ((eql attempts 0) (return best)) | |
608 | (attempts (shuffle missing) (decf attempts)) | |
609 | ((null (next-permutation missing)) (return best))) | |
610 | (do ((idx indices (cdr idx)) | |
611 | (i 0 (1+ i))) | |
612 | ((endp idx)) | |
613 | (setf (aref p (car idx)) (aref missing i))) | |
614 | (let* ((benes (benes-search p)) (len (length benes))) | |
615 | (when (or (null best-length) | |
616 | (< len best-length)) | |
617 | (setf best-length len | |
618 | best benes) | |
619 | (print-permutation-network benes) | |
620 | (force-output))))))) | |
621 | ||
622 | ;;;-------------------------------------------------------------------------- | |
d3f33b9a MW |
623 | ;;; Examples and useful runes. |
624 | ||
625 | #+example | |
626 | (let* ((ip #(58 50 42 34 26 18 10 2 | |
627 | 60 52 44 36 28 20 12 4 | |
628 | 62 54 46 38 30 22 14 6 | |
629 | 64 56 48 40 32 24 16 8 | |
630 | 57 49 41 33 25 17 9 1 | |
631 | 59 51 43 35 27 19 11 3 | |
632 | 61 53 45 37 29 21 13 5 | |
633 | 63 55 47 39 31 23 15 7)) | |
634 | (fixed-ip (map '(vector fixnum) | |
635 | (lambda (x) (- 64 x)) | |
636 | (reverse ip))) | |
637 | (trad-network | |
638 | (make-permutation-network | |
639 | 64 ; 5 4 3 2 1 0 | |
640 | '((:exchange-invert 2 5) ; ~2 4 3 ~5 1 0 | |
641 | (:exchange-invert 1 4) ; ~2 ~1 3 ~5 ~4 0 | |
642 | (:exchange-invert 0 3) ; ~2 ~1 ~0 ~5 ~4 ~3 | |
643 | (:exchange-invert 3 4) ; ~2 0 1 ~5 ~4 ~3 | |
48af823d MW |
644 | (:exchange-invert 4 5)))) ; ~0 2 1 ~5 ~4 ~3 |
645 | (new-network | |
646 | (make-permutation-network | |
647 | 64 ; 5 4 3 2 1 0 | |
648 | '((:exchange-invert 2 5) ; ~2 4 3 ~5 1 0 | |
649 | (:exchange-invert 4 5) ; ~4 2 3 ~5 1 0 | |
650 | (:exchange 1 5) ; 1 2 3 ~5 ~4 0 | |
651 | (:exchange 3 5) ; 3 2 1 ~5 ~4 0 | |
652 | (:exchange-invert 0 5))))) ; ~0 2 1 ~5 ~4 ~3 | |
d3f33b9a MW |
653 | |
654 | (fresh-line) | |
655 | ||
c7c44436 MW |
656 | (let ((benes-network (benes-search fixed-ip))) |
657 | (print-permutation-network benes-network) | |
658 | (demonstrate-permutation-network 64 benes-network fixed-ip)) | |
659 | (terpri) | |
d3f33b9a | 660 | (print-permutation-network trad-network) |
48af823d MW |
661 | (demonstrate-permutation-network 64 trad-network fixed-ip) |
662 | (terpri) | |
663 | (print-permutation-network new-network) | |
664 | (demonstrate-permutation-network 64 new-network fixed-ip)) | |
c7c44436 MW |
665 | |
666 | #+example | |
667 | (benes-search-des #( 0 0 0 0 | |
668 | 57 49 41 33 25 17 9 1 | |
669 | 58 50 42 34 26 18 10 2 | |
670 | 59 51 43 35 27 19 11 3 | |
671 | 60 52 44 36 | |
672 | 0 0 0 0 | |
673 | 63 55 47 39 31 23 15 7 | |
674 | 62 54 46 38 30 22 14 6 | |
675 | 61 53 45 37 29 21 13 5 | |
676 | 28 20 12 4)) | |
677 | ||
678 | #+example | |
679 | (let ((pc2 (make-array '(8 6) | |
680 | :element-type 'fixnum | |
681 | :initial-contents '((14 17 11 24 1 5) | |
682 | ( 3 28 15 6 21 10) | |
683 | (23 19 12 4 26 8) | |
684 | (16 7 27 20 13 2) | |
685 | (41 52 31 37 47 55) | |
686 | (30 40 51 45 33 48) | |
687 | (44 49 39 56 34 53) | |
688 | (46 42 50 36 29 32))))) | |
689 | (benes-search-des | |
690 | (make-array 64 | |
691 | :element-type 'fixnum | |
692 | :initial-contents | |
693 | (loop for i in '(2 4 6 8 1 3 5 7) | |
694 | nconc (list 0 0) | |
695 | nconc (loop for j below 6 | |
696 | for x = (aref pc2 (1- i) j) | |
697 | collect (if (<= x 32) (+ x 4) (+ x 8))))) | |
698 | 1000)) |