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 ;;; 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 ;;;--------------------------------------------------------------------------
 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
 638        ;; The traditional network.  (Exchange each `*' with the earliest
 639        ;; available `#'.)
 640        ;;
 641        ;;       - - - - - - - -          0  1  2  3  4  5  6  7
 642        ;;       - - - - - - - -          8  9 10 11 12 13 14 15
 643        ;;       - - - - - - - -         16 17 18 19 20 21 22 23
 644        ;;       - - - - - - - -         24 25 26 27 28 29 30 31
 645        ;;       - - - - - - - -         32 33 34 35 36 37 38 39
 646        ;;       - - - - - - - -         40 41 42 43 44 45 46 47
 647        ;;       - - - - - - - -         48 49 50 51 52 53 54 55
 648        ;;       - - - - - - - -         56 57 58 59 60 61 62 63
 649        ;;
 650        ;;       * * * * - - - -         36 37 38 39  4  5  6  7
 651        ;;       * * * * - - - -         44 45 46 47 12 13 14 15
 652        ;;       * * * * - - - -         52 53 54 55 20 21 22 23
 653        ;;       * * * * - - - -         60 61 62 63 28 29 30 31
 654        ;;       - - - - # # # #         32 33 34 35  0  1  2  3
 655        ;;       - - - - # # # #         40 41 42 43  8  9 10 11
 656        ;;       - - - - # # # #         48 49 50 51 16 17 18 19
 657        ;;       - - - - # # # #         56 57 58 59 24 25 26 27
 658        ;;
 659        ;;       * * - - * * - -         54 55 38 39 22  3 26  7
 660        ;;       * * - - * * - -         62 63 46 47 30 11 34 15
 661        ;;       - - # # - - # #         52 53 36 37 20  1 24  5
 662        ;;       - - # # - - # #         60 61 44 45 28 19 22 13
 663        ;;       * * - - * * - -         50 51 34 35 18  9 12  3
 664        ;;       * * - - * * - -         58 59 42 43 26 17 20 11
 665        ;;       - - # # - - # #         48 49 32 33 16  7 10  1
 666        ;;       - - # # - - # #         56 57 40 41 24  5 28  9
 667        ;;
 668        ;;       * - * - * - * -         63 55 47 39 21 13 35  7
 669        ;;       - # - # - # - #         62 54 46 38 20 12 34  6
 670        ;;       * - * - * - * -         61 53 45 37 29 11 23  5
 671        ;;       - # - # - # - #         60 52 44 36 28 10 22  4
 672        ;;       * - * - * - * -         59 51 43 35 17 19 21  3
 673        ;;       - # - # - # - #         58 50 42 34 16 18 20  2
 674        ;;       * - * - * - * -         57 49 41 33 15  7 29  1
 675        ;;       - # - # - # - #         56 48 40 32 14  6 28  0
 676        ;;
 677        ;;       * * * * * * * *         60 52 44 36 28 20 12  4
 678        ;;       - - - - - - - -         62 54 46 38 30 22 14  6
 679        ;;       - - - - - - - -         61 53 45 37 29 21 13  5
 680        ;;       # # # # # # # #         63 55 47 39 31 23 15  7
 681        ;;       * * * * * * * *         56 48 40 32 24 16  8  0
 682        ;;       - - - - - - - -         58 50 42 34 26 18 10  2
 683        ;;       - - - - - - - -         57 49 41 33 25 17  9  1
 684        ;;       # # # # # # # #         59 51 43 35 27 19 11  3
 685        ;;
 686        ;;       * * * * * * * *         57 49 41 33 25 17  9  1
 687        ;;       * * * * * * * *         59 51 43 35 27 19 11  3
 688        ;;       - - - - - - - -         61 53 45 37 29 21 13  5
 689        ;;       - - - - - - - -         63 55 47 39 31 23 15  7
 690        ;;       - - - - - - - -         56 48 40 32 24 16  8  0
 691        ;;       - - - - - - - -         58 50 42 34 26 18 10  2
 692        ;;       # # # # # # # #         60 52 44 36 28 20 12  4
 693        ;;       # # # # # # # #         62 54 46 38 30 22 14  6
 694        (trad-network
 695         (make-permutation-network
 696          64                             ;  5  4  3  2  1  0
 697          '((:exchange-invert 2 5)       ; ~2  4  3 ~5  1  0
 698            (:exchange-invert 1 4)       ; ~2 ~1  3 ~5 ~4  0
 699            (:exchange-invert 0 3)       ; ~2 ~1 ~0 ~5 ~4 ~3
 700            (:exchange-invert 3 4)       ; ~2  0  1 ~5 ~4 ~3
 701            (:exchange-invert 4 5))))    ; ~0  2  1 ~5 ~4 ~3
 702
 703        ;; The new twizzle-optimized network.  (Exchange each `*' with the
 704        ;; earliest available `#'.)
 705        ;;
 706        ;;       - - - - - - - -          0  1  2  3  4  5  6  7
 707        ;;       - - - - - - - -          8  9 10 11 12 13 14 15
 708        ;;       - - - - - - - -         16 17 18 19 20 21 22 23
 709        ;;       - - - - - - - -         24 25 26 27 28 29 30 31
 710        ;;       - - - - - - - -         32 33 34 35 36 37 38 39
 711        ;;       - - - - - - - -         40 41 42 43 44 45 46 47
 712        ;;       - - - - - - - -         48 49 50 51 52 53 54 55
 713        ;;       - - - - - - - -         56 57 58 59 60 61 62 63
 714        ;;
 715        ;;       * * * * - - - -         36 37 38 39  4  5  6  7
 716        ;;       * * * * - - - -         44 45 46 47 12 13 14 15
 717        ;;       * * * * - - - -         52 53 54 55 20 21 22 23
 718        ;;       * * * * - - - -         60 61 62 63 28 29 30 31
 719        ;;       - - - - # # # #         32 33 34 35  0  1  2  3
 720        ;;       - - - - # # # #         40 41 42 43  8  9 10 11
 721        ;;       - - - - # # # #         48 49 50 51 16 17 18 19
 722        ;;       - - - - # # # #         56 57 58 59 24 25 26 27
 723        ;;
 724        ;;       * * * * * * * *         48 49 50 51 16 17 18 19
 725        ;;       * * * * * * * *         56 57 58 59 24 25 26 27
 726        ;;       - - - - - - - -         52 53 54 55 20 21 22 23
 727        ;;       - - - - - - - -         60 61 62 63 28 29 30 31
 728        ;;       - - - - - - - -         32 33 34 35  0  1  2  3
 729        ;;       - - - - - - - -         40 41 42 43  8  9 10 11
 730        ;;       # # # # # # # #         36 37 38 39  4  5  6  7
 731        ;;       # # # # # # # #         44 45 46 47 12 13 14 15
 732        ;;
 733        ;;       - - * * - - * *         48 49 32 33 16 17  0  1
 734        ;;       - - * * - - * *         56 57 40 41 24 25  8  9
 735        ;;       - - * * - - * *         52 53 36 37 20 21  4  5
 736        ;;       - - * * - - * *         60 61 44 45 28 29 12 13
 737        ;;       # # - - # # - -         50 51 34 35 18 19  2  3
 738        ;;       # # - - # # - -         58 59 42 43 26 27 10 11
 739        ;;       # # - - # # - -         54 55 38 39 22 23  6  7
 740        ;;       # # - - # # - -         62 63 46 47 30 31 14 15
 741        ;;
 742        ;;       - - - - - - - -         48 49 32 33 16 17  0  1
 743        ;;       * * * * * * * *         50 51 34 35 18 19  2  3
 744        ;;       - - - - - - - -         52 53 36 37 20 21  4  5
 745        ;;       * * * * * * * *         54 55 38 39 22 23  6  7
 746        ;;       # # # # # # # #         56 57 40 41 24 25  8  9
 747        ;;       - - - - - - - -         58 59 42 43 26 27 10 11
 748        ;;       # # # # # # # #         60 61 44 45 28 29 12 13
 749        ;;       - - - - - - - -         62 63 46 47 30 31 14 15
 750        ;;
 751        ;;       * - * - * - * -         57 49 41 33 25 17  9  1
 752        ;;       * - * - * - * -         59 51 43 35 27 19 11  3
 753        ;;       * - * - * - * -         61 53 45 37 29 21 13  5
 754        ;;       * - * - * - * -         63 55 47 39 31 23 15  7
 755        ;;       - # - # - # - #         56 48 40 32 24 16  8  0
 756        ;;       - # - # - # - #         58 50 42 34 26 18 10  2
 757        ;;       - # - # - # - #         60 52 44 36 28 20 12  4
 758        ;;       - # - # - # - #         62 54 46 38 30 22 14  6
 759        (new-network
 760         (make-permutation-network
 761          64                             ;  5  4  3  2  1  0
 762          '((:exchange-invert 2 5)       ; ~2  4  3 ~5  1  0
 763            (:exchange-invert 4 5)       ; ~4  2  3 ~5  1  0
 764            (:exchange        1 5)       ;  1  2  3 ~5 ~4  0
 765            (:exchange        3 5)       ;  3  2  1 ~5 ~4  0
 766            (:exchange-invert 0 5)))))   ; ~0  2  1 ~5 ~4 ~3
 767
 768   (fresh-line)
 769
 770   (let ((benes-network (benes-search fixed-ip)))
 771     (print-permutation-network benes-network)
 772     (demonstrate-permutation-network 64 benes-network fixed-ip))
 773   (terpri)
 774   (print-permutation-network trad-network)
 775   (demonstrate-permutation-network 64 trad-network fixed-ip)
 776   (terpri)
 777   (print-permutation-network new-network)
 778   (demonstrate-permutation-network 64 new-network fixed-ip))
 779
 780 #+example
 781 (benes-search-des #( 0  0  0  0
 782                     57 49 41 33 25 17  9  1
 783                     58 50 42 34 26 18 10  2
 784                     59 51 43 35 27 19 11  3
 785                     60 52 44 36
 786                      0  0  0  0
 787                     63 55 47 39 31 23 15  7
 788                     62 54 46 38 30 22 14  6
 789                     61 53 45 37 29 21 13  5
 790                                 28 20 12  4))
 791
 792 #+example
 793 (let ((pc2 (make-array '(8 6)
 794                        :element-type 'fixnum
 795                        :initial-contents '((14 17 11 24  1  5)
 796                                            ( 3 28 15  6 21 10)
 797                                            (23 19 12  4 26  8)
 798                                            (16  7 27 20 13  2)
 799                                            (41 52 31 37 47 55)
 800                                            (30 40 51 45 33 48)
 801                                            (44 49 39 56 34 53)
 802                                            (46 42 50 36 29 32)))))
 803   (benes-search-des
 804    (make-array 64
 805                :element-type 'fixnum
 806                :initial-contents
 807                  (loop for i in '(2 4 6 8 1 3 5 7)
 808                        nconc (list 0 0)
 809                        nconc (loop for j below 6
 810                                    for x = (aref pc2 (1- i) j)
 811                                    collect (if (<= x 32) (+ x 4) (+ x 8)))))
 812    1000))