Re: Guile 100 #6: CGI and MySQL

[Daniel Hartwig <mandyke@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 1039 bytes --]

On 2 May 2013 01:17, Mike Gran <spk121@yahoo.com> wrote:
> Three other problems remain incomplete, so feel free to try your
> hand at one of them as well.
>

>     - Challenge #3: LZW Compression
>

Just for fun I made a rough start at this one when you announced it.
The outer procedures are as specified in the project details, the
inner procedures operate on “streams” of any kind of data similar to
the templates in Nelsons writeup.

The universe of symbols (uncompress data) is not required to be 8 bit
integers, but it must be known in advance.

If this seems an interesting start, I'll tidy it up for pedagogy,
produce the two scripts, and of course the obligatory writeup.  The
level of abstraction in the inner procedures is perhaps a nice
opportunity to briefly compare Guiles options for processing streams
of data (i.e. containers, ports, srfi-41, input–output procedures) and
reasons for my particularly choice here.  I assumed procedures would
be less overhead than streams, but did not test it.

[-- Attachment #2: lzw.scm --]
[-- Type: application/octet-stream, Size: 3994 bytes --]

(define-module (lzw)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (lzw-compress
            lzw-uncompress
            %lzw-compress
            %lzw-uncompress))

;; This procedure adapted from an example in the Guile Reference
;; Manual.
(define (make-serial-number-generator start end)
  (let ((current-serial-number (- start 1)))
    (lambda ()
      (and (< current-serial-number end)
           (set! current-serial-number (+ current-serial-number 1))
           current-serial-number))))

(define (%lzw-compress in out done? table-size)
  (let ((codes (make-hash-table table-size))
        (next-code (make-serial-number-generator 0 table-size))
        (universe (iota 256))
        (eof-code #f))
    ;; Populate the initial dictionary with all one-element strings
    ;; from the universe.
    (for-each (lambda (obj)
                (hash-set! codes (list obj) (next-code)))
              universe)
    (set! eof-code (next-code))
    (let loop ((cs '()))
      (let ((c (in)))
        (cond ((done? c)
               (unless (null? cs)
                 (out (hash-ref codes cs)))
               (out eof-code)
               codes)
              ((hash-ref codes (cons c cs))
               (loop (cons c cs)))
              (else
               (and=> (next-code)
                      (cut hash-set! codes (cons c cs) <>))
               (out (hash-ref codes cs))
               (loop (cons c '()))))))))

(define (put-u16 port k)
  (put-u8 port (logand k #xFF))
  (put-u8 port (logand (ash k -8) #xFF)))

(define* (lzw-compress bv #:key (table-size 65536) dictionary)
  (call-with-values
      (lambda ()
        (open-bytevector-output-port))
    (lambda (output-port get-result)
      (let ((dict (%lzw-compress (cute get-u8 (open-bytevector-input-port bv))
                                 (cute put-u16 output-port <>)
                                 eof-object?
                                 table-size)))
        (if dictionary
            (values (get-result) dict)
            (get-result))))))

(define (for-each-right proc lst)
  (let loop ((lst lst))
    (unless (null? lst)
      (loop (cdr lst))
      (proc (car lst)))))

(define (%lzw-uncompress in out done? table-size)
  (let ((strings (make-hash-table table-size))
        (next-code (make-serial-number-generator 0 table-size))
        (universe (iota 256))
        (eof-code #f))
    (for-each (lambda (obj)
                (hash-set! strings (next-code) (list obj)))
              universe)
    (set! eof-code (next-code))
    (let loop ((previous-string '()))
      (let ((code (in)))
        (unless (or (done? code)
                    (= code eof-code))
          (unless (hash-ref strings code)
            (hash-set! strings
                       code
                       (cons (last previous-string) previous-string)))
          (for-each-right out (hash-ref strings code))
          (let ((cs (hash-ref strings code)))
            (and=> (and (not (null? previous-string))
                        (next-code))
                   (cut hash-set! strings <> (cons (last cs)
                                                   previous-string)))
            (loop cs)))))))

(define (get-u16 port)
  ;; Order of evaluation is important, use 'let*'.
  (let* ((a (get-u8 port))
         (b (get-u8 port)))
    (if (any eof-object? (list a b))
        (eof-object)
        (logior a (ash b 8)))))

(define* (lzw-uncompress bv #:key (table-size 65536) dictionary)
  (call-with-values
      (lambda ()
        (open-bytevector-output-port))
    (lambda (output-port get-result)
      (let ((dict (%lzw-uncompress (cute get-u16 (open-bytevector-input-port bv))
                                   (cute put-u8 output-port <>)
                                   eof-object?
                                   table-size)))
        (if dictionary
            (values (get-result) dict)
            (get-result))))))