Sync

Task/Vigen-re-cipher-Cryptanalysis/Racket/vigen-re-cipher-cryptanalysis-1.rkt

@@ -0,0 +1,71 @@
+#lang at-exp racket
+
+(define max-keylen 30)
+
+(define text
+  @~a{MOMUD EKAPV TQEFM OEVHP AJMII CDCTI FGYAG JSPXY ALUYM NSMYH
+      VUXJE LEPXJ FXGCM JHKDZ RYICU HYPUS PGIGM OIYHF WHTCQ KMLRD
+      ITLXZ LJFVQ GHOLW CUHLO MDSOE KTALU VYLNZ RFGBX PHVGA LWQIS
+      FGRPH JOOFW GUBYI LAPLA LCAFA AMKLG CETDW VOELJ IKGJB XPHVG
+      ALWQC SNWBU BYHCU HKOCE XJEYK BQKVY KIIEH GRLGH XEOLW AWFOJ
+      ILOVV RHPKD WIHKN ATUHN VRYAQ DIVHX FHRZV QWMWV LGSHN NLVZS
+      JLAKI FHXUF XJLXM TBLQV RXXHR FZXGV LRAJI EXPRV OSMNP KEPDT
+      LPRWM JAZPK LQUZA ALGZX GVLKL GJTUI ITDSU REZXJ ERXZS HMPST
+      MTEOE PAPJH SMFNB YVQUZ AALGA YDNMP AQOWT UHDBV TSMUE UIMVH
+      QGVRW AEFSP EMPVE PKXZY WLKJA GWALT VYYOB YIXOK IHPDS EVLEV
+      RVSGB JOGYW FHKBL GLXYA MVKIS KIEHY IMAPX UOISK PVAGN MZHPW
+      TTZPV XFCCD TUHJH WLAPF YULTB UXJLN SIJVV YOVDJ SOLXG TGRVO
+      SFRII CTMKO JFCQF KTINQ BWVHG TENLH HOGCS PSFPV GJOKM SIFPR
+      ZPAAS ATPTZ FTPPD PORRF TAXZP KALQA WMIUD BWNCT LEFKO ZQDLX
+      BUXJL ASIMR PNMBF ZCYLV WAPVF QRHZV ZGZEF KBYIO OFXYE VOWGB
+      BXVCB XBAWG LQKCM ICRRX MACUO IKHQU AJEGL OIJHH XPVZW JEWBA
+      FWAML ZZRXJ EKAHV FASMU LVVUT TGK})
+
+(define first-char (char->integer #\A))
+(define chars# (- (char->integer #\Z) first-char -1))
+
+(define freqs ; english letter frequencies from wikipedia
+  ((compose1 list->vector (curry map (curryr / 100000.0)))
+   '(8167 1492 2782 4253 12702 2228 2015 6094 6966 153 772 4025 2406
+     6749 7507 1929 95 5987 6327 9056 2758 978 2360 150 1974 74)))
+
+(define text* (for/vector ([c (regexp-replace* #px"\\s+" text "")])
+                (- (char->integer c) first-char)))
+(define N (vector-length text*))
+
+(define (col-guesses len)
+  (for/list ([ofs len])
+    (define text (for/list ([i (in-range ofs N len)]) (vector-ref text* i)))
+    (define cN (length text))
+    (define cfreqs (make-vector chars# 0))
+    (for ([c (in-list text)])
+      (vector-set! cfreqs c (add1 (vector-ref cfreqs c))))
+    (for ([i chars#]) (vector-set! cfreqs i (/ (vector-ref cfreqs i) cN)))
+    (argmin car
+      (for/list ([d chars#])
+        (cons (for/sum ([i chars#])
+                (expt (- (vector-ref freqs i)
+                         (vector-ref cfreqs (modulo (+ i d) chars#)))
+                      2))
+              d)))))
+
+(define best-key
+  (cdr (argmin car
+         (for/list ([len (range 1 (add1 max-keylen))])
+           (define guesses (col-guesses len))
+           (cons (/ (apply + (map car guesses)) len) (map cdr guesses))))))
+
+(printf "Best key found: ")
+(for ([c best-key]) (display (integer->char (+ c first-char))))
+(newline)
+
+(printf "Decoded text:\n")
+(define decode-num
+  (let ([cur '()])
+    (λ(n) (when (null? cur) (set! cur best-key))
+          (begin0 (modulo (- n (car cur)) chars#) (set! cur (cdr cur))))))
+(for ([c text])
+  (define n (- (char->integer c) first-char))
+  (if (not (< -1 n chars#)) (display c)
+      (display (integer->char (+ first-char (decode-num n))))))
+(newline)

Task/Vigen-re-cipher-Cryptanalysis/Racket/vigen-re-cipher-cryptanalysis-2.rkt

@@ -0,0 +1,105 @@
+#lang at-exp racket
+
+(define max-keylen 30)
+
+(define text
+  @~a{MOMUD EKAPV TQEFM OEVHP AJMII CDCTI FGYAG JSPXY ALUYM NSMYH
+      VUXJE LEPXJ FXGCM JHKDZ RYICU HYPUS PGIGM OIYHF WHTCQ KMLRD
+      ITLXZ LJFVQ GHOLW CUHLO MDSOE KTALU VYLNZ RFGBX PHVGA LWQIS
+      FGRPH JOOFW GUBYI LAPLA LCAFA AMKLG CETDW VOELJ IKGJB XPHVG
+      ALWQC SNWBU BYHCU HKOCE XJEYK BQKVY KIIEH GRLGH XEOLW AWFOJ
+      ILOVV RHPKD WIHKN ATUHN VRYAQ DIVHX FHRZV QWMWV LGSHN NLVZS
+      JLAKI FHXUF XJLXM TBLQV RXXHR FZXGV LRAJI EXPRV OSMNP KEPDT
+      LPRWM JAZPK LQUZA ALGZX GVLKL GJTUI ITDSU REZXJ ERXZS HMPST
+      MTEOE PAPJH SMFNB YVQUZ AALGA YDNMP AQOWT UHDBV TSMUE UIMVH
+      QGVRW AEFSP EMPVE PKXZY WLKJA GWALT VYYOB YIXOK IHPDS EVLEV
+      RVSGB JOGYW FHKBL GLXYA MVKIS KIEHY IMAPX UOISK PVAGN MZHPW
+      TTZPV XFCCD TUHJH WLAPF YULTB UXJLN SIJVV YOVDJ SOLXG TGRVO
+      SFRII CTMKO JFCQF KTINQ BWVHG TENLH HOGCS PSFPV GJOKM SIFPR
+      ZPAAS ATPTZ FTPPD PORRF TAXZP KALQA WMIUD BWNCT LEFKO ZQDLX
+      BUXJL ASIMR PNMBF ZCYLV WAPVF QRHZV ZGZEF KBYIO OFXYE VOWGB
+      BXVCB XBAWG LQKCM ICRRX MACUO IKHQU AJEGL OIJHH XPVZW JEWBA
+      FWAML ZZRXJ EKAHV FASMU LVVUT TGK})
+
+(define first-char (char->integer #\A))
+(define chars# (- (char->integer #\Z) first-char -1))
+
+(define freqs ; english letter frequencies from wikipedia
+  ((compose1 list->vector (curry map (curryr / 100000.0)))
+   '(8167 1492 2782 4253 12702 2228 2015 6094 6966 153 772 4025 2406
+     6749 7507 1929 95 5987 6327 9056 2758 978 2360 150 1974 74)))
+
+(define (n*n-1 n) (* n (sub1 n)))
+
+(define text* (for/vector ([c (regexp-replace* #px"\\s+" text "")])
+                (- (char->integer c) first-char)))
+(define N (vector-length text*))
+(define (get-col-length+freqs width offset)
+  (define text (for/list ([i (in-range offset N width)]) (vector-ref text* i)))
+  (define cN (length text))
+  (define freqs (make-vector chars# 0))
+  (for ([c (in-list text)]) (vector-set! freqs c (add1 (vector-ref freqs c))))
+  (values cN freqs))
+
+(define expected-IC (* chars# (for*/sum ([x freqs]) (* x x))))
+
+;; maps key lengths to average index of coincidence
+(define keylen->ICs
+  (for/vector ([len (in-range 1 (add1 (* max-keylen 2)))])
+    (for/sum ([ofs len])
+      (define-values [cN cfreqs] (get-col-length+freqs len ofs))
+      (/ (for/sum ([i chars#]) (n*n-1 (vector-ref cfreqs i)))
+         (/ (n*n-1 cN) chars#) len 1.0))))
+
+;; given a key length find the key that minimizes errors from alphabet freqs,
+;; return (cons average-error key)
+(define (guess-key len)
+  (define guesses
+    (for/list ([ofs len])
+      (define-values [cN cfreqs] (get-col-length+freqs len ofs))
+      (for ([i chars#]) (vector-set! cfreqs i (/ (vector-ref cfreqs i) cN)))
+      (argmin car
+        (for/list ([d chars#])
+          (cons (for/sum ([i chars#])
+                  (expt (- (vector-ref freqs i)
+                           (vector-ref cfreqs (modulo (+ i d) chars#)))
+                        2))
+                d)))))
+  (cons (/ (apply + (map car guesses)) len) (map cdr guesses)))
+
+;; look for a key length that minimizes error from expected-IC, with some
+;; stupid consideration of multiples of the length (which should also have low
+;; errors), for each one guess a key, then find the one that minimizes both (in
+;; a way that looks like it works, but undoubtedly is wrong in all kinds of
+;; ways) and return the winner key
+(define best-key
+  ((compose1 cdr (curry argmin car))
+   (for/list ([i (* max-keylen 2)])
+     ;; get the error from the expected-IC for the length and its multiples,
+     ;; with decreasing weights for the multiples
+     (define with-multiples
+       (for/list ([j (in-range i (* max-keylen 2) (add1 i))] [div N])
+         (cons (/ (abs (- (vector-ref keylen->ICs j) expected-IC)) expected-IC)
+               (/ (add1 div)))))
+     (define total (/ (for/sum ([x with-multiples]) (* (car x) (cdr x)))
+                      (for/sum ([x with-multiples]) (cdr x))))
+     (define guess (guess-key (add1 i)))
+     (define guess*total (* total (car guess) (car guess)))
+     ;; (printf "~a~a: ~a ~s\n" (if (< i 9) " " "") (add1 i)
+     ;;       (list total (car guess) guess*total) (cdr guess))
+     (cons guess*total (cdr guess)))))
+
+(printf "Best key found: ")
+(for ([c best-key]) (display (integer->char (+ c first-char))))
+(newline)
+
+(printf "Decoded text:\n")
+(define decode-num
+  (let ([cur '()])
+    (λ(n) (when (null? cur) (set! cur best-key))
+          (begin0 (modulo (- n (car cur)) chars#) (set! cur (cdr cur))))))
+(for ([c text])
+  (define n (- (char->integer c) first-char))
+  (if (not (< -1 n chars#)) (display c)
+      (display (integer->char (+ first-char (decode-num n))))))
+(newline)