```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 ``` ```; dawkins weasel ; http://en.wikipedia.org/wiki/Weasel_program (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 target (string->list "METHINKS IT IS LIKE A WEASEL")) (define (rand-letter) (let ((r (randint 27))) (if (zero? r) #\space (integer->char (+ r 64))))) (define (mutate xs) (map (lambda (c) (if (zero? (randint 20)) (rand-letter) c)) xs)) (define (score xs) (apply + (map (lambda (a b) (if (char=? a b) 1 0)) xs target))) (define (get-best xs) (let loop ((k 100) (best (score xs)) (mutation xs)) (let* ((m (mutate xs)) (s (score m))) (if (zero? k) (values best mutation) (if (< best s) (loop (- k 1) s m) (loop (- k 1) best mutation)))))) (define (weasel) (let loop ((i 0) (hi 0) (xs (map (lambda (x) (rand-letter)) (range 28)))) (display i) (display " ") (display hi) (display " ") (display (list->string xs)) (newline) (when (< hi 28) (call-with-values (lambda () (get-best xs)) (lambda (best mutation) (if (< hi best) (loop (+ i 1) best mutation) (loop (+ i 1) hi xs))))))) (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 ``` ```0 0 FOFVZJ MRFSAMLS J DFIIKBU NI 1 1 FEFVZJ DRFSAMLS J DFIIKBU NI 2 2 FEFVZJ DRISAMLS J DFIIKBU NI 3 3 FEFVZJ DRISAMLS J DFI KBU NI 4 4 FEFVZJ DRISAMLS JKDFI KBU NI 5 5 FEFVZJ DRISAMLS JKDFI KBA NI 6 6 FEFVZJ DRISAILS JKDFI KBA NI 7 7 MEFVZJ DAISAILS JKDFI KBA NI 8 8 MEFVZJ DAISAILS JKDFA KBA NI 9 9 MEFVZJ SAISAILSXJKDFA KBA NI 10 10 MEFVZJ SAISAILSXJKEFA KBA NI 11 11 MEFVZJ SAISAIM XJKEFA KBA NI 12 12 MEFVZJ SAITAIM XJKEFA KBA NI 13 12 MEFVZJ SAITAIM XJKEFA KBA NI 14 13 MEFVZJ SAITAIM XJKEFA KBA NL 15 14 MEFVZJ SAITAIM XJKEFA UBA EL 16 15 MEFVZJ SAIT IM XJKEFA UBA EL 17 15 MEFVZJ SAIT IM XJKEFA UBA EL 18 16 MEFVZJKSAIT IM XJKEFA UBA EL 19 17 MEFVZJKS IT IM XJKEFA XBA EL 20 17 MEFVZJKS IT IM XJKEFA XBA EL 21 18 MEFVZJKS IT IM XJKEFA WBA EL 22 19 METVZJKS IT IM K KEKA WBAEEL 23 19 METVZJKS IT IM K KEKA WBAEEL 24 20 METVZJKS IT IM KIKEKA WBAEEL 25 20 METVZJKS IT IM KIKEKA WBAEEL 26 21 METVZJKS IT IM KIKEKA WBASEL 27 22 METHZJKS IT IM KIKEKA WBASEL 28 23 METHZJKS IT IS KIKEKA WBASEL 29 23 METHZJKS IT IS KIKEKA WBASEL 30 23 METHZJKS IT IS KIKEKA WBASEL 31 24 METHIJKS IT IS KIKEKA WBASEL 32 24 METHIJKS IT IS KIKEKA WBASEL 33 24 METHIJKS IT IS KIKEKA WBASEL 34 24 METHIJKS IT IS KIKEKA WBASEL 35 24 METHIJKS IT IS KIKEKA WBASEL 36 25 METHIJKS IT IS KIKE A WBASEL 37 26 METHIJKS IT IS KIKE A WEASEL 38 26 METHIJKS IT IS KIKE A WEASEL 39 26 METHIJKS IT IS KIKE A WEASEL 40 26 METHIJKS IT IS KIKE A WEASEL 41 26 METHIJKS IT IS KIKE A WEASEL 42 26 METHIJKS IT IS KIKE A WEASEL 43 26 METHIJKS IT IS KIKE A WEASEL 44 26 METHIJKS IT IS KIKE A WEASEL 45 26 METHIJKS IT IS KIKE A WEASEL 46 26 METHIJKS IT IS KIKE A WEASEL 47 26 METHIJKS IT IS KIKE A WEASEL 48 26 METHIJKS IT IS KIKE A WEASEL 49 26 METHIJKS IT IS KIKE A WEASEL 50 26 METHIJKS IT IS KIKE A WEASEL 51 26 METHIJKS IT IS KIKE A WEASEL 52 27 METHIJKS IT IS LIKE A WEASEL 53 27 METHIJKS IT IS LIKE A WEASEL 54 27 METHIJKS IT IS LIKE A WEASEL 55 27 METHIJKS IT IS LIKE A WEASEL 56 27 METHIJKS IT IS LIKE A WEASEL 57 28 METHINKS IT IS LIKE A WEASEL ```