fortune-cookie

[Thien-Thi Nguyen <ttn@surf.glug.org>]

(use-modules (database binconv) (scripts slurp))

(define (fortune-cookie cookie-file)

  (let* ((port (open-input-file (string-append cookie-file ".dat")))
         (readw (let ((s (make-string 4)))
                  (lambda ()
                    (string-set! s 0 (read-char port))
                    (string-set! s 1 (read-char port))
                    (string-set! s 2 (read-char port))
                    (string-set! s 3 (read-char port))
                    (integer-byte-string->integer s #f #t)))))

    (define (read-header)
      (list (cons #:version  (readw))
            (cons #:count    (readw))
            (cons #:longest  (readw))
            (cons #:shortest (readw))
            (cons #:flags    (let* ((w (readw))
                                    (chk (lambda (mask val)
                                           (if (= 0 (logand mask w))
                                               '()
                                               (list val)))))
                               `(,@(chk #x1 #:random)
                                 ,@(chk #x2 #:ordered)
                                 ,@(chk #x4 #:rotated))))
            (cons #:delim    (read-char port))
            (cons #:filler   (list (read-char port)
                                   (read-char port)
                                   (read-char port)))))

    ;; do it!
    (let* ((header (read-header))
           (selection (random (assq-ref header #:count)))
           (start (do ((i 0 (1+ i)))
                      ((= i selection) (readw))
                    (readw)))
           (finish (readw))
           (len (- finish start 2))
           (cookie (make-string len)))
      (slurp-file! cookie cookie-file start len 0)
      (display cookie))))

;;(set! *random-state* (seed->random-state (current-time)))
;;(fortune-cookie "lambda.txt") ; use strfile(1) to make lambda.txt.dat


_______________________________________________
Guile-user mailing list
Guile-user@gnu.org
http://lists.gnu.org/mailman/listinfo/guile-user