; http://cap-lore.com/MathPhys/Field/finite ; This program relies on case sensitive symbols. (let* ((Dog (fileVal "Do")) (Do (Dog 'Do)) (DoV (Dog 'DoV)) (vr vector-ref)(mv make-vector)(vs! vector-set!)(vl vector-length)) (lambda (p) (ylppa ((fileVal "GFp") p) (lambda (m+ m- m* m/) (let ((p+ (lambda (a b) (let* ((la (vl a))(lb (vl b))(pl (lambda (la a lb b) (DoV lb (lambda (j) (if (< j la) (m+ (vr a j) (vr b j)) (vr b j))))))) (if (< la lb) (pl la a lb b) (pl lb b la a))))) (p- (lambda (a) (DoV (vl a) (lambda (j) (m- (vr a j)))))) (trim (lambda (a) (let m ((n (vl a))) (if (zero? n) '#() (if (zero? (vr a (- n 1))) (if (= 1 n) '#() (m (- n 1))) (DoV n (lambda (j) (vr a j))))))))) (let ((pqr (lambda (N d) (let* ((n (trim N)) (ln (vl n)) (ldm (- (vl d) 1))) (if (< ln ldm) (cons '#() n) (let ((ht (vr d ldm))) (if (zero? ht) (ex "divide check") '()) (let* ((htr (m/ ht)) (nd (DoV ldm (lambda (i) (m* htr (vr d i))))) (q (mv (- ln ldm)))) (Do (- ln ldm) (lambda (j) (let ((t (vr n (+ j ldm)))) (vs! q j (m* htr t)) (Do ldm (lambda (i) (vs! n (+ i j) (m+ (vr n (+ i j)) (m- (m* t (vr nd i)))))))))) (cons q (DoV ldm (lambda (j) (vr n j)))))))))) (p* (lambda (a b) (let* ((la (vl a))(lb (vl b))) (if (= (+ la lb) 0) '#() (let ((p (mv (+ la lb -1) 0))) (Do la (lambda (i) (Do lb (lambda (j) (vs! p (+ i j) (m+ (vr p (+ i j)) (m* (vr a i) (vr b j)))))))) p)))))) (let* ((pegcd (lambda (a b) (let pg ((a a)(b (trim b))) (let* ((qr (pqr a b))(q (car qr))(r (trim (cdr qr)))) (if (zero? (vl r)) (cons '#() (vector (m/ (vr b (- (vl b) 1))))) (let ((c (pg b r))) (cons (cdr c) (p+ (car c) (p- (p* (cdr c) q)))))))))) (pgcmd (lambda (a b) (let* ((A (trim a))(B (trim b))(la (vl A))(lb (vl B))) (letrec ((d (lambda (l s) (if (zero? (vl s)) l (d s (trim (cdr (pqr l s)))))))) (let* ((a (if (< la lb) (d B A) (d A B))) (l (vl a))) (let ((f (vr a (- l 1)))) (if (> f 1) (let ((r (m/ f))) (Do l (lambda (j) (vs! a j (m* r (vr a j))))))) a)))))) (mexpt (lambda (u p f) ; compute u^p mod f (let ((l (vl f))) (let pl ((u u)(p p)) (if (zero? p) (let ((a (mv (- l 1) 0))) (vs! a 0 1) a) (if (even? p) (pl (cdr (pqr (p* u u) f)) (/ p 2)) (if (= p 1) u (cdr (pqr (p* u (pl u (- p 1))) f))))))))) (tip (lambda (f) ; f is vector polynomial, list of coefficients, constant first. ;Testing a Polynomial for Irreducibility ; From Algorithm 4.69 of HB. of App. Cryptog. (let tr ((u '#(0 1)) (m (vl f))) (or (< m 3) (let* ((up (mexpt u p f)) (d (pgcmd f (p+ up (vector 0 (- p 1)))))) (and (= 1 (vl d)) (tr up (- m 2)))))))) (p->i (lambda (P) (let ((w (vl P))) (let m ((n 0)) (if (= w n) 0 (+ (vr P n) (* p (m (+ n 1))))))))) (i->p (lambda (n) (let r ((k n)(s 0)) (if (zero? k) (mv s) (let ((x (r (quotient k p)(+ s 1)))) (vs! x s (remainder k p)) x))))) (gap (lambda (m) (let ((N (let P ((z m)) (if (zero? z) 1 (* p (P (- z 1))))))) (lambda () (let ((n 0)) (lambda () (and (< n N) (let ((x (i->p n))) (set! n (+ n 1)) x)))))))) (gip (lambda (m) (let ((g ((gap m)))(m (i->p (expt p m)))) (let r ((l '())) (let ((x (g))) (if x (let ((tp (p+ m x))) (if (and (positive? (vr tp 0))(tip tp)) (r (cons tp l)) (r l))) l)))))) (gfip (lambda (m) (let ((g ((gap m)))(m (i->p (expt p m)))) (let r () (let ((x (g))) (if x (let ((tp (p+ m x))) (if (and (> (vr tp 0) 0)(tip tp)) tp (r))))))))) (gsip (lambda (m) (let* ((pq (expt p m))(m20 (* m 20)) (tp (lambda (k) (let ((x (i->p (+ pq k))))(and (tip x) x))))) (or (let seek ((n 1)) (and (< n m20) (or (tp n) (seek (+ n 1))))) (let seek ((n 1)) (or (tp (+ p n)) (seek (+ n 1)))))))) (fops (lambda (f) (lambda (sy) (let ((aw (assq sy (list (cons 'f* (lambda (a b) (cdr (pqr (p* a b) f)))) (cons 'f/ (lambda (a) (trim (cdr (pegcd f a))))) (cons 'fexpt (lambda (a p)(mexpt a p f))))))) (if aw (cdr aw) (begin (write (list 'Nonesuch sy)) (newline)))))))) (let ((veq (lambda (a b)(let ((la (vl a))(lb (vl b)) (rc (lambda (la a lb b) (and (let w ((c la))(let ((C (- c 1))) (or (= c 0) (and (= (vr a C)(vr b C)) (w C))))) (let w ((c (- lb la))(d la)) (or (= c 0) (and (zero? (vr b d))(w (- c 1)(+ d 1))))))))) (if (< la lb) (rc la a lb b) (rc lb b la a)))))) (let ((pl (map cons '(pqr p->i i->p gap gip gfip gsip veq m+ m- m* m/ p+ p- p* mexpt trim pgcmd tip pegcd fops p) (list pqr p->i i->p gap gip gfip gsip veq m+ m- m* m/ p+ p- p* mexpt trim pgcmd tip pegcd fops p)))) (lambda (sy) (let ((a (assq sy pl))) (if a (cdr a) (begin (write (list 'Nonesuch2 sy)) (newline)))))))))))))) ; Demo: => (() ()) (let ((Do ((fileVal "Do") 'Do))(gg (((fileVal "RC4") "SedStuff") 'rbi))) (let ((r40 (gg 40))(S (fileVal "finiteField"))) (map (lambda (b) (let* ((T (S b))(fops (T 'fops))(gsip (T 'gsip)) (i->p (T 'i->p))) (Do 15 (lambda (n) (let* ((pw (+ 2 (r40))) (rpw (gg (- (expt b pw) 1))) (U (fops (gsip pw))) (/ (U 'f/)) (* (U 'f*)) (p->i (T 'p->i))) (Do 20 (lambda (j) (let* ((k (+ (rpw) 1))(x (i->p k))(i (/ x))(p (* i x))) (if (= (p->i p) 1) 'good (write (list 'bad k x p))))))))))) (list 2 3)))) (let* ((n 19) (m 58) (T ((fileVal "finiteField") n)) (rb ((((fileVal "RC4") "Sead Stuff") 'rbi) n))) ((((T 'fops) ((T 'gsip) m)) 'fexpt) (((fileVal "Do") 'DoV) m (λ (_) (rb))) (- (expt n m) 1))) ; => #58(1 0)