enigma.scm

(use-module "elf/util.scm")    ; dotimes
(use-module "elf/iterate.scm") ; map*
(use-module "https://gist.githubusercontent.com/brv00/0175bdf47dc70cf9e10d02e3c067cced/raw/035e31c0b28c3e75a3a052035d668488a43e8d7c/vector-util.scm")
;; またはこの URL をダウンロードして
;; この式を(use-module "/storage/emulated/0/Download/vector-util.scm")
;; のような式に置き換える。または、vector-copy の定義をコピペする。


(define (make-plug-board vec)
  (let* ((len (vector-length vec))
         (vec (vector-copy vec 0 len))
         (go-back (make-vector len)))
    (dotimes (i len) (vector-set! go-back (vector-ref vec i) i))
    (lambda (i . args) (vector-ref (if (memq 'go-back args) go-back vec) i))))

; 角度の設定はまた今度
(define (make-roter vec)
  (let* ((len (vector-length vec))
         (vec-r (make-vector len)) (vec-l (make-vector len)))
    (dotimes (i len)
      (let ((j (vector-ref vec i)))
        (vector-set! vec-r i (- j i))
        (vector-set! vec-l j (- i j))))
    (list vec-r vec-l)))

(define (make-roters . vs)
  (let* ((rs (map make-roter vs)) 
         (os (map car rs)) (rs (reverse (map cadr rs)))
         (len (vector-length (car vs)))
         (offsets (map (lambda (x) 0) vs))
         (rev-offsets (do ((p offsets (cdr p)) (res '() `(,p . ,res)))
                          ((null? p) res))))
    (lambda args
      (case (car args)
        ((reset!) (do ((p offsets (cdr p))) ((null? p) offsets)
                    (set-car! p 0)))
        ((rot!) (let lp ((offsets offsets))
                  (if (pair? offsets)
                    (let ((offset (car offsets)))
                      (cond ((= offset (- len 1))
                             (set-car! offsets 0) (lp (cdr offsets)))
                            (else (set-car! offsets (+ offset 1)))))))
                (values offsets rev-offsets))
        ((out) (do ((offsets offsets (cdr offsets)) (os os (cdr os))
                    (i (cadr args)
                       (let ((j (modulo (- i (car offsets)) len)))
                         (modulo (+ i (vector-ref (car os) j)) len))))
                   ((null? os) i)))
        ((ret) (do ((offsets rev-offsets (cdr offsets)) (rs rs (cdr rs))
                    (i (cadr args)
                       (let ((j (modulo (- i (caar offsets)) len)))
                         (modulo (+ i (vector-ref (car rs) j)) len))))
                   ((null? rs) i)))))))

;; (i)  0以上 n-1 以下の数を1個ずつ要素に持つ長さ n の vector を渡す。
;; (ii) 任意の k について、k 番目には k でない数が入っていなければならない。
;; （ii についてはエニグマであることに拘らないなら気にしなくてもいい）
(define (make-reflector vec)
  (let* ((len (vector-length vec)) (res (vector-copy vec 0 len))
         (work (make-vector len)))
    (dotimes (i len) (vector-set! work (vector-ref vec i) i))
    (dotimes (i len)
      (let* ((j (vector-ref res i)) (k (vector-ref work i)))
        (cond ((< i j)
               (vector-swap! res j k)
               (vector-set! work (vector-ref res j) j)
               (vector-set! work (vector-ref res k) k)))))
    res))

(define table "abcdefghijklmnopqrstuvwxyz")

(define char-a->integer-0
  (let* ((table1 (map* char->integer table))
         (mini (apply min table1)) (range (+ (apply max table1) 1))
         (table1 (list->vector table1))
         (table2 (make-vector range)))
    (dotimes (i 26) (vector-set! table2 (- (vector-ref table1 i) mini) i))
    (lambda (c) (vector-ref table2 (- (char->integer c) mini)))))

(define (integer-0->char-a i) (string-ref table i))

;; plug-board と reflector には
;; 0以上 n-1 以下の数を1個ずつ要素に持つ長さ n の vector を渡す。
;; reflector の i 番目が j のとき、j 番目は i でなければならない。
;; （この条件を満たす vector は make-reflector でつくることができる）
;; roters には
;; 0以上 n-1 以下の数を1個ずつ要素に持つ長さ n の vector のリストを渡す。
;; message は iterate (elf) で走査可能で、
;; すべての要素が char-alphabetic? と char-lower-case? で真を返す列
(define (encrypt plug-board roters reflector message)
  (let ((pb (make-plug-board plug-board)) (rs (apply make-roters roters)))
    (list->string
      (map* (lambda (c)
              (let ((res (integer-0->char-a
                           (pb (rs 'ret (vector-ref
                                          reflector
                                          (rs 'out (pb (char-a->integer-0 c)))))
                               'go-back))))
                (rs 'rot!)
                res))
            message))))
(define decode encrypt)

; 実行例
; (define pb
;   '#(15 13 5 4 8 7 24 20 22 9 16 21 0 3 17 18 10 14 6 12 2 25 19 23 11 1))
; (define r1
;   '#(19 7 24 14 15 12 6 1 9 21 5 2 20 16 17 23 10 0 25 8 22 4 3 11 13 18))
; (define r2
;   '#(11 12 17 9 10 7 4 20 6 21 23 22 14 18 16 1 24 19 8 25 3 0 13 5 2 15))
; (define r3
;   '#(17 14 8 2 1 13 21 16 9 6 15 11 0 7 5 18 10 22 25 4 23 3 12 19 20 24))
; (define rf
;   '#(23 15 17 5 8 3 9 12 4 6 13 19 7 10 16 1 14 2 22 11 25 24 18 0 21 20))

; (encrypt pb (list r1 r2 r3) rf "stcrossgirlsacademystoria")
; => "lavepmmwhsuxrfhzhkowxagkg"
; (decode pb (list r1 r2 r3) rf "lavepmmwhsuxrfhzhkowxagkg")
; => "stcrossgirlsacademystoria"