Location: prog, 640 Lines
#! /usr/local/bin/s9 ; advgen -- generate HTML text adventures ; by Nils M Holm, 2010,2012 ; Placed in the Public Domain ; ; Usage: advgen [too many options] [file] ; ; Sample adventure: ; ; (room ; ("This is a sample room.") ; (((not light)) ; ("It's pitch-dark!") ; "Turn on light" ; (add light)) ; ((light) ; ("It's too bright!") ; "Turn off light" ; (rem light))) (load-from-library "string-split.scm") (load-from-library "string-translate.scm") (load-from-library "for-all.scm") (load-from-library "remove.scm") (load-from-library "basename.scm") (load-from-library "displaystar.scm") (load-from-library "append-to-output-file.scm") (load-from-library "string-digest.scm") (load-from-library "write-to-string.scm") (load-from-library "hash-table.scm") (load-from-library "parse-optionsb.scm") (define bare-html (option #\b #f)) (define debug-info (option #\d #f)) (define dry-run (option #\n #f)) (define dumpdir (option #\o 'string)) (define hash-length (option #\H 'integer)) (define intro-text (option #\i 'string)) (define path-length (option #\P 'string)) (define page-epilog (option #\e 'string)) (define remove-old (option #\r #f)) (define page-prolog (option #\p 'string)) (define show-help (option #\h #f)) (define squeeze-nl (option #\s #f)) (define state-comments (option #\c #f)) (define style-sheet (option #\y 'string)) (define title-text (option #\t 'string)) (define verbose (option #\v 'counter)) (define options `(,show-help ,bare-html ,debug-info ,dry-run ,dumpdir ,hash-length ,intro-text ,page-epilog ,path-length ,page-prolog ,remove-old ,squeeze-nl ,state-comments ,style-sheet ,title-text ,verbose)) (define *dumpdir* "advdump") (define *dest-node* #f) (define *min-depth* #f) (define *hash-length* 8) (define *visited* (make-hash-table)) (define *base* #t) (define vertex-id car) (define vertex-desc cadr) (define vertex-cond* cddr) (define mod-cond car) (define mod-desc cadr) (define mod-link caddr) (define mod-action cadddr) (define (valid-action? a) (and (list? a) (not (null? a)) (or (and (memq (car a) '(go add rem)) (<= 2 (length a) 3) (symbol? (cadr a)) (or (null? (cddr a)) (string? (caddr a)))) (and (memq (car a) '(nop)) (<= 1 (length a))) (and (memq (car a) '(add/go rem/go)) (<= 3 (length a) 4) (symbol? (cadr a)) (symbol? (caddr a)) (or (null? (cdddr a)) (string? (cadddr a)))) (and (memq (car a) '(go/cut go/sel)) (>= (length a) 2) (for-all symbol? (cdr a)))))) (define (valid-clause? x) (or (symbol? x) (and (list? x) (= 2 (length x)) (eq? 'not (car x)) (symbol? (cadr x))))) (define (valid-description? x) (and (list? x) (or (for-all string? x) (and (= 2 (length x)) (eq? 'copy-from (car x)) (symbol? (cadr x)))))) (define (list-of-string? x) (and (list? x) (for-all string? x))) (define (valid-link-text? x) (or (string? x) (and (list-of-string? x) (= 3 (length x))))) (define (adv-error v-id msg . obj) (display "advgen: ") (if v-id (display* "vertex " v-id ": ")) (display* "error: " msg) (if (not (null? obj)) (display* ": " (car obj))) (newline) (sys:exit 1)) ; An adventure description is a sequence of vertexes ; of the following form: ; ; vertex := (<identifier> ; ("description" ; ...) ; ((<identifier>|(not <identifier>) ...) ; ("description" ...) ; "action description" ; <action> ; ...) ; ; <action> := (go <identifier> ["message"]) ; | (add <identifier> ["message"]) ; | (add/go <identifier> <identifier> ["message"]) ; | (rem <identifier> ["message"]) ; | (rem/go <identifier> <identifier> ["message"]) ; | (go/cut <identifier> ... ) ; | (go/sel <identifier> ... ) ; | (nop [<identifier>] [<identifier>] ["message"]) ; ; <identifier> := [a-z0-9:\-]+ (define (read-description) (let ((vertexes (make-hash-table)) (base #f)) (let loop ((obj (read))) (cond ((eof-object? obj) (list base vertexes)) ((not (list? obj)) (adv-error #f "expected a vertex, got" obj)) ((< (length obj) 2) (adv-error #f "missing members in vertex" obj)) ((not (symbol? (vertex-id obj))) (adv-error #f "malformed vertex ID" (vertex-id obj))) ((not (valid-description? (vertex-desc obj))) (adv-error (vertex-id obj) "malformed description in vertex" (vertex-desc obj))) ((let cloop ((c* (vertex-cond* obj))) (and (not (null? c*)) (let ((c (car c*))) (if (not (= 4 (length c))) (adv-error (vertex-id obj) "missing members in modifier" c)) (if (or (not (list? (mod-cond c))) (not (for-all valid-clause? (mod-cond c)))) (adv-error (vertex-id obj) "malformed condition in modifier" (mod-cond c))) (if (not (valid-description? (mod-desc c))) (adv-error (vertex-id obj) "malformed description in modifier" (mod-desc c))) (if (not (valid-link-text? (mod-link c))) (adv-error (vertex-id obj) "malformed link text in modifier" (mod-link c))) (if (not (valid-action? (mod-action c))) (adv-error (vertex-id obj) "malformed action in modifier" (mod-action c))) (cloop (cdr c*)))))) (else (if (hash-table-ref vertexes (vertex-id obj)) (adv-error #f "duplicate vertex ID" (vertex-id obj))) (hash-table-set! vertexes (vertex-id obj) obj) (if (not base) (set! base (vertex-id obj))) (loop (read))))))) (define (append-map p . x) (apply append (apply map p x))) (define (make-path id) (string-append *dumpdir* "/" id ".html")) (define *vertex-counter* 0) (define unique (let ((h (make-hash-table))) (lambda (seed len) (let ((v (string-digest (write-to-string seed) (* 4 len)))) (set! *vertex-counter* (+ 1 *vertex-counter*)) (let loop ((v v)) (if (hash-table-ref h v) (loop (+ 1 v)) (let ((s (number->string v 16))) (hash-table-set! h v #t) (if (>= (string-length s) len) (substring s 0 len) (string-append (make-string (- len (string-length s)) #\0) s))))))))) (define (emit* . args) (if (not (opt-val dry-run)) (if (opt-val squeeze-nl) (apply display* (remv #\newline args)) (apply display* args)))) (define (call-with-dummy-file file thunk) (thunk #f)) (define (copy-to out) (if (not (opt-val dry-run)) (let loop ((c (read-char))) (if (not (eof-object? c)) (begin (write-char c out) (loop (read-char))))))) (define (html-prelude out title) (if (not (opt-val bare-html)) (emit* out "<HTML>" #\newline "<HEAD>" #\newline "<TITLE>" title "</TITLE>" #\newline (cond ((opt-val style-sheet) => (lambda (name) (string-append "<LINK rel=stylesheet " "type=\"text/css\" href=\"" name "\">" (string #\newline)))) (else "")) "</HEAD>" #\newline "<BODY>" #\newline)) (cond ((opt-val page-prolog) => (lambda (path) (with-input-from-file path (lambda () (copy-to out)))))) (cond ((opt-val title-text) => (lambda (text) (emit* out "<H1><A href=\"index.html\">" text "</A></H1>" #\newline (if (opt-val page-prolog) "" "<HR>") #\newline ))))) (define (html-postlude out) (cond ((opt-val page-epilog) => (lambda (path) (with-input-from-file path (lambda () (copy-to out)))))) (if (not (opt-val bare-html)) (emit* out "</BODY>" #\newline "</HTML>" #\newline))) (define (make-interim-page msg dest) (let ((i-vertex (unique msg *hash-length*))) (if (and (opt-val verbose) (> (opt-val verbose) 1)) (display* "state: interim" #\newline)) (if (not (opt-val dry-run)) (with-output-to-file (make-path i-vertex) (lambda () (html-prelude (current-output-port) "Info") (emit* "<P>" msg "</P>" #\newline "<P>" "<A href=\"" dest ".html\">Continue</A></P>" #\newline) (html-postlude (current-output-port))))) i-vertex)) (define (make-heading sym) (let* ((s (symbol->string sym)) (s (car (string-split #\: s))) (l (string->list s)) (l (cons (char-upcase (car l)) (cdr l)))) (string-translate (list->string l) "-" " "))) (define (last x) (car (reverse x))) (define (all-but-last x) (reverse! (cdr (reverse x)))) (define (emit-desc out desc) (for-each (lambda (x) (emit* out x #\newline)) desc)) (define (emit-mod-desc* out c*) (cond ((not (null? c*)) (for-each (lambda (x) (if (not (null? (mod-desc x))) (emit-desc out (mod-desc x)))) c*)))) (define (cycle prop v-id) (adv-error v-id "cycling through property" prop)) (define (cut-props props state) (if (null? props) state (cut-props (cdr props) (remq (car props) state)))) (define (retain-props props state) (let ((cut (cut-props props state))) (cut-props cut state))) (define (make-nav-grid out dir*) (letrec ((find-dir (lambda (d d*) (cond ((null? d*) #f) ((string=? d (mod-link (cadar d*))) (caar d*)) (else (find-dir d (cdr d*))))))) (emit* out "<DIV> </DIV>" #\newline "<TABLE>" #\newline) (let y-loop ((grid '(("NW" "N" "NE") ("W" "" "E") ("SW" "S" "SE")))) (if (not (null? grid)) (begin (emit* out "<TR>" #\newline) (let x-loop ((row (car grid))) (if (null? row) (begin (emit* out "</TR>" #\newline) (y-loop (cdr grid))) (begin (emit* out "<TD> ") (let ((dest (find-dir (car row) dir*))) (if dest (emit* out "<A href=\"" (string-append dest ".html") "\">" (car row) "</A>") (emit* out (car row)))) (emit* out " </TD>" #\newline) (x-loop (cdr row)))))))) (emit* out "</TABLE>" #\newline))) (define (split-desc s) (if (string? s) (list "" s "") s)) (define (emit-action* out page-id c* vertexes v-id state visited depth) (if (not (null? c*)) (emit* out "<DL>" #\newline)) (let loop ((c* c*) (dir* '())) (if (null? c*) (if (not (null? dir*)) (make-nav-grid out dir*)) (let ((x (car c*))) (let ((a (mod-action x)) (new-v-id v-id) (new-state state)) (case (car a) ((go) (set! new-v-id (cadr a))) ((add) (if (memq (cadr a) state) (cycle (cadr a) v-id)) (set! new-state (cons (cadr a) state))) ((add/go) (if (memq (cadr a) state) (cycle (cadr a) v-id)) (set! new-state (cons (cadr a) state)) (set! new-v-id (caddr a))) ((rem) (set! new-state (remq (cadr a) state))) ((rem/go) (set! new-state (remq (cadr a) state)) (set! new-v-id (caddr a))) ((go/cut) (set! new-state (cut-props (cddr a) state)) (set! new-v-id (cadr a))) ((go/sel) (set! new-state (retain-props (cddr a) state)) (set! new-v-id (cadr a))) ((nop) 'nop) ((nop) 'nop) (else (adv-error v-id "bad action" (car a)))) (let* ((new-tag (cons new-v-id new-state)) (linked-vertex (hash-table-ref visited new-tag))) (if out (close-output-port out)) (let ((v (if linked-vertex (car linked-vertex) (render-vertex vertexes new-v-id new-state (+ 1 depth))))) (if out (set! out (append-to-output-file (make-path page-id)))) (cond ((and (string? (mod-link x)) (string=? "" (mod-link x))) (loop (cdr c*) dir*)) ((member (mod-link x) '("N" "E" "S" "W" "NE" "SE" "SW" "NW")) (loop (cdr c*) (cons (list v x) dir*))) (else (let ((s* (split-desc (mod-link x)))) (emit* out "<DD>" (car s*) "<A href=\"" (if (string? (last a)) (make-interim-page (last a) v) v) ".html\">" (cadr s*) "</A>" (caddr s*) "</DD>" #\newline)) (loop (cdr c*) dir*))))))))) (if (not (null? c*)) (emit* out "</DL>" #\newline)) out) (define (true-conditions cond* state) (append-map (lambda (this-cond) (let loop ((c* (mod-cond this-cond))) (cond ((null? c*) (list this-cond)) ((or (and (symbol? (car c*)) (not (memq (car c*) state))) (and (pair? (car c*)) (memq (cadar c*) state))) '()) (else (loop (cdr c*)))))) cond*)) (define (find-vertex src vertexes v-id) (let ((v (hash-table-ref vertexes v-id))) (if v (car v) (adv-error src "no such vertex" v-id)))) (define (render-vertex vertexes v-id state depth) (if (eq? v-id *dest-node*) (if (or (not *min-depth*) (< depth *min-depth*)) (set! *min-depth* depth))) (let* ((vertex (find-vertex #f vertexes v-id)) (tag (cons (vertex-id vertex) state)) (c* (true-conditions (vertex-cond* vertex) state))) (let ((page-id (unique tag *hash-length*))) (if (and (opt-val verbose) (> (opt-val verbose) 1)) (display* "state: " tag #\newline)) (if (and (not (opt-val dry-run)) (not (file-exists? *dumpdir*))) (sys:mkdir *dumpdir*)) ((if (opt-val dry-run) call-with-dummy-file call-with-output-file) (make-path page-id) (lambda (out) (html-prelude out (make-heading v-id)) (if (opt-val state-comments) (emit* out "<!-- state: " tag " -->" #\newline)) (if (opt-val debug-info) (emit* out "<P>State: " tag "</P>" #\newline)) (hash-table-set! *visited* tag page-id) (emit* out (if (opt-val title-text) "<H2>" "<H1>") (make-heading (vertex-id vertex)) (if (opt-val title-text) "</H2>" "</H1>") #\newline) (emit* out "<P>" #\newline) (let* ((desc (vertex-desc vertex)) (desc (if (and (pair? desc) (eq? 'copy-from (car desc))) (vertex-desc (find-vertex v-id vertexes (cadr desc))) desc))) (emit-desc out desc)) (emit-mod-desc* out c*) (emit* out "</P>" #\newline) (let ((out (emit-action* out page-id c* vertexes v-id state *visited* depth))) (html-postlude out)))) page-id))) (define (dump-state v-id vertexes) (render-vertex vertexes v-id '() 0)) (define (make-entry-page base) (if (not (opt-val dry-run)) (with-output-to-file (make-path "index") (lambda () (html-prelude (current-output-port) (if (opt-val title-text) (opt-val title-text) "The Beginning")) (cond ((opt-val intro-text) => (lambda (file) (with-input-from-file file (lambda () (copy-to (current-output-port))))))) (emit* "<H2><A href=\"" base ".html\">Let the journey begin!</A></H2>" #\newline) (html-postlude (current-output-port)))))) (define (advgen) (let* ((base+vertexes (read-description)) (base (car base+vertexes)) (vertexes (cadr base+vertexes)) (n-vertexes (length (hash-table->alist vertexes)))) (if base (let ((entry-page (dump-state base vertexes))) (make-entry-page entry-page) (if (opt-val verbose) (display* n-vertexes " vertexes read, " *vertex-counter* " states generated." #\newline)) (if (opt-val path-length) (if (not *min-depth*) (display* "there is no path to a vertex named \"" *dest-node* "\"" #\newline) (display* "shortest path to \"" *dest-node* "\": " *min-depth* " nodes" #\newline))))))) (define (usage) (display* "Usage: advgen [-bcdnrsv] [-e file] [-H length] [-i file]" "[-o path]" #\newline " [-p file] [-P node] [-t text] [-y url] [file]") (newline)) (let ((file (parse-options! (sys:command-line) options usage))) (if (opt-val show-help) (begin (display-usage `("" ,usage "" "Generate HTML text adventures" "" "-b emit bare HTML without headers or BODY tags" "-c include state comments in source files" "-d write visible state information to each page" "-e file copy page epilogue from file" "-H len hash length (file name length)" "-i file copy introduction text from file" "-n dry-run, do not emit any data" "-o path output path" "-p file copy page prologue from file" "-P node print the length of the shortest path to node" "-r remove left-over files before processing" " (will remove *all* files from destination!)" "-s squeeze out newlines to save space" "-t text title to be displayed on each page" "-y url link style sheet (not with -b)" "-v verbose operation" "")) (sys:exit))) (cond ((opt-val dumpdir) => (lambda (path) (set! *dumpdir* path)))) (cond ((opt-val path-length) => (lambda (path) (set! *dest-node* (string->symbol path))))) (cond ((opt-val hash-length) => (lambda (len) (set! *hash-length* len)))) (if (and (opt-val remove-old) (file-exists? *dumpdir*)) (for-each (lambda (name) (sys:unlink (string-append *dumpdir* "/" name))) (sys:readdir *dumpdir*))) (cond ((> (length file) 1) (usage) (sys:exit)) ((null? file) (advgen)) (else (with-input-from-file (car file) advgen))))