```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 ``` ```; dawkins weasel (define (range . args) (case (length args) ((1) (range 0 (car args) (if (negative? (car args)) -1 1))) ((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1))) ((3) (let ((le? (if (negative? (caddr args)) >= <=))) (let loop ((x(car args)) (xs '())) (if (le? (cadr args) x) (reverse xs) (loop (+ x (caddr args)) (cons x xs)))))) (else (error 'range "unrecognized arguments")))) (define rand #f) (define randint #f) (let ((two31 #x80000000) (a (make-vector 56 -1)) (fptr #f)) (define (mod-diff x y) (modulo (- x y) two31)) ; generic version ; (define (mod-diff x y) (logand (- x y) #x7FFFFFFF)) ; fast version (define (flip-cycle) (do ((ii 1 (+ ii 1)) (jj 32 (+ jj 1))) ((< 55 jj)) (vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj)))) (do ((ii 25 (+ ii 1)) (jj 1 (+ jj 1))) ((< 55 ii)) (vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj)))) (set! fptr 54) (vector-ref a 55)) (define (init-rand seed) (let* ((seed (mod-diff seed 0)) (prev seed) (next 1)) (vector-set! a 55 prev) (do ((i 21 (modulo (+ i 21) 55))) ((zero? i)) (vector-set! a i next) (set! next (mod-diff prev next)) (set! seed (+ (quotient seed 2) (if (odd? seed) #x40000000 0))) (set! next (mod-diff next seed)) (set! prev (vector-ref a i))) (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle))) (define (next-rand) (if (negative? (vector-ref a fptr)) (flip-cycle) (let ((next (vector-ref a fptr))) (set! fptr (- fptr 1)) next))) (define (unif-rand m) (let ((t (- two31 (modulo two31 m)))) (let loop ((r (next-rand))) (if (<= t r) (loop (next-rand)) (modulo r m))))) (init-rand 19380110) ; happy birthday donald e knuth (set! rand (lambda seed (cond ((null? seed) (/ (next-rand) two31)) ((eq? (car seed) 'get) (cons fptr (vector->list a))) ((eq? (car seed) 'set) (set! fptr (caadr seed)) (set! a (list->vector (cdadr seed)))) (else (/ (init-rand (modulo (numerator (inexact->exact (car seed))) two31)) two31))))) (set! randint (lambda args (cond ((null? (cdr args)) (if (< (car args) two31) (unif-rand (car args)) (floor (* (next-rand) (car args))))) ((< (car args) (cadr args)) (let ((span (- (cadr args) (car args)))) (+ (car args) (if (< span two31) (unif-rand span) (floor (* (next-rand) span)))))) (else (let ((span (- (car args) (cadr args)))) (- (car args) (if (< span two31) (unif-rand span) (floor (* (next-rand) span)))))))))) (define (rept n . cs) (make-string n (if (pair? cs) (car cs) #\space))) (define (align str wid aline) (let ((len (string-length str))) (cond ((< wid len) (rept wid #\#)) ((eq? aline'left) (string-append str (rept (- wid len)))) ((eq? aline 'center) (let* ((left (quotient (- wid len) 2)) (right (- wid len left))) (string-append (rept left) str (rept right)))) ((eq? aline 'right) (string-append (rept (- wid len)) str)) (else (error 'align "invalid alignment specifier"))))) (define (rand-letter) (let ((r (randint 27))) (if (zero? r) #\space (integer->char (+ r 64))))) (define (mutate guess) (map (lambda (g) (if (zero? (randint 20)) (rand-letter) g)) guess)) (define (score guess target) (apply + (map (lambda (g t) (if (char=? g t) 1 0)) guess target))) (define (get-best guess target) (let loop ((k 100) (best 0) (mutation guess)) (if (zero? k) (values best mutation) (let* ((m (mutate guess)) (s (score m target))) (if (< best s) (loop (- k 1) s m) (loop (- k 1) best mutation)))))) (define (display-weasel guess target) (for-each (lambda (t g) (if (char=? t g) (display g) (if (char=? #\space g) (display #\_) (display (char-downcase g))))) target guess)) (define (dawkins target) (let* ((target (string->list (string-upcase target))) (len (length target)) (guess (map (lambda (x) (rand-letter)) (range len))) (current (score guess target))) (let loop ((i 0) (current current) (guess guess)) (display (align (number->string i) 4 'left)) (display (align (number->string current) 4 'left)) (display-weasel guess target) (newline) (when (< current len) (call-with-values (lambda () (get-best guess target)) (lambda (best mutation) (loop (+ i 1) best mutation))))))) (dawkins "METHINKS IT IS LIKE A WEASEL") ```
 ```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 ``` ```0 0 fofvzj_mrfsamls_j_dfiikbu_ni 1 1 fEfvzj_drfsamls_j_dfiikbu_ni 2 2 fEfvzj_drIsamls_j_dfiikbu_ni 3 2 fEfvzj_drIsamls_jndfiikbu_ni 4 3 fEfvzj_drIsamls_jndfi kbu_ni 5 4 fEfvzj_drIsamls_jndfi kbA_ni 6 5 fEfvzj_drIsaIls_jndfi kbA_ni 7 6 MEfvzj_daIsaIls_jndfi kbA_ni 8 7 MEfvzj_daIsaIls_jndfA kbA_ni 9 8 MEfvzj_daIsaIls_jndfA kEA_ni 10 9 MEfvzj_daIsaIls_jnEfA kEA_ni 11 9 MEfvzj_daIsaIls_jgEfA kEA_ni 12 10 MEfvzj_daIsaIm _jgEfA kEA_ni 13 10 MEfvzj_daIsaIm _jgEfA kEA_dm 14 12 MEfvzN_vaITaIm _jgEfA kEA_dm 15 13 MEfvzN_vaITaIm _jgEfA uEA_Em 16 14 MEfvzN_vaIT Im _jgEfA uEA_Em 17 15 MEfvIN_vaIT Im _jvEfA uEA_Ea 18 16 MEfvINKvaIT Im _jvEfA uEA_Ea 19 17 MEfvINKv IT Im _jvEfA xEA_Ea 20 17 MEfvINKv IT Im _jvEfA xEA_Ea 21 18 MEfvINKv IT Im _jvEfA WEA_Ea 22 19 METvINKv IT Im k_vEkA WEAeEa 23 19 METvINKv IT Im k_vEkA WEAoEa 24 20 METvINKv IT Im kIvEkA WEAoEa 25 20 METvINKv IT Im kIvEkA WEAoEa 26 21 METvINKv IT Im kIvEkA WEASEa 27 22 METvINKS IT Im kIvEkA WEASEa 28 23 METvINKS IT IS kIvEkA WEASEa 29 23 METxINKS IT IS kIvEkA WEASEa 30 23 METxINKS IT IS kIvEkA WEASEa 31 24 METxINKS IT IS kIKEkA WEASEa 32 24 METxINKS IT IS kIKEkA WEASEa 33 24 METxINKS IT IS kIKEkA WEASEa 34 24 METxINKS IT IS kIKEkA WEASEa 35 24 METxINKS IT IS kIKEkA WEASEa 36 24 METxINKS IT IS kIKEkA WEASEa 37 25 METxINKS IT IS kIKE A WEASEa 38 25 METxINKS IT IS kIKE A WEASEa 39 25 METxINKS IT IS kIKE A WEASEa 40 25 METxINKS IT IS kIKE A WEASEa 41 25 METxINKS IT IS kIKE A WEASEa 42 25 METxINKS IT IS kIKE A WEASEa 43 25 METxINKS IT IS kIKE A WEASEa 44 25 METxINKS IT IS kIKE A WEASEa 45 25 METxINKS IT IS kIKE A WEASEa 46 25 METxINKS IT IS kIKE A WEASEa 47 25 METxINKS IT IS kIKE A WEASEa 48 25 METxINKS IT IS kIKE A WEASEa 49 25 METxINKS IT IS kIKE A WEASEa 50 26 METxINKS IT IS kIKE A WEASEL 51 26 METxINKS IT IS kIKE A WEASEL 52 26 METxINKS IT IS kIKE A WEASEL 53 27 METxINKS IT IS LIKE A WEASEL 54 27 METxINKS IT IS LIKE A WEASEL 55 27 METxINKS IT IS LIKE A WEASEL 56 27 METxINKS IT IS LIKE A WEASEL 57 27 METxINKS IT IS LIKE A WEASEL 58 27 METxINKS IT IS LIKE A WEASEL 59 27 METxINKS IT IS LIKE A WEASEL 60 27 METxINKS IT IS LIKE A WEASEL 61 27 METxINKS IT IS LIKE A WEASEL 62 27 METxINKS IT IS LIKE A WEASEL 63 27 METxINKS IT IS LIKE A WEASEL 64 27 METxINKS IT IS LIKE A WEASEL 65 27 METxINKS IT IS LIKE A WEASEL 66 27 METxINKS IT IS LIKE A WEASEL 67 27 METxINKS IT IS LIKE A WEASEL 68 27 METxINKS IT IS LIKE A WEASEL 69 27 METxINKS IT IS LIKE A WEASEL 70 27 METxINKS IT IS LIKE A WEASEL 71 27 METxINKS IT IS LIKE A WEASEL 72 27 METxINKS IT IS LIKE A WEASEL 73 27 METxINKS IT IS LIKE A WEASEL 74 27 METxINKS IT IS LIKE A WEASEL 75 27 METxINKS IT IS LIKE A WEASEL 76 27 METxINKS IT IS LIKE A WEASEL 77 27 METxINKS IT IS LIKE A WEASEL 78 27 METxINKS IT IS LIKE A WEASEL 79 27 METxINKS IT IS LIKE A WEASEL 80 27 METxINKS IT IS LIKE A WEASEL 81 27 METxINKS IT IS LIKE A WEASEL 82 27 METxINKS IT IS LIKE A WEASEL 83 27 METxINKS IT IS LIKE A WEASEL 84 27 METkINKS IT IS LIKE A WEASEL 85 27 METsINKS IT IS LIKE A WEASEL 86 27 METsINKS IT IS LIKE A WEASEL 87 27 METsINKS IT IS LIKE A WEASEL 88 27 METsINKS IT IS LIKE A WEASEL 89 27 METsINKS IT IS LIKE A WEASEL 90 27 METsINKS IT IS LIKE A WEASEL 91 27 METsINKS IT IS LIKE A WEASEL 92 27 METsINKS IT IS LIKE A WEASEL 93 28 METHINKS IT IS LIKE A WEASEL ```