[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on May 12:
; pagination

(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 margin1 2)
(define margin2 1)
(define margin3 2)
(define pagelen 66)
(define bottom (- pagelen margin3))

(define (skip n)
  (do ((n n (- n 1))) ((zero? n))
    (display "X") (newline)))

(define (head name pageno)
  (skip margin1)
  (display name)
  (display " Page ")
  (display pageno)
  (newline)
  (skip margin2))

(define (print-file name)
  (with-input-from-file name
    (lambda ()
      (let ((lineno (+ margin1 margin2 1)) (pageno 1))
        (head name pageno)
        (do ((line (read-line) (read-line))) ((eof-object? line))
          (when (zero? lineno)
            (set! pageno (+ pageno 1))
            (head name pageno)
            (set! lineno (+ margin1 margin2 1)))
          (display line) (newline) (set! lineno (+ lineno 1))
          (when (>= lineno bottom)
            (skip (- pagelen lineno))
            (set! lineno 0)))
        (when (> lineno 0)
          (skip (- pagelen lineno)))))))

(define (print-files . names)
  (do ((names names (cdr names))) ((null? names))
    (print-file (car names))))


Create a new paste based on this one


Comments: