# lisp-random

 ``` 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142``` ```;;;; Kasadkad's avoiding stuff ;;;; Copyright (c) 2012 Robert Smith ;;; UTILITY FUNCTIONS (declaim (inline xor list-to-vector range iota)) (defun xor (a b) "Exclusive or on A and B." (and (or a b) (not (and a b)))) (defun list-to-vector (list) "Convert LIST into a vector." (declare (type list list)) (make-array (length list) :initial-contents list)) (defun range (start end &optional (step 1)) "Return the list of numbers n such that START <= n < END and n = START + k*STEP." (declare (type fixnum start end step)) (assert (<= start end)) (loop :for i :from start :below end :by step :collecting i)) (defun iota (n) "Return [0, ..., N-1]." (declare (type fixnum n)) (assert (not (minusp n))) (range 0 n)) ;;; PERMUTATIONS (defun order-isomorphic-p (a b) "Are A and B order-isomorphic?" (declare (type vector a b)) (let ((n (length a))) (declare (type fixnum n)) (when (= n (length b)) (loop :for i :below n :always (loop :for j :from i :below n :always (not (xor (<= (elt a i) (elt a j)) (<= (elt b i) (elt b j))))))))) (defun consecutive-subsequences (x n) "Get all of the subsequences of X of length N." (declare (type fixnum n) (type vector x)) (let ((lenx (length x))) (declare (type fixnum lenx)) (cond ((or (> n lenx) (not (plusp n))) nil) ((= n lenx) (list x)) (t (let ((total (1+ (- lenx n)))) (loop :for i :below total :collect (subseq x i (+ i n)))))))) (defun subsequences (x m) (let ((combs nil)) (labels ((comb1 (l c m) (when (>= (length l) m) (if (zerop m) (return-from comb1 (push (coerce (reverse c) 'vector) combs))) (comb1 (cdr l) c m) (comb1 (cdr l) (cons (first l) c) (1- m))))) (comb1 (coerce x 'list) nil m) combs))) (defun permutation-matches-p (perm pattern) "Does the permutation PERM have a subsequence which matches the pattern PATTERN?" (declare (type vector perm pattern)) (loop :for s :in (subsequences perm (length pattern)) :thereis (order-isomorphic-p pattern s))) (defun permutation-avoids-p (perm pattern) "Does the permutation PERM avoid the pattern PATTERN?" (declare (type vector perm pattern)) (not (permutation-matches-p perm pattern))) ;;; This conses an awful lot. (defun permutations (n) "Generate the elements of the permutation group S_N." (declare (type integer n)) (labels ((perms (l) (declare (type list l)) (if (null l) (list nil) (mapcan #'(lambda (x) (mapcar #'(lambda (y) (cons x y)) (perms (remove x l :count 1)))) l)))) (mapcar #'list-to-vector (perms (iota n))))) (defun avoided-patterns (permutation pattern-size) "Compute a list of all of the patterns of size PATTERN-SIZE that are avoided by the permutation PERMUTATION." (declare (type (unsigned-byte 16) pattern-size)) (let ((perms (permutations pattern-size))) (delete-if (lambda (pattern) (permutation-matches-p permutation pattern)) perms))) ;;; requires steinhaus-johnson-trotter . L I S P (defun scan-avoided-patterns (f permutation pattern-size) (doperms (pattern pattern-size) (unless (permutation-matches-p permutation pattern) (funcall f pattern)))) (defun count-avoid (perm patlen) (let ((c 0)) (scan-avoided-patterns (lambda (p) (incf c)) perm patlen) c)) (defun count-avoid-all (n k) "count all of the patterns that everything in S_n avoids where the patterns are in P_k" (let ((total 0)) (doperms (perm n total) (incf total (count-avoid perm k))))) (defun show-counts (max-n) (loop :for n :from 1 :to max-n :do (loop :for k :from 1 :to n :do (format t "n=~A k=~A: ~A~%" n k (count-avoid-all n k))))) ```