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 | ;;;-------------------------------------------------------------------------- | |
254 | ;;; Examples and useful runes. | |
255 | ||
256 | #+example | |
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)) | |
267 | (reverse ip))) | |
268 | (trad-network | |
269 | (make-permutation-network | |
270 | 64 ; 5 4 3 2 1 0 | |
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 | |
48af823d MW |
275 | (:exchange-invert 4 5)))) ; ~0 2 1 ~5 ~4 ~3 |
276 | (new-network | |
277 | (make-permutation-network | |
278 | 64 ; 5 4 3 2 1 0 | |
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 | |
d3f33b9a MW |
284 | |
285 | (fresh-line) | |
286 | ||
287 | (print-permutation-network trad-network) | |
48af823d MW |
288 | (demonstrate-permutation-network 64 trad-network fixed-ip) |
289 | (terpri) | |
290 | (print-permutation-network new-network) | |
291 | (demonstrate-permutation-network 64 new-network fixed-ip)) |