; run-length encoding
; This implementation is not IEEE- or R5RS-compliant,
; for the following reasons:
;
; This implementation does not redefine procedures
; like READ, WRITE, DISPLAY, and NEWLINE to ensure
; that they use the redefined PEEK-CHAR, READ-CHAR,
; WRITE-CHAR, and so forth. That should be easy
; for an implementor to do, however.
;
; This implementation obtains an end-of-file object
; by reading a Unix-specific file, /dev/null.
(define open-input-string 0) ; assigned below
(define open-output-string 0) ; assigned below
(define get-output-string 0) ; assigned below
; We have to remember the original procedures before
; we can define new ones.
(define ur-vector? vector?)
(define ur-vector-length vector-length)
(define ur-vector-ref vector-ref)
(define ur-vector-set! vector-set!)
(define ur-input-port? input-port?)
(define ur-output-port? output-port?)
(define ur-close-input-port close-input-port)
(define ur-close-output-port close-output-port)
(define ur-peek-char peek-char)
(define ur-read-char read-char)
(define ur-write-char write-char)
; IEEE/ANSI Scheme insists that we define any global
; variables that we are going to assign. R5RS Scheme
; apparently does not require this.
(define vector? vector?)
(define vector-length vector-length)
(define vector-ref vector-ref)
(define vector-set! vector-set!)
(define input-port? input-port?)
(define output-port? output-port?)
(define close-input-port close-input-port)
(define close-output-port close-output-port)
(define peek-char peek-char)
(define read-char read-char)
(define write-char write-char)
(let ((ur-vector? ur-vector?)
(ur-vector-length ur-vector-length)
(ur-vector-ref ur-vector-ref)
(ur-vector-set! ur-vector-set!)
(ur-input-port? ur-input-port?)
(ur-output-port? ur-output-port?)
(ur-close-input-port ur-close-input-port)
(ur-close-output-port ur-close-output-port)
(ur-peek-char ur-peek-char)
(ur-read-char ur-read-char)
(ur-write-char ur-write-char)
(eof (call-with-input-file "/dev/null" read-char))
(input-string-tag (list 'input-string-tag))
(output-string-tag (list 'output-string-tag)))
(define (error)
(display "You're not supposed to do that!")
(newline)
(if #f #f))
(define (restrict f pred?)
(lambda (x . rest)
(if (pred? x)
(apply f x rest)
(error))))
(define (my-vector? x)
(and (ur-vector? x)
(not (input-string? x))
(not (output-string? x))))
(define (input-string? x)
(and (ur-vector? x)
(positive? (ur-vector-length x))
(eq? input-string-tag (ur-vector-ref x 0))))
(define (output-string? x)
(and (ur-vector? x)
(positive? (ur-vector-length x))
(eq? output-string-tag (ur-vector-ref x 0))))
(define (selector pred? i)
(lambda (x)
(if (pred? x)
(ur-vector-ref x i)
(error))))
(define (setter pred? i)
(lambda (x y)
(if (pred? x)
(begin (ur-vector-set! x i y)
(if #f #f))
(error))))
(set! vector? my-vector?)
(set! vector-length (restrict ur-vector-length my-vector?))
(set! vector-ref (restrict ur-vector-ref my-vector?))
(set! vector-set! (restrict ur-vector-set! my-vector?))
(let ()
; The guts of the implementation begin here.
(define (make-input-string s)
(vector input-string-tag #t s (string-length s) 0))
(define input-string:open? (selector input-string? 1))
(define input-string:open?! (setter input-string? 1))
(define input-string:string (selector input-string? 2))
(define input-string:size (selector input-string? 3))
(define input-string:next (selector input-string? 4))
(define input-string:next! (setter input-string? 4))
(define (make-output-string)
(vector output-string-tag #t '()))
(define output-string:open? (selector output-string? 1))
(define output-string:open?! (setter output-string? 1))
(define output-string:contents (selector output-string? 2))
(define output-string:contents! (setter output-string? 2))
(set! open-input-string make-input-string)
(set! open-output-string make-output-string)
(set! get-output-string
(lambda (x)
(list->string (reverse (output-string:contents x)))))
(set! input-port?
(lambda (x)
(or (ur-input-port? x)
(input-string? x))))
(set! output-port?
(lambda (x)
(or (ur-output-port? x)
(output-string? x))))
(set! close-input-port
(lambda (x)
(if (input-string? x)
(input-string:open?! x #f)
(ur-close-input-port x))))
(set! close-output-port
(lambda (x)
(if (output-string? x)
(output-string:open?! x #f)
(ur-close-output-port x))))
(set! peek-char
(lambda args
(if (null? args)
(ur-peek-char)
(let ((x (car args)))
(if (input-string? x)
(let ((s (input-string:string x))
(i (input-string:next x))
(n (input-string:size x)))
(if (input-string:open? x)
(if (< i n)
(string-ref s i)
eof)
(error)))
(ur-peek-char x))))))
(set! read-char
(lambda args
(if (null? args)
(ur-read-char)
(let ((x (car args)))
(if (input-string? x)
(let ((s (input-string:string x))
(i (input-string:next x))
(n (input-string:size x)))
(if (input-string:open? x)
(if (< i n)
(let ((c (string-ref s i)))
(input-string:next! x (+ i 1))
c)
eof)
(error)))
(ur-read-char x))))))
(set! write-char
(lambda (c . rest)
(if (null? rest)
(ur-write-char c)
(let ((x (car rest)))
(if (output-string? x)
(if (output-string:open? x)
(output-string:contents!
x
(cons c (output-string:contents x)))
(error))
(ur-write-char c x))))))
(if #f #f)))
(define (compress in-port out-port)
(define (n->char n) (integer->char (+ 64 n)))
(define (show-run prev n)
(display #\~ out-port)
(display (n->char n) out-port)
(display prev out-port))
(define (put-run prev n)
(cond ((char=? prev #\~) (show-run #\~ n))
((< n 4) (display (make-string n prev) out-port))
((< n 27) (show-run prev n))
(else (show-run prev 26) (put-run prev (- n 26)))))
(let loop ((c (read-char in-port)) (prev #f) (n 0))
(cond ((eof-object? c) (if prev (put-run prev n)))
((and prev (char=? c prev))
(loop (read-char in-port) prev (+ n 1)))
(prev (put-run prev n) (loop (read-char in-port) c 1))
(else (loop (read-char in-port) c 1)))))
(define (expand in-port out-port)
(define (char->n c) (- (char->integer c) 64))
(let loop ((c (read-char in-port)))
(unless (eof-object? c)
(if (char=? c #\~)
(let* ((n (char->n (read-char in-port)))
(c (read-char in-port)))
(display (make-string n c) out-port))
(display c out-port))
(loop (read-char in-port)))))
(with-input-from-string "ABBB~CDDDDDEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE"
(lambda () (compress (current-input-port) (current-output-port))))
ABBB~A~C~ED~ZE~DE
(with-input-from-string "ABBB~A~C~ED~ZE~DE"
(lambda () (expand (current-input-port) (current-output-port))))
ABBB~CDDDDDEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE