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.
6 ;;;--------------------------------------------------------------------------
7 ;;; General permutation utilities.
10 "Randomly permute the elements of the vector V. Return V."
16 (rotatef (aref v i) (aref v (1- k))))))))
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))))
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))
29 (defun next-permutation (v)
30 "Adjust V so that it reflects the next permutation in ascending order.
32 V should be a vector of real numbers. Returns V if successful, or nil if
33 there are no more permutations."
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.
40 ;; Equivalently, reverse the tail Z, Y, X, ... so we have A, ... X, Y, Z,
41 ;; and swap A with the next larger element.
47 (loop (when (zerop k) (return-from next-permutation nil))
53 (do ((i (1+ k) (1+ i))
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)))))
62 (defun make-index-mask (w mask-expr)
63 "Construct a bitmask based on bitwise properties of the bit indices.
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:
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."
73 (let ((max-bit (1- (integer-length (1- w))))
76 (labels ((interpret (expr)
77 (cond ((and (integerp expr) (<= 0 expr max-bit))
79 ((and (consp expr) (eq (car expr) 'not)
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)))
87 (error "unknown mask expression ~S" expr)))))
88 (when (interpret mask-expr)
89 (setf (ldb (byte 1 i) mask) 1))))))
91 (defun make-permutation-network (w steps)
92 "Construct a permutation network.
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:
97 * (SHIFT . MASK) -- a pair of integers is treated literally;
99 * (SHIFT MASK-EXPR) -- the SHIFT is literal, but the MASK-EXPR is
100 processed by `make-index-mask' to calculate the mask;
102 * (:invert I) -- make an instruction which inverts the sense of the
105 * (:exchange I J) -- make an instruction which exchanges index bits I
108 * (:exchange-invert I J) -- make an instruction which exchanges and
109 inverts index bits I and J.
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)."
115 (let ((max-mask (1- (ash 1 w)))
117 (max-bit (1- (integer-length (1- w))))
120 (cond ((and (consp step)
121 (integerp (car step)) (<= 0 (car step) max-shift)
122 (integerp (cdr step)) (<= 0 (cdr step) max-mask))
125 (integerp (car step)) (<= 0 (car step) max-shift)
127 (push (cons (car step) (make-index-mask w (cadr step))) list))
129 (eq (car step) :invert)
130 (integerp (cadr step)) (<= 0 (cadr step) max-bit)
132 (let ((i (cadr step)))
133 (push (cons (ash 1 i) (make-index-mask w `(not ,i))) list)))
135 (eq (car step) :exchange)
136 (integerp (cadr step)) (integerp (caddr step))
137 (<= 0 (cadr step) (caddr step) max-bit)
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))))
144 (eq (car step) :exchange-invert)
145 (integerp (cadr step)) (integerp (caddr step))
146 (<= 0 (cadr step) (caddr step) max-bit)
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))))
153 (error "unknown permutation step ~S" step))))
156 ;;;--------------------------------------------------------------------------
157 ;;; Permutation network diagnostics.
159 (defun print-permutation-network (steps &optional (stream *standard-output*))
160 "Print a description of the permutation network STEPS to STREAM.
162 A permutation network consists of a list of pairs
166 indicating that the bits selected by MASK, and those SHIFT bits to the
167 left, should be exchanged.
169 The output is intended to be human-readable and is subject to change."
171 (let ((shiftwd 1) (maskwd 2))
173 ;; Determine suitable print widths for shifts and masks.
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)))
179 (when (> swd shiftwd) (setf shiftwd swd))
180 (when (> mwd maskwd) (setf maskwd mwd)))))
182 ;; Print the display.
183 (pprint-logical-block (stream steps :prefix "(" :suffix ")")
186 (let ((shift (car step)) (mask (cdr step)))
188 ;; Separate entries with newlines.
189 (cond (first (setf first nil))
190 (t (pprint-newline :mandatory stream)))
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))
201 (format stream "~@<(~;~vD #x~(~v,'0X~) ~8I~:@_~W~;)~:>"
202 shiftwd shift maskwd mask swaps))))))
204 ;; Print a final newline following the close parenthesis.
207 (defun demonstrate-permutation-network
210 (stream *standard-output*))
211 "Print, on STREAM, a demonstration of the permutation STEPS.
213 Begin, on the left, with the integers from 0 up to N - 1. For each
214 (SHIFT . MASK) element in STEPS, print an additional column showing the
215 effect of that step on the vector. If REFERENCE is not nil, then it
216 should be a vector of length at least N: on the right, print the REFERENCE
217 vector, showing where the result of the permutation STEPS differs from the
218 REFERENCE. Return non-nil if the output matches the reference; return nil
219 if the output doesn't match, or no reference was supplied."
221 (let ((v (make-array n)))
223 ;; Initialize a vector of lists which will record, for each step in the
224 ;; permutation network, which value is in that position. The lists are
225 ;; reversed, so the `current' value is at the front.
226 (dotimes (i n) (setf (aref v i) (cons i nil)))
228 ;; Work through the permutation steps updating the vector.
230 (let ((shift (car step)) (mask (cdr step)))
232 (dotimes (i n) (push (car (aref v i)) (aref v i)))
235 (when (logbitp i mask)
236 (rotatef (car (aref v i))
237 (car (aref v (+ i shift))))))))
240 (let ((ok (not (null reference))))
242 (let* ((entry (aref v i))
244 (format stream "~{ ~7D~}" (reverse entry))
246 (let* ((want (aref reference i))
247 (match (eql final want)))
248 (format stream " ~:[/=~;==~] ~7D" match want)
249 (unless match (setf ok nil))))
252 (format stream "~:[FAIL~;pass~]~%" ok))
255 ;;;--------------------------------------------------------------------------
258 (defun compute-benes-step (n p p-inv bit clear-input)
259 "Compute a single layer of a Beneš network.
261 N is a fixnum. P is a vector of fixnums defining a permutation: for each
262 output bit position i (numbering the least significant bit 0), element i
263 gives the number of the input which should end up in that position; P-INV
264 gives the inverse permutation in the same form. BIT is a power of 2 which
265 gives the distance between bits we should consider. CLEAR-INPUT is
266 a (generalized) boolean: if true, we attempt to do no work on the input
267 side; if false, we try to do no work on the output side. The length of P
268 must be at least (logior N BIT).
270 The output consists of a pair of masks M0 and M1, to be used on the input
271 and output sides respectively. The permutation stage, applied to an input
274 (let ((tmp (logand (logxor x (ash x (- bit))) mask)))
275 (logxor x tmp (ash tmp bit)))
277 The critical property of the masks is that it's possible to compute an
278 inner permutation, mapping the output of the M0 stage to the input of the
279 M1 stage, such that (a) the overall composition of the three permutations
280 is the given permutation P, and (b) the distances that the bits need to
281 be moved by the inner permutation all have BIT clear.
283 The resulting permutation will attempt to avoid touching elements at
284 indices greater than N. This attempt will succeed if all such elements
285 contain values equal to their indices.
287 By appropriately composing layers computed by this function, then, it's
288 possible to perform an arbitrary permutation of 2^n bits in 2 n - 1 simple
289 steps like the one above."
291 ;; Consider the following problem. You're given two equally-sized
292 ;; collections of things, called `left' and `right'. Each left thing is
293 ;; attached to exactly one right thing with a string, and /vice versa/.
294 ;; Furthermore, the left things, and the right things, are each linked
295 ;; together in pairs, so each pair has two strings coming out of it. Our
296 ;; job is to paint the strings so that each linked pair of things has one
297 ;; red string and one blue string.
299 ;; This is quite straightforward. Pick a pair whose strings aren't yet
300 ;; coloured, and colour one of its strings, chosen arbitrarily, red. Find
301 ;; the pair at the other end of this red string. If the two other things
302 ;; in these two pairs are connected, then paint that string blue and move
303 ;; on. Otherwise, both things have an uncoloured string, so paint both of
304 ;; them blue and trace along these now blue strings to find two more thing
305 ;; pairs. Again, the other thing in each pair has an uncoloured string.
306 ;; If these things share the /same/ string, paint it red and move on.
307 ;; Otherwise, paint both strings red, trace, and repeat. Eventually, we'll
308 ;; find two things joined by the same string, each paired with another
309 ;; thing whose strings we've just painted the same colour. Once we're
310 ;; done, we'll have painted a cycle's worth of strings, and each pair of
311 ;; things will have either both of its strings painted different colours,
312 ;; or neither of them.
314 ;; The right things are the integers 0, 1, ..., n - 1, where n is some
315 ;; power of 2, paired according to whether they differ only in BIT. The
316 ;; left things are the same integers, connected to the right things
317 ;; according to the permutation P: the right thing labelled i is connected
318 ;; to the left thing labelled P(i). Similarly, two left things are paired
319 ;; if their labels P(i) and P(j) differ only in BIT. We're going to paint
320 ;; a string red if we're going to arrange to clear BIT in the labels at
321 ;; both ends, possibly by swapping the two labels, and paint it red if
322 ;; we're going to arrange to set BIT. Once we've done this, later stages
323 ;; of the filter will permute the red- and blue-painted things
326 (let ((m0 0) (m1 0) (done 0))
328 ;; Now work through the permutation cycles.
329 (do ((i (1- n) (1- i)))
332 ;; Skip if we've done this one already.
333 (unless (or (plusp (logand i bit))
336 ;; Find the other associated values.
337 (let* ((i0 i) (i1 (aref p-inv i))
338 (sense (cond ((>= (logior i0 bit) n) 0)
339 (clear-input (logand i0 bit))
340 (t (logand i1 bit)))))
343 (format t ";; new cycle: i0 = ~D, j0 = ~D; i1 = ~D, j1 = ~D~%"
347 ;; Mark this index as done.
348 (setf (ldb (byte 1 i0) done) 1)
349 #+noise (format t ";; done = #x~2,'0X~%" done)
351 ;; Now trace round the cycle.
354 ;; Mark this index as done.
355 (setf (ldb (byte 1 (logandc2 i0 bit)) done) 1)
356 #+noise (format t ";; done = #x~2,'0X~%" done)
358 ;; Swap the input and output pairs if necessary.
359 (unless (= (logand i0 bit) sense)
361 (format t ";; swap input: ~D <-> ~D~%"
362 (logandc2 i0 bit) (logior i0 bit))
363 (setf (ldb (byte 1 (logandc2 i0 bit)) m0) 1))
364 (unless (= (logand i1 bit) sense)
366 (format t ";; swap output: ~D <-> ~D~%"
367 (logandc2 i1 bit) (logior i1 bit))
368 (setf (ldb (byte 1 (logandc2 i1 bit)) m1) 1))
370 ;; Advance around the cycle.
371 (let* ((j0 (logxor i0 bit))
373 (next-i1 (aref p-inv j0))
374 (next-i0 (aref p j1)))
375 (when (= next-i0 j0) (return))
378 sense (logxor sense bit)))
381 (format t ";; advance: i0 = ~D, j0 = ~D; i1 = ~D, j1 = ~D~%"
383 i1 (logxor i1 bit))))))
387 (defun compute-final-benes-step (n p p-inv bit)
388 "Determine the innermost stage of a Beneš network.
390 N is a fixnum. P is a vector of fixnums defining a permutation: for each
391 output bit position i (numbering the least significant bit 0), element i
392 gives the number of the input which should end up in that position; P-INV
393 gives the inverse permutation in the same form. BIT is a power of 2 which
394 gives the distance between bits we should consider. The length of P must
395 be at least (logior N BIT).
397 Furthermore, the ith element of P must be equal either to i or to
398 (logxor i BIT); and therefore P-INV must be equal to P.
400 Return the mask such that
402 (let ((tmp (logand (logxor x (ash x (- bit))) mask)))
403 (logxor x tmp (ash tmp bit)))
405 applies the permutation P to the bits of x."
407 (declare (ignorable p-inv))
411 (unless (plusp (logand i bit))
412 (let ((x (aref p i)))
414 (assert (= (logandc2 x bit) i))
416 (assert (= x (aref p-inv i)))
419 (setf (ldb (byte 1 i) m) 1)))))
422 (defun apply-benes-step (p p-inv bit m0 m1)
423 "Apply input and output steps for a Beneš network to a permutation.
425 Given the permutation P and its inverse, and the distance BIT, as passed
426 to `compute-benes-step', and the masks M0 and M1 returned, determine and
427 return the necessary `inner' permutation to be applied between these
428 steps, and its inverse.
430 A permutation-network step, and, in particular, a Beneš step, is an
431 involution, so the change to the vectors P and P-INV can be undone by
432 calling the function again with the same arguments."
434 (flet ((swaps (p p-inv mask)
435 (dotimes (i0 (length p))
436 (when (logbitp i0 mask)
437 (let* ((j0 (logior i0 bit))
439 (j1 (aref p-inv j0)))
442 (rotatef (aref p-inv i0) (aref p-inv j0)))))))
447 (let* ((n (length p)))
449 (assert (= (aref p (aref p-inv i)) i))
450 (assert (= (aref p-inv (aref p i)) i))))))
452 (defun benes-search (p)
453 "Given a bit permutation P, describe a Beneš network implementing P.
455 P is a sequence of fixnums defining a permutation: for each output bit
456 position i (numbering the least significant bit 0), element i gives the
457 number of the input which should end up in that position.
459 The return value is a list of steps of the form
461 (BIT MASK (X . Y) (X' . Y') ...)
463 To implement this permutation step:
465 * given an input X, compute
467 (let ((tmp (logand (logxor x (ash x (- bit))) mask)))
468 (logxor x tmp (ash tmp bit)))
472 * exchange the bits in the positions given in each of the pairs X, Y,
473 ..., where each Y = X + BIT."
475 (let* ((n (length p))
476 (w (ash 1 (integer-length (1- n))))
477 (p (let ((new (make-array w :element-type 'fixnum)))
481 (setf (aref new i) i))
483 (p-inv (invert-permutation p)))
485 (labels ((recurse (todo)
486 ;; Main recursive search. DONE is a mask of the bits which
487 ;; have been searched. Return the number of skipped stages
488 ;; and a list of steps (BIT M0 M1), indicating that (BIT M0)
489 ;; should be performed before the following stages, and
490 ;; (BIT M1) should be performed afterwards.
492 ;; The permutation `p' and its inverse `p-inv' will be
493 ;; modified and restored.
495 (cond ((zerop (logand todo (1- todo)))
496 ;; Only one more bit left. Use the more efficient
497 ;; final-step computation.
499 (let ((m (compute-final-benes-step n p p-inv todo)))
500 (values (if m 0 1) (list (list todo m 0)))))
503 ;; More searching to go. We'll keep the result which
504 ;; maximizes the number of skipped stages.
505 (let ((best-list nil)
508 (flet ((try (bit clear-input)
509 ;; Try a permutation with the given BIT and
510 ;; CLEAR-INPUT arguments to
511 ;; `compute-benes-step'.
513 ;; Compute the next step.
514 (multiple-value-bind (m0 m1)
515 (compute-benes-step n p p-inv
518 ;; Apply the step and recursively
519 ;; determine the inner permutation.
520 (apply-benes-step p p-inv bit m0 m1)
521 (multiple-value-bind (nskip tail)
522 (recurse (logandc2 todo bit))
523 (apply-benes-step p p-inv bit m0 m1)
525 ;; Work out how good this network is.
526 ;; Keep it if it improves over the
528 (when (zerop m0) (incf nskip))
529 (when (zerop m1) (incf nskip))
530 (when (> nskip best-skips)
532 (cons (list bit m0 m1)
537 ;; Work through each bit that we haven't done
538 ;; already, and try skipping both the start and end
540 (do ((bit 1 (ash bit 1)))
542 (when (plusp (logand bit todo))
545 (values best-skips best-list))))))
547 ;; Find the best permutation network.
548 (multiple-value-bind (nskip list) (recurse (1- w))
549 (declare (ignore nskip))
551 ;; Turn the list returned by `recurse' into a list of (SHIFT MASK)
552 ;; entries as expected by everything else.
553 (let ((head nil) (tail nil))
554 (dolist (step list (nconc (nreverse head) tail))
555 (destructuring-bind (bit m0 m1) step
556 (when (plusp m0) (push (cons bit m0) head))
557 (when (plusp m1) (push (cons bit m1) tail)))))))))
559 ;;;--------------------------------------------------------------------------
560 ;;; Special functions for DES permutations.
562 (defun benes-search-des (p &optional attempts)
563 "Search for a Beneš network for a DES 64-bit permutation.
565 P must be a sequence of 64 fixnums, each of which is between 0 and 64
566 inclusive. In the DES convention, bits are numbered with the most-
567 significant bit being bit 1, and increasing towards the least-significant
568 bit, which is bit 64. Each nonzero number must appear at most once, and
569 specifies which input bit must appear in that output position. There may
570 also be any number of zero entries, which mean `don't care'.
572 This function searches for and returns a Beneš network which implements a
573 satisfactory permutation. If ATTEMPTS is nil or omitted, then search
574 exhaustively, returning the shortest network. Otherwise, return the
575 shortest network found after considering ATTEMPTS randomly chosen
576 matching permutations."
578 (let* ((n (length p))
579 (p (map '(vector fixnum)
584 (seen (make-hash-table))
585 (nmissing 0) (missing nil) (indices nil))
587 ;; Find all of the `don't care' slots, and keep track of the bits which
588 ;; have homes to go to.
590 (let ((x (aref p i)))
594 (t (setf (gethash x seen) t)))))
596 ;; Fill in numbers of the input bits which don't have fixed places to go.
597 (setf missing (make-array nmissing :element-type 'fixnum))
600 (unless (gethash i seen)
601 (setf (aref missing j) i)
603 (assert (= j nmissing)))
605 ;; Run the search, printing successes as we find them to keep the user
607 (let ((best nil) (best-length nil))
609 (cond ((eql attempts 0) (return best))
610 (attempts (shuffle missing) (decf attempts))
611 ((null (next-permutation missing)) (return best)))
612 (do ((idx indices (cdr idx))
615 (setf (aref p (car idx)) (aref missing i)))
616 (let* ((benes (benes-search p)) (len (length benes)))
617 (when (or (null best-length)
619 (setf best-length len
621 (print-permutation-network benes)
624 ;;;--------------------------------------------------------------------------
625 ;;; Examples and useful runes.
628 (let* ((ip #(58 50 42 34 26 18 10 2
629 60 52 44 36 28 20 12 4
630 62 54 46 38 30 22 14 6
631 64 56 48 40 32 24 16 8
632 57 49 41 33 25 17 9 1
633 59 51 43 35 27 19 11 3
634 61 53 45 37 29 21 13 5
635 63 55 47 39 31 23 15 7))
636 (fixed-ip (map '(vector fixnum)
637 (lambda (x) (- 64 x))
640 ;; The traditional network. (Exchange each `*' with the earliest
643 ;; - - - - - - - - 0 1 2 3 4 5 6 7
644 ;; - - - - - - - - 8 9 10 11 12 13 14 15
645 ;; - - - - - - - - 16 17 18 19 20 21 22 23
646 ;; - - - - - - - - 24 25 26 27 28 29 30 31
647 ;; - - - - - - - - 32 33 34 35 36 37 38 39
648 ;; - - - - - - - - 40 41 42 43 44 45 46 47
649 ;; - - - - - - - - 48 49 50 51 52 53 54 55
650 ;; - - - - - - - - 56 57 58 59 60 61 62 63
652 ;; * * * * - - - - 36 37 38 39 4 5 6 7
653 ;; * * * * - - - - 44 45 46 47 12 13 14 15
654 ;; * * * * - - - - 52 53 54 55 20 21 22 23
655 ;; * * * * - - - - 60 61 62 63 28 29 30 31
656 ;; - - - - # # # # 32 33 34 35 0 1 2 3
657 ;; - - - - # # # # 40 41 42 43 8 9 10 11
658 ;; - - - - # # # # 48 49 50 51 16 17 18 19
659 ;; - - - - # # # # 56 57 58 59 24 25 26 27
661 ;; * * - - * * - - 54 55 38 39 22 3 26 7
662 ;; * * - - * * - - 62 63 46 47 30 11 34 15
663 ;; - - # # - - # # 52 53 36 37 20 1 24 5
664 ;; - - # # - - # # 60 61 44 45 28 19 22 13
665 ;; * * - - * * - - 50 51 34 35 18 9 12 3
666 ;; * * - - * * - - 58 59 42 43 26 17 20 11
667 ;; - - # # - - # # 48 49 32 33 16 7 10 1
668 ;; - - # # - - # # 56 57 40 41 24 5 28 9
670 ;; * - * - * - * - 63 55 47 39 21 13 35 7
671 ;; - # - # - # - # 62 54 46 38 20 12 34 6
672 ;; * - * - * - * - 61 53 45 37 29 11 23 5
673 ;; - # - # - # - # 60 52 44 36 28 10 22 4
674 ;; * - * - * - * - 59 51 43 35 17 19 21 3
675 ;; - # - # - # - # 58 50 42 34 16 18 20 2
676 ;; * - * - * - * - 57 49 41 33 15 7 29 1
677 ;; - # - # - # - # 56 48 40 32 14 6 28 0
679 ;; * * * * * * * * 60 52 44 36 28 20 12 4
680 ;; - - - - - - - - 62 54 46 38 30 22 14 6
681 ;; - - - - - - - - 61 53 45 37 29 21 13 5
682 ;; # # # # # # # # 63 55 47 39 31 23 15 7
683 ;; * * * * * * * * 56 48 40 32 24 16 8 0
684 ;; - - - - - - - - 58 50 42 34 26 18 10 2
685 ;; - - - - - - - - 57 49 41 33 25 17 9 1
686 ;; # # # # # # # # 59 51 43 35 27 19 11 3
688 ;; * * * * * * * * 57 49 41 33 25 17 9 1
689 ;; * * * * * * * * 59 51 43 35 27 19 11 3
690 ;; - - - - - - - - 61 53 45 37 29 21 13 5
691 ;; - - - - - - - - 63 55 47 39 31 23 15 7
692 ;; - - - - - - - - 56 48 40 32 24 16 8 0
693 ;; - - - - - - - - 58 50 42 34 26 18 10 2
694 ;; # # # # # # # # 60 52 44 36 28 20 12 4
695 ;; # # # # # # # # 62 54 46 38 30 22 14 6
697 (make-permutation-network
699 '((:exchange-invert 2 5) ; ~2 4 3 ~5 1 0
700 (:exchange-invert 1 4) ; ~2 ~1 3 ~5 ~4 0
701 (:exchange-invert 0 3) ; ~2 ~1 ~0 ~5 ~4 ~3
702 (:exchange-invert 3 4) ; ~2 0 1 ~5 ~4 ~3
703 (:exchange-invert 4 5)))) ; ~0 2 1 ~5 ~4 ~3
705 ;; The new twizzle-optimized network. (Exchange each `*' with the
706 ;; earliest available `#'.)
708 ;; - - - - - - - - 0 1 2 3 4 5 6 7
709 ;; - - - - - - - - 8 9 10 11 12 13 14 15
710 ;; - - - - - - - - 16 17 18 19 20 21 22 23
711 ;; - - - - - - - - 24 25 26 27 28 29 30 31
712 ;; - - - - - - - - 32 33 34 35 36 37 38 39
713 ;; - - - - - - - - 40 41 42 43 44 45 46 47
714 ;; - - - - - - - - 48 49 50 51 52 53 54 55
715 ;; - - - - - - - - 56 57 58 59 60 61 62 63
717 ;; * * * * - - - - 36 37 38 39 4 5 6 7
718 ;; * * * * - - - - 44 45 46 47 12 13 14 15
719 ;; * * * * - - - - 52 53 54 55 20 21 22 23
720 ;; * * * * - - - - 60 61 62 63 28 29 30 31
721 ;; - - - - # # # # 32 33 34 35 0 1 2 3
722 ;; - - - - # # # # 40 41 42 43 8 9 10 11
723 ;; - - - - # # # # 48 49 50 51 16 17 18 19
724 ;; - - - - # # # # 56 57 58 59 24 25 26 27
726 ;; * * * * * * * * 48 49 50 51 16 17 18 19
727 ;; * * * * * * * * 56 57 58 59 24 25 26 27
728 ;; - - - - - - - - 52 53 54 55 20 21 22 23
729 ;; - - - - - - - - 60 61 62 63 28 29 30 31
730 ;; - - - - - - - - 32 33 34 35 0 1 2 3
731 ;; - - - - - - - - 40 41 42 43 8 9 10 11
732 ;; # # # # # # # # 36 37 38 39 4 5 6 7
733 ;; # # # # # # # # 44 45 46 47 12 13 14 15
735 ;; - - * * - - * * 48 49 32 33 16 17 0 1
736 ;; - - * * - - * * 56 57 40 41 24 25 8 9
737 ;; - - * * - - * * 52 53 36 37 20 21 4 5
738 ;; - - * * - - * * 60 61 44 45 28 29 12 13
739 ;; # # - - # # - - 50 51 34 35 18 19 2 3
740 ;; # # - - # # - - 58 59 42 43 26 27 10 11
741 ;; # # - - # # - - 54 55 38 39 22 23 6 7
742 ;; # # - - # # - - 62 63 46 47 30 31 14 15
744 ;; - - - - - - - - 48 49 32 33 16 17 0 1
745 ;; * * * * * * * * 50 51 34 35 18 19 2 3
746 ;; - - - - - - - - 52 53 36 37 20 21 4 5
747 ;; * * * * * * * * 54 55 38 39 22 23 6 7
748 ;; # # # # # # # # 56 57 40 41 24 25 8 9
749 ;; - - - - - - - - 58 59 42 43 26 27 10 11
750 ;; # # # # # # # # 60 61 44 45 28 29 12 13
751 ;; - - - - - - - - 62 63 46 47 30 31 14 15
753 ;; * - * - * - * - 57 49 41 33 25 17 9 1
754 ;; * - * - * - * - 59 51 43 35 27 19 11 3
755 ;; * - * - * - * - 61 53 45 37 29 21 13 5
756 ;; * - * - * - * - 63 55 47 39 31 23 15 7
757 ;; - # - # - # - # 56 48 40 32 24 16 8 0
758 ;; - # - # - # - # 58 50 42 34 26 18 10 2
759 ;; - # - # - # - # 60 52 44 36 28 20 12 4
760 ;; - # - # - # - # 62 54 46 38 30 22 14 6
762 (make-permutation-network
764 '((:exchange-invert 2 5) ; ~2 4 3 ~5 1 0
765 (:exchange-invert 4 5) ; ~4 2 3 ~5 1 0
766 (:exchange 1 5) ; 1 2 3 ~5 ~4 0
767 (:exchange 3 5) ; 3 2 1 ~5 ~4 0
768 (:exchange-invert 0 5))))) ; ~0 2 1 ~5 ~4 ~3
772 (let ((benes-network (benes-search fixed-ip)))
773 (print-permutation-network benes-network)
774 (demonstrate-permutation-network 64 benes-network :reference fixed-ip))
776 (print-permutation-network trad-network)
777 (demonstrate-permutation-network 64 trad-network :reference fixed-ip)
779 (print-permutation-network new-network)
780 (demonstrate-permutation-network 64 new-network :reference fixed-ip))
783 (benes-search-des #( 0 0 0 0
784 57 49 41 33 25 17 9 1
785 58 50 42 34 26 18 10 2
786 59 51 43 35 27 19 11 3
789 63 55 47 39 31 23 15 7
790 62 54 46 38 30 22 14 6
791 61 53 45 37 29 21 13 5
795 (let ((pc2 (make-array '(8 6)
796 :element-type 'fixnum
797 :initial-contents '((14 17 11 24 1 5)
804 (46 42 50 36 29 32)))))
807 :element-type 'fixnum
809 (loop for i in '(2 4 6 8 1 3 5 7)
811 nconc (loop for j below 6
812 for x = (aref pc2 (1- i) j)
813 collect (if (<= x 32) (+ x 4) (+ x 8)))))