[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/GBXcEPTy    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on Jul 10:
(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 (string-upcase str)
  (list->string
    (map char-upcase
      (string->list str))))

(define (read-line . port)
  (define (eat p c)
    (if (and (not (eof-object? (peek-char p)))
             (char=? (peek-char p) c))
        (read-char p)))
  (let ((p (if (null? port) (current-input-port) (car port))))
    (let loop ((c (read-char p)) (line '()))
      (cond ((eof-object? c) (if (null? line) c (list->string (reverse line))))
            ((char=? #\newline c) (eat p #\return) (list->string (reverse line)))
            ((char=? #\return c) (eat p #\newline) (list->string (reverse line)))
            (else (loop (read-char p) (cons c line)))))))

(define (fold-input reader proc base . pof)
  (let* ((f? (and (pair? pof) (string? (car pof))))
         (p (cond (f? (open-input-file (car pof)))
                  ((pair? pof) (car pof))
                  (else (current-input-port)))))
    (let loop ((item (reader p)) (base base))
      (if (eof-object? item)
          (begin (if f? (close-input-port p)) base)
          (loop (reader p) (proc base item))))))

(define sort #f)
(define merge #f)
(let ()
  (define dosort
    (lambda (pred? ls n)
      (if (= n 1)
          (list (car ls))
          (let ((i (quotient n 2)))
            (domerge pred?
                     (dosort pred? ls i)
                     (dosort pred? (list-tail ls i) (- n i)))))))
  (define domerge
    (lambda (pred? l1 l2)
      (cond
        ((null? l1) l2)
        ((null? l2) l1)
        ((pred? (car l2) (car l1))
         (cons (car l2) (domerge pred? l1 (cdr l2))))
        (else (cons (car l1) (domerge pred? (cdr l1) l2))))))
  (set! sort
    (lambda (pred? l)
      (if (null? l) l (dosort pred? l (length l)))))
  (set! merge
    (lambda (pred? l1 l2)
      (domerge pred? l1 l2))))

(define (unique eql? xs)
  (cond ((null? xs) '())
        ((null? (cdr xs)) xs)
        ((eql? (car xs) (cadr xs))
          (unique eql? (cdr xs)))
        (else (cons (car xs) (unique eql? (cdr xs))))))

(define (uniq-c eql? xs)
  (if (null? xs) xs
    (let loop ((xs (cdr xs)) (prev (car xs)) (k 1) (result '()))
      (cond ((null? xs) (reverse (cons (cons prev k) result)))
            ((eql? (car xs) prev) (loop (cdr xs) prev (+ k 1) result))
            (else (loop (cdr xs) (car xs) 1 (cons (cons prev k) result)))))))

(define (left-section proc . args)
  (lambda xs (apply proc (append args xs))))

(define null-key (make-string 26 #\_))

(define (make-key pass-phrase)
  (define (c->z c)
    (map integer->char
      (range (char->integer c) 91)))
  (define (add-if xs ys)
    (let loop ((xs xs) (ys ys))
      (cond ((null? xs) ys)
            ((not (char-alphabetic? (car xs))) (loop (cdr xs) ys))
            ((member (car xs) ys) (loop (cdr xs) ys))
            (else (loop (cdr xs) (cons (car xs) ys))))))
  (let* ((ks (add-if (map char-upcase (string->list pass-phrase)) '()))
         ; uncomment next line for stronger key
         ; (ks (add-if (c->z (car ks)) ks))
         (ks (add-if (c->z #\A) ks)))
    (list->string (reverse ks))))

(define (p->c key p)
  (if (not (char-alphabetic? p)) p
    (string-ref key (- (char->integer (char-upcase p)) 65))))

(define (c->p key c)
  (if (not (char-alphabetic? c)) c
    (let loop ((c-index 25))
      (cond ((negative? c-index) #\_)
            ((char=? (string-ref key c-index) c)
              (integer->char (+ c-index 65)))
            (else (loop (- c-index 1)))))))

(define (encipher key plain-text)
  (list->string
    (map (left-section p->c key)
      (string->list plain-text))))

(define (decipher key cipher-text)
  (list->string
    (map (left-section c->p key)
      (string->list cipher-text))))

(define (freq . args)
  (let* ((bite (if (= (length args) 1) 1 (car args)))
         (text (if (= (length args) 1) (car args) (cadr args))))
    (let loop ((ts (string->list text)) (fs '()))
      (if (< (length ts) bite)
          (sort (lambda (a b)
                  (cond ((< (cdr b) (cdr a)) #t)
                        ((< (cdr a) (cdr b)) #f)
                        (else (string<? (car a) (car b)))))
            (uniq-c string=? (sort string<? fs)))
          (loop (cdr ts) (cons (list->string (take bite ts)) fs))))))

(define (dict key cipher-text)
  (let* ((cs (map char-upcase (string->list cipher-text)))
         (len (length cs)))
    (let loop ((words words) (ws '()))
      (cond ((null? words) (reverse ws))
            ((not (= (string-length (car words)) len))
              (loop (cdr words) ws))
            ((match? key cs (string->list (car words)))
              (loop (cdr words) (cons (car words) ws)))
            (else (loop (cdr words) ws))))))

(define (match? key cs ws)
  (let loop ((key key) (cs cs) (ws ws))
    (cond ((null? cs) #t)
          ((and (not (char-alphabetic? (car cs)))
                (not (char-alphabetic? (car ws)))
                (char=? (car cs) (car ws)))
            (loop key (cdr cs) (cdr ws)))
          ((or (not (char-alphabetic? (car cs)))
               (not (char-alphabetic? (car ws)))) #f)
          ((char=? (c->p key (car cs)) (car ws))
            (loop key (cdr cs) (cdr ws)))
          ((char=? (p->c key (car ws)) (car cs))
            (loop key (cdr cs) (cdr ws)))
          ((and (char=? (c->p key (car cs)) #\_)
                (char=? (p->c key (car ws)) #\_))
            (loop (add-key key (list (cons (car ws) (car cs)))) (cdr cs) (cdr ws)))
          (else #f))))

(define words
  (map string-upcase
    (sort string<?
      (unique string=?
        (fold-input read-line (lambda (d a) (cons a d)) '()
          "/usr/dict/words")))))

(define (string->words str)
  (let loop ((cs (string->list str)) (w '()) (ws '()))
    (cond ((null? cs)
            (reverse
              (if (null? w) ws
                (cons (list->string (reverse w)) ws))))
          ((or (char-alphabetic? (car cs)) (char=? (car cs) #\'))
            (loop (cdr cs) (cons (car cs) w) ws))
          ((pair? w) (loop (cdr cs) '() (cons (list->string (reverse w)) ws)))
          (else (loop (cdr cs) w ws)))))

(define (enhance-key key cipher-text plain-text)
  (let ((key (string-copy key))
        (cipher-text (string-upcase cipher-text))
        (plain-text (string-upcase plain-text)))
    (do ((i 0 (+ i 1))) ((= i (string-length plain-text)))
      (if (char-alphabetic? (string-ref plain-text i))
          (string-set! key (- (char->integer (string-ref plain-text i)) 65)
            (string-ref cipher-text i))))
    key))

(define (solve cs)
  (define (next k c)
    (map (lambda (w) (enhance-key k c w)) (dict k c)))
  (define (nexts ks c)
    (apply append (map (lambda (k) (next k c)) ks)))
  (let loop ((cs cs) (ks (list null-key)))
    ; (display cs) (display (length ks)) (newline)
    (if (null? cs) ks
      (loop (cdr cs) (nexts ks (car cs))))))

(define (sort-by-counts words)
  (map car (sort (lambda (x y) (< (cdr x) (cdr y)))
    (map (lambda (w) (cons w (length (dict null-key w)))) words))))

(define (cryptogram cipher)
  (unique string=? (sort string<?
    (map (lambda (k) (decipher k cipher))
      (solve (sort-by-counts (string->words cipher)))))))


Output:
1
2
3
4
open-input-file: cannot open input file: "/usr/dict/words" (No such file or directory; errno=2)

 === context ===
Line 36:0: fold-input


Create a new paste based on this one


Comments: