#!/bin/sh
exec ${GUILE-guile} -e "(ttn-do fortune)" -s $0 "$@" # -*-scheme-*-
!#
;; Copyright (C) 2004, 2005, 2007, 2009, 2010, 2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version. There is NO WARRANTY. See file COPYING for details.
;;; Commentary:
;; Usage: fortune -l (like "ls -l -I '*.dat' <standard-cookie-dir>")
;; fortune
;; fortune literature [or other filename in standard cookie dir]
;; fortune ABSOLUTE-FILENAME [.dat assumed in same dir]
;;
;; Display fortune cookie to stdout. Option ‘--list’ (or ‘-l’ for short)
;; means instead to list the contents of the <standard-cookie-dir>, which
;; is either "$HOME/local/share/games/fortunes" or the contents of file
;; $HOME/.fortune-cookie-dir if the first directory is not found. If the
;; cookie dir cannot be determined, signal error.
;;; Code:
(define-module (ttn-do fortune)
#:export (main
create-index-file!
fortune-cookie)
#:use-module ((ice-9 rw) #:select (read-string!/partial))
#:use-module ((ice-9 rdelim) #:select (read-line write-line))
#:use-module ((srfi srfi-13) #:select (substring/shared
string-take))
#:use-module ((ttn-do zzz banalities) #:select (check-hv
qop<-args))
#:use-module ((ttn-do zzz filesystem) #:select (directory-vicinity
dir-exists?))
#:use-module ((ttn-do zzz personally) #:select (FE)))
;; A fortune cookie file is a text file containing groups of lines separated
;; by "delim lines", a specially chosen character (traditionally the percent
;; `%' character) on a line by itself. The first and last lines may also be
;; delim lines. Each group of lines thus delimited is a "cookie". Thus, a
;; file with N cookies may have N-1, N or N+1 delim lines.
;;
;; A fortune cookie index file is a binary file consisting of a six-word
;; header followed by the offset table (each entry a word). A word is four
;; bytes in network (big-endian) order. The header is:
;;
;; version -- typically 1 for old files and 2 for newer ones
;; count -- number of cookies
;; longest -- number of bytes of longest cookie
;; shortest -- number of bytes of shortest cookie
;; flags -- logior of #x1 (random)
;; #x2 (ordered)
;; #x4 (rotated)
;; delim-char -- this is shifted to the MSB position
;; (the remaining bytes are #\nul)
;;
;; Traditionally, for cookie file foo, the index file is named foo.dat, but
;; that is not required.
(define (k name)
(case name
((#:format-version) 2) ; hmmm
((#:sizeof-word) 4)
((#:all-flags) '(#:random #:ordered #:rotated))
((#:random) #x1)
((#:ordered) #x2)
((#:rotated) #x4)
((#:bits-per-byte) 8) ; you never know...
((#:delim+newline) 2)
((#:all-headers) '(#:version #:count #:longest #:shortest
#:flags #:delim #:filler))))
(define (read-word-proc port)
(let ((uve (make-uniform-vector 1 1)))
(lambda ()
(uniform-vector-read! uve port)
(ntohl (uniform-vector-ref uve 0)))))
(define (write-word-proc port)
(let ((uve (make-uniform-vector 1 1)))
(lambda (n)
(uniform-vector-set! uve 0 (htonl n))
(uniform-vector-write uve port))))
(define (words<-cookie-file filename delim flags)
(let* ((p (open-input-file filename))
(count -1) (shortest #f) (longest #f)
(box (list #f))
(tp box)
(order? (memq #:ordered flags)))
(define (next)
(read-line p 'concat))
(define (another! ofs prev)
(let ((len (- ofs
(cond ((not prev) 0)
(order? (car prev))
(else prev))
(k #:delim+newline))))
(cond ((not shortest)
(set! shortest len)
(set! longest len))
(else
(set! shortest (min shortest len))
(set! longest (max longest len)))))
(set-cdr! tp (list
(if order?
(cons ofs
(let* ((full (apply string-append
(reverse acc)))
(len (string-length full)))
(do ((i 0 (1+ i)))
((or (= len i)
(let ((c (string-ref full i)))
(or (char-alphabetic? c)
(char-numeric? c))))
(substring/shared full i)))))
ofs)))
(set! tp (cdr tp))
(set! count (1+ count)))
;; If ‘order?’, accumulate (OFFSET . COOKIE-TRIMMED-TO-FIRST-ALPHANUMERIC),
;; then sort ascending. Otherwise, accumulate OFFSET only.
(let loop ((line (next)) (acc '()))
(cond ((eof-object? line)
(or (null? acc)
(another! (seek p 0 SEEK_END) (car tp)))
(close-port p)
;; kludge
(cond ((= 1 count)
(set! longest (+ (k #:delim+newline) longest))
(set! shortest (+ (k #:delim+newline) shortest))))
(cons* ; rv
;; header
(k #:format-version)
count
longest
shortest
(apply logior (map (lambda (flag)
(if (memq flag flags)
(k flag)
0))
(k #:all-flags)))
(ash (char->integer delim)
(* (1- (k #:sizeof-word))
(k #:bits-per-byte)))
;; offset table
(if order?
(map car (sort (cdr box) (lambda (a b)
(string<? (cdr a) (cdr b)))))
(cdr box))))
((and (= (k #:delim+newline) (string-length line))
(char=? delim (string-ref line 0)))
(another! (seek p 0 SEEK_CUR) (car tp))
(loop (next) '()))
((negative? count)
(set-cdr! tp (list 0))
(set! tp (cdr tp))
(set! count (1+ count))
(loop (next) (cons line acc)))
(else
(loop (next) (cons line acc)))))))
;; Create index file @var{out-name} from cookie file @var{in-name}, separating
;; cookies by looking for char @var{delim} on a line by itself. Optional
;; @var{flags} are keywords:
;;
;; @table @code
;; @item #:random
;; Set bit 0 (corresponding to a mask of #x1) in the flags word in the header,
;; but do nothing else at the moment (FIXME).
;;
;; @item #:ordered
;; Set bit 1 (corresponding to a mask of #x2) in the flags word in the header,
;; and order the offsets by sorting the cookies with @code{string<?}, ignoring
;; non-alphanumeric leading characters.
;;
;; @item #:rotated
;; Set bit 2 (corresponding to a mask of #x4) in the flags word in the header,
;; to note that the cookies are @dfn{ROT13}.
;; @end table
;;
;; Return #t on success.
;;
(define (create-index-file! out-name in-name delim . flags)
(call-with-output-file out-name
(lambda (port)
(FE (words<-cookie-file in-name delim flags)
(write-word-proc port)))))
(define (grok-header readc readw)
(let ((info (map cons
(k #:all-headers)
(list (readw)
(readw)
(readw)
(readw)
(let ((w (readw)))
(let loop ((ls (k #:all-flags)) (acc '()))
(if (null? ls)
acc
(let ((flag (car ls)))
(loop (cdr ls)
(if (zero? (logand (k flag) w))
acc
(cons flag acc)))))))
(readc)
(map (lambda ignored
(readc))
(iota (1- (k #:sizeof-word))))))))
;; rv
(lambda (name)
(assq-ref info name))))
(define (get-cookie cookie-file dat-file)
(let* ((port (open-input-file dat-file))
(readw (read-word-proc port))
(qh (grok-header (lambda () (read-char port)) readw))
(selection (random (qh #:count)))
(start (do ((i 0 (1+ i)))
((= i selection) (readw))
(readw)))
(need-scan? (or (memq #:ordered (qh #:flags))
(= (1- (qh #:count)) selection)))
(len (if need-scan?
(min (qh #:longest)
(- (stat:size (stat cookie-file)) start))
(- (readw) start (k #:delim+newline))))
(cookie (make-string len)))
(close-port port)
(let ((p (open-input-file cookie-file)))
(seek p start SEEK_SET)
(read-string!/partial cookie p)
(close-port p))
(and need-scan?
(let ((delim (qh #:delim))
(cookie-char=? (lambda (c n)
(char=? c (string-ref cookie n)))))
(let loop ((nl (string-index cookie #\nl 0)))
(and nl (if (and (<= (+ nl (k #:delim+newline)) len)
(cookie-char=? delim (1+ nl))
(cookie-char=? #\nl (+ nl 2)))
(set! cookie (string-take cookie (1+ nl)))
(loop (string-index cookie #\nl (1+ nl))))))))
(if (memq #:rotated (qh #:flags))
(list->string
(let ((a-n (char->integer #\a))
(A-n (char->integer #\A))
(rot (lambda (base n)
(integer->char (+ base (modulo (+ (- n base) 13) 26))))))
(map (lambda (c)
(let ((n (char->integer c)))
(cond ((char<=? #\a c #\z) (rot a-n n))
((char<=? #\A c #\Z) (rot A-n n))
(else c))))
(string->list cookie))))
cookie)))
;; Return a randomly-chosen string extracted from @var{cookie-file},
;; using the index file named by appending @file{.dat} to @var{cookie-file}.
;; Optional arg @var{dat-file} specifies the index file to use instead of the
;; default.
;;
;;-args: (- 1 0)
;;
(define (fortune-cookie cookie-file . dat-file)
(get-cookie cookie-file (if (null? dat-file)
(string-append cookie-file ".dat")
(car dat-file))))
(define (dir-ok? name)
(and (dir-exists? name) name))
(define (fortune/qop qop)
(let* ((under-home (directory-vicinity (getenv "HOME")))
(cdir (or (dir-ok? (under-home "local/share/games/fortunes"))
(let ((clue (under-home ".fortune-cookie-dir")))
(and (file-exists? clue)
(dir-ok? (call-with-input-file clue read-line))))
(error "could not determine fortune cookie dir"))))
(set! *random-state* (seed->random-state
(let ((pair (gettimeofday)))
(* (car pair) (cdr pair)))))
(if (qop 'list)
(let ((cmd (string-append "ls -l -I '*.dat' " cdir)))
(write-line cmd)
(system cmd))
(display (fortune-cookie
(let* ((args (qop '()))
(file (if (null? args)
"fortunes"
(car args))))
(if (char=? #\/ (string-ref file 0))
file
(in-vicinity cdir file))))))))
(define (main args)
(check-hv args '((package . "ttn-do")
(version . "1.0")
(help . commentary)))
(fortune/qop
(qop<-args
args '((list (single-char #\l))))))
;;; fortune ends here