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
208 (n steps &optional reference (stream *standard-output*))
209 "Print, on STREAM, a demonstration of the permutation STEPS.
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."
219 (let ((v (make-array n)))
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)))
226 ;; Work through the permutation steps updating the vector.
228 (let ((shift (car step)) (mask (cdr step)))
230 (dotimes (i n) (push (car (aref v i)) (aref v i)))
233 (when (logbitp i mask)
234 (rotatef (car (aref v i))
235 (car (aref v (+ i shift))))))))
238 (let ((ok (not (null reference))))
240 (let* ((entry (aref v i))
242 (format stream "~{ ~7D~}" (reverse entry))
244 (let* ((want (aref reference i))
245 (match (eql final want)))
246 (format stream " ~:[/=~;==~] ~7D" match want)
247 (unless match (setf ok nil))))
250 (format stream "~:[FAIL~;pass~]~%" ok))
253 ;;;--------------------------------------------------------------------------
254 ;;; Examples and useful runes.
257 (let* ((ip #(58 50 42 34 26 18 10 2
258 60 52 44 36 28 20 12 4
259 62 54 46 38 30 22 14 6
260 64 56 48 40 32 24 16 8
261 57 49 41 33 25 17 9 1
262 59 51 43 35 27 19 11 3
263 61 53 45 37 29 21 13 5
264 63 55 47 39 31 23 15 7))
265 (fixed-ip (map '(vector fixnum)
266 (lambda (x) (- 64 x))
269 (make-permutation-network
271 '((:exchange-invert 2 5) ; ~2 4 3 ~5 1 0
272 (:exchange-invert 1 4) ; ~2 ~1 3 ~5 ~4 0
273 (:exchange-invert 0 3) ; ~2 ~1 ~0 ~5 ~4 ~3
274 (:exchange-invert 3 4) ; ~2 0 1 ~5 ~4 ~3
275 (:exchange-invert 4 5)))) ; ~0 2 1 ~5 ~4 ~3
277 (make-permutation-network
279 '((:exchange-invert 2 5) ; ~2 4 3 ~5 1 0
280 (:exchange-invert 4 5) ; ~4 2 3 ~5 1 0
281 (:exchange 1 5) ; 1 2 3 ~5 ~4 0
282 (:exchange 3 5) ; 3 2 1 ~5 ~4 0
283 (:exchange-invert 0 5))))) ; ~0 2 1 ~5 ~4 ~3
287 (print-permutation-network trad-network)
288 (demonstrate-permutation-network 64 trad-network fixed-ip)
290 (print-permutation-network new-network)
291 (demonstrate-permutation-network 64 new-network fixed-ip))