Project:
 ```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 ``` ```; fountain codes (define (take n xs) (let loop ((n n) (xs xs) (ys '())) (if (or (zero? n) (null? xs)) (reverse ys) (loop (- n 1) (cdr xs) (cons (car xs) ys))))) (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 (logxor a b) (cond ((zero? a) b) ((zero? b) a) (else (+ (* (logxor (floor (/ a 2)) (floor (/ b 2))) 2) (if (even? a) (if (even? b) 0 1) (if (even? b) 1 0)))))) (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 (shuffle x) (do ((v (list->vector x)) (n (length x) (- n 1))) ((zero? n) (vector->list v)) (let* ((r (randint n)) (t (vector-ref v r))) (vector-set! v r (vector-ref v (- n 1))) (vector-set! v (- n 1) t)))) (define (degree-distribution n) (let* ((len (* n (+ n 1) 1/2)) (k (randint len))) (let loop ((i 0) (s 0) (t 1)) (if (< k s) (- n i -1) (loop (+ i 1) (+ s t) (+ t 1)))))) (define (make-fountain str) (let* ((cv (list->vector (map char->integer (string->list str)))) (len (vector-length cv))) (lambda () (let* ((d (degree-distribution len)) (blocks (take d (shuffle (range len))))) (let loop ((bs blocks) (x 0)) (if (null? bs) (cons x blocks) (loop (cdr bs) (logxor x (vector-ref cv (car bs)))))))))) (define fountain (make-fountain "Programming Praxis")) (define (decode fountain len) (let* ((cv (make-vector len #f)) (n len)) (define (store packet) (cond ((vector-ref cv (cadr packet)) #f) (else (vector-set! cv (cadr packet) (car packet)) (set! n (- n 1)) #t))) (define (reduce packet) (let loop ((x (car packet)) (bs (cdr packet)) (zs (list))) (cond ((null? bs) (cons x zs)) ((vector-ref cv (car bs)) (loop (logxor x (vector-ref cv (car bs))) (cdr bs) zs)) (else (loop x (cdr bs) (cons (car bs) zs)))))) (define (ripple hold) (let ((done? #t)) (let loop ((hold hold) (out-hold (list))) (if (null? hold) (if done? out-hold (ripple out-hold)) (let ((p (reduce (car hold)))) (cond ((equal? p (list 0)) (loop (cdr hold) out-hold)) ((null? (cddr p)) (if (store p) (set! done? #f)) (loop (cdr hold) out-hold)) ((equal? (cdar hold) (reverse (cdr p))) (loop (cdr hold) (cons p out-hold))) (else (set! done? #f) (loop (cdr hold) (cons p out-hold))))))))) (let loop ((hold (list))) (if (zero? n) (list->string (map integer->char (vector->list cv))) (let ((p (fountain))) (if (null? (cddr p)) (if (store p) (loop (ripple hold)) (loop hold)) (loop (cons p hold)))))))) (display (decode fountain 18)) ```
 ```1 ``` `Programming Praxis`