[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Mar 30:
(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 (drop n xs)
  (let loop ((n n) (xs xs))
    (if (or (zero? n) (null? xs)) xs
      (loop (- n 1) (cdr xs)))))

(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 (filter pred? xs)
  (let loop ((xs xs) (ys '()))
    (cond ((null? xs) (reverse ys))
          ((pred? (car xs))
            (loop (cdr xs) (cons (car xs) ys)))
          (else (loop (cdr xs) ys)))))

(define-syntax assert
  (syntax-rules ()
    ((assert expr result)
      (if (not (equal? expr result))
          (for-each display `(
            #\newline "failed assertion:" #\newline
            expr #\newline "expected: " ,result
            #\newline "returned: " ,expr #\newline))))))

(define (transpose m)
  (if (null? (car m)) '()
    (cons (map car m) (transpose (map cdr m)))))

(define (make-list n x)
  (let loop ((n n) (xs '()))
    (if (zero? n) xs
      (loop (- n 1) (cons x xs)))))

(define (sort lt? xs)
  (define (merge x1 x2)
    (cond ((null? x1) x2)
          ((null? x2) x1)
          ((lt? (car x2) (car x1))
            (cons (car x2) (merge x1 (cdr x2))))
          (else (cons (car x1) (merge (cdr x1) x2)))))
  (define (merge-pairs xs k)
    (if (or (null? (cdr xs)) (odd? k)) xs
        (merge-pairs
          (cons (merge (car xs) (cadr xs)) (cddr xs))
          (quotient k 2))))
  (define (next-run run xs)
    (if (or (null? xs) (lt? (car xs) (car run)))
        (values (reverse run) xs)
        (next-run (cons (car xs) run) (cdr xs))))
  (define (sorting xs ys k)
    (if (null? xs)
        (car (merge-pairs ys 0))
        (call-with-values
          (lambda () (next-run (list (car xs)) (cdr xs)))
          (lambda (run tail)
            (sorting tail (merge-pairs (cons run ys) (+ k 1)) (+ k 1))))))
  (if (null? xs) xs (sorting xs '() 0)))

(define X '_) ; a unique tag for padding the data structure

(define (waves str h)
  (define (down str)
    (if (>= h (length str))
        (list (fill h str))
        (cons (take h str) (up (drop h str)))))
  (define (up str)
    (if (>= (- h 2) (length str))
        (list (pad (fill (- h 2) str)))
        (cons (pad (take (- h 2) str)) (down (drop (- h 2) str)))))
  (define (pad str) (append (list X) (reverse str) (list X)))
  (define (fill h str) (append str (make-list (- h (length str)) X)))
  (down str))

(define (fence lox h)
  (define a (apply append (transpose (waves lox h))))
  (filter (lambda (e) (not (eq? X e))) a))

(define (encipher str h)
  (list->string (fence (string->list str) h)))

(define (decipher str h)
  (define e (fence (range (string-length str)) h))
  (define x (map list e (string->list str)))
  (define y (sort (lambda (i j) (<= (car i) (car j))) x))
  (define z (map cadr y))
  (list->string z))

(do ((i 2 (+ i 1))) ((< 18 i))
  (assert (decipher (encipher "PROGRAMMING PRAXIS" i) i)
         "PROGRAMMING PRAXIS"))

(display (encipher "PROGRAMMING PRAXIS" 4)) (newline)

(display (decipher "PMPRAM RSORIGAIGNX" 4))


Output:
1
2
PMPRAM RSORIGAIGNX
PROGRAMMING PRAXIS


Create a new paste based on this one


Comments: