chiark - git - mdw - catacomb/blob - utils/permute.lisp

   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
 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
 284
 285   (fresh-line)
 286
 287   (print-permutation-network trad-network)
 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))