codepad

Language:

; permuted index

(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 (string-split sep str)
  (define (f cs xs) (cons (list->string (reverse cs)) xs))
  (let loop ((ss (string->list str)) (cs '()) (xs '()))
    (cond ((null? ss) (reverse (if (null? cs) xs (f cs xs))))
          ((char=? (car ss) sep) (loop (cdr ss) '() (f cs xs)))
          (else (loop (cdr ss) (cons (car ss) cs) xs)))))

(define (string-join sep ss)
  (define (f s ss)
    (string-append s (string sep) ss))
  (define (join ss)
    (if (null? (cdr ss)) (car ss)
      (f (car ss) (join (cdr ss)))))
  (if (null? ss) "" (join ss)))

(define stop-list
  '("a" "an" "and" "by" "for" "if" "in" "is" "of" "on" "the" "to"))

(define (rot-line words)
  (define (join xs) (string-join #\space xs))
  (let loop ((front (reverse words)) (back '()) (rots '()))
    (if (null? front) rots
      (let ((f (cdr front)) (b (cons (car front) back)))
        (loop f b (if (and (pair? f) (member (car b) stop-list)) rots
                    (cons (cons (join (reverse f)) (join b)) rots)))))))

(define (rot-file filename)
  (define (split s) (string-split #\space s))
  (with-input-from-file filename
    (lambda ()
      (let loop ((line (read-line)) (rs '()))
        (if (eof-object? line) rs
          (loop (read-line)
                (append (rot-line (split line)) rs)))))))

(define (rjust n str)
  (let ((len (string-length str)))
    (if (< n len)
        (substring str (- len n) len)
        (string-append (make-string (- n len) #\space) str))))

(define (ljust n str)
  (let ((len (string-length str)))
    (if (< n len)
        (substring str 0 n)
        (string-append str (make-string (- n len) #\space)))))

(define (print rots)
  (define (print-line x)
    (display (rjust 32 (car x)))
    (display "     ")
    (display (ljust 32 (cdr x)))
    (newline))
  (for-each print-line rots))

(define (ptx filename)
  (define (order-by a b) (string-ci<? (cdr a) (cdr b)))
  (print (sort order-by (rot-file filename))))

Private [?]

Run code