1 files changed, 556 insertions(+), 0 deletions(-)

A => enter.scm
A => enter.scm +556 -0
@@ 0,0 1,556 @@ 
+#!/usr/bin/env guile
+; !#
+
+(define-module (enter)
+    #:export
+    (introduced-names ->string list->textline 
+        show colortable color 
+        say-lines say-name say Speak Speak-indirect
+        print-lines Print
+        Ask Choose ask respond
+        Enter Scene Call
+        main ))
+
+(use-modules (ice-9 optargs)
+              (srfi srfi-1)
+              (system syntax)
+              (ice-9 rdelim)
+              (ice-9 pretty-print))
+
+(define introduced-names '())
+
+(define (->string x)
+       (cond
+         ((symbol? x)
+           (symbol->string x))
+         ((number? x)
+           (format #f "~a" x))
+         ((unspecified? x)
+           "")
+         (else
+           (format #f "~A" x))))
+
+
+(define (show str)
+      (let lp ((chars (string->list str)))
+          (cond 
+            ((null? chars)
+              #t)
+            (else
+              (display (car chars))
+              (usleep 60000)
+              (lp (cdr chars))))))
+
+
+(define colortable
+    `(
+      (#f . "\x1b[0m")
+      (black . "\x1b[1;30m")
+      (blue . "\x1b[1;34m")
+      (yellow . "\x1b[1;33m")
+      (red . "\x1b[1;31m")
+      (cyan . "\x1b[1;36m")
+      (magenta . "\x1b[1;35m")
+      (green . "\x1b[1;32m")
+      (white . "\x1b[1;37m")))
+      
+
+(define (color col)
+       "helper function to colorize the input"
+       (cond
+         ((assoc col colortable)
+           (format #t (assoc-ref colortable col))
+           #f)
+         (else
+           (format #t (assoc-ref colortable #f))
+           #f)))
+
+(define-syntax say-words
+    (lambda (x)
+        (syntax-case x ()
+            ((_ word word2 words ...)
+              #`(begin
+                 (let ((w `word))
+                   (cond
+                     ((equal? w #f)
+                       #f)
+                     ((equal? w '..)
+                       (show ".")
+                       (show " "))
+                     (else
+                       (show (->string w))
+                       (show " "))))
+                 (say-words word2 words ...)))
+            ((_ last-word words ...)
+              #`(begin
+                 (let ((w `last-word))
+                   (cond
+                     ((equal? w #f)
+                       #f)
+                     ((equal? w '..)
+                       (show "."))
+                     (else
+                       (show (->string w)))))
+                 (say-words words ...)))
+            ((_)
+              #`(begin "")))))
+
+
+
+(define-syntax say-lines 
+    (lambda (x)
+        (syntax-case x (fdb6c10f-f8bf-4bb5-82c5-d3a5cd37b7c0)
+            ((_ (((word words ...))) fdb6c10f-f8bf-4bb5-82c5-d3a5cd37b7c0 (() lines ...))
+              ;; TODO: move out to a helper macro
+              #`(begin
+                 (say-words word words ...)
+                 (say-lines ((())) fdb6c10f-f8bf-4bb5-82c5-d3a5cd37b7c0 (() lines ...))))
+            ((_ ((())) fdb6c10f-f8bf-4bb5-82c5-d3a5cd37b7c0  (() lines ...))
+              #`(begin
+                 (usleep 200000)
+                 (newline)
+                 (say-lines (lines ...))))
+            ;; lines of form ,(...)
+            ((_ ((unq (word words ...)) lines ...))
+              #`(if (equal? 'unquote `unq ));; FIXME: This guard seems to not actually work
+              #`(begin ; add an extra level of parens
+                 (show "  " );; indentation of dialogue
+                 (say-lines (((unq (word words ...)))) fdb6c10f-f8bf-4bb5-82c5-d3a5cd37b7c0 (() lines ...))))
+            ((_ (((unq word)) lines ...))
+              #`(if (equal? 'unquote-splicing `unq ));; FIXME: This guard seems to not actually work
+              #`(begin ; include the unquoting without extra level of parentheses
+                 ;; TODO: clean this up. This duplicates logic in the first case, and duplicates it again internally. Also it is inconsistent with the handling of the show-words macro.
+                 (show " ")
+                 (apply
+                     (λ (unq x)
+                        (cond
+                          ((equal? 'unquote-splicing unq)
+                            (map (λ (x) (show " ")(show x))
+                                (if (pair? x)
+                                     (map ->string x)
+                                     x)))
+                          ((equal? 'unquote unq)
+                            (cond
+                              ((equal? x #f)
+                                #f)
+                              ((equal? x '..)
+                                (show "."))
+                              (else
+                                (show " ")
+                                (show (->string x)))))
+                          (else
+                            (cond
+                              ((equal? unq #f)
+                                #f)
+                              ((equal? unq '..)
+                                (show "."))
+                              (else
+                                (show " ")
+                                (show (->string unq))))
+                            (cond
+                              ((equal? x #f)
+                                #f)
+                              ((equal? x '..)
+                                (show "."))
+                              (else
+                                (show " ")
+                                (show (->string x)))))))
+                     (list 'unq word))
+                 (say-lines ((())) fdb6c10f-f8bf-4bb5-82c5-d3a5cd37b7c0 (() lines ...))))
+            ((_ ((word words ...) lines ...) ); start of a line
+              #`(begin
+                 (show "  " );; indentation of dialogue
+                 (say-lines (((word words ...))) fdb6c10f-f8bf-4bb5-82c5-d3a5cd37b7c0 (() lines ...))))
+            ((_ (() lines ...) ); finished showing the line, show the next one
+              #`(say-lines (lines ...)))
+            ((_ (lines ...))
+              #`(begin "")))))
+
+
+(define-syntax print-lines ;; this is say-lines without indentation and without unquote-splicing support (because that’s nasty)
+    (lambda (x)
+        (syntax-case x (fdb6c10f-f8bf-4bb5-82c5-d3a5cd37b7c0)
+            ((_ (((word words ...))) fdb6c10f-f8bf-4bb5-82c5-d3a5cd37b7c0 (() lines ...))
+              #`(begin
+                 (say-words word words ...)
+                 (print-lines ((())) fdb6c10f-f8bf-4bb5-82c5-d3a5cd37b7c0 (() lines ...))))
+            ((_ ((())) fdb6c10f-f8bf-4bb5-82c5-d3a5cd37b7c0  (() lines ...))
+              #`(begin
+                 (usleep 200000)
+                 (newline)
+                 (print-lines (lines ...))))
+            ;; lines of form ,(...)
+            ((_ ((unq (word words ...)) lines ...))
+              #`(if (equal? 'unquote `unq ));; FIXME: This guard seems to not actually work
+              #`(begin ; add an extra level of parens
+                 (print-lines (((unq (word words ...)))) fdb6c10f-f8bf-4bb5-82c5-d3a5cd37b7c0 (() lines ...))))
+            ((_ ((word words ...) lines ...) ); start of a line
+              #`(begin
+                 (print-lines (((word words ...))) fdb6c10f-f8bf-4bb5-82c5-d3a5cd37b7c0 (() lines ...))))
+            ((_ (() lines ...) ); finished showing the line, show the next one
+              #`(print-lines (lines ...)))
+            ((_ (lines ...))
+              #`(begin "")))))
+
+
+(define (clean-name nameparts)
+    (let loop ((name nameparts) (pure-name '()))
+        (cond
+            ((null? name)
+              (reverse! pure-name))
+            ((pair? (first name))
+              (loop (cdr name) pure-name))
+            ((string-prefix? ":" (symbol->string (first name)))
+              (loop (cdr name) pure-name))
+            (else
+              (loop (cdr name) (cons (first name) pure-name))))))
+
+(define (described-name nameparts)
+    (define black (string->symbol (assoc-ref colortable 'black)))
+    (define default (string->symbol (assoc-ref colortable #f)))
+    (let loop ((name nameparts) (pure-name '()))
+        (cond
+            ((null? name)
+              (reverse! pure-name))
+            ((pair? (first name))
+              (loop (cdr name) pure-name))
+            ((string-prefix? ":" (symbol->string (first name)))
+              (loop (cdr name) (append (list default (first name) black) pure-name)))
+            (else
+              (loop (cdr name) (cons (first name) pure-name))))))
+
+(define (clean-name-definition nameparts)
+    (let loop ((name nameparts) (pure-name '()))
+        (cond
+            ((null? name)
+              (reverse! pure-name))
+            ((pair? (first name))
+              (loop (cdr name) pure-name))
+            ((string-prefix? ":" (symbol->string (first name)))
+              (when (< (length name) 2)
+                (error 
+                  (format #f "Name ~A contains keyword without value ~A"
+                    nameparts (first name))))
+              (loop (cdr (cdr name)) pure-name))
+            (else
+              (loop (cdr name) (cons (first name) pure-name))))))
+
+
+(define (say-name nameparts)
+       (let 
+         ;; symbols starting with : are not treated as part of the
+         ;; name. They can be used as actor instructions
+         ((pure-name (clean-name nameparts))
+           (described-name (described-name nameparts)))
+         (if (not (member pure-name introduced-names))
+              (error 
+                (format #f "Tried to use ~A who did not Enter. Introduced names: ~A" 
+                  pure-name introduced-names)))
+         (format #t "\n~A\n"
+           (string-join (map symbol->string described-name)))))
+
+
+(define-syntax say
+  (lambda (x)
+    (syntax-case x ()
+      ((_ nameparts lines)
+        #`(begin
+           (say-name nameparts)
+           (say-lines lines))))))
+
+
+
+(define-syntax Print
+ (lambda (x)
+  (with-ellipsis :::
+   (syntax-case x ()
+     ;; Support form for modifiers: enclose by double parens (used later)
+     ((_ (word :::) line :::)
+         #`(begin
+            (print-lines ((word :::) line :::))))))))
+
+
+(define-syntax Speak
+ (lambda (x)
+  (with-ellipsis :::
+   (syntax-case x ()
+     ;; Support form for modifiers: enclose by double parens (used later)
+     ((_ (((name :::))) ((mod :::)) (word :::) line :::)
+         #`(begin
+            (say-name (quasiquote (name ::: mod :::)))
+            (say-lines ((word :::) line :::))))
+     ;; extend mod keywords
+     ((_ (((name :::))) ((mod :::)) modifier line :::)
+         ;; extend the modifier keyword list
+         #`(Speak (((name :::))) ((mod ::: modifier)) line :::))
+     ;; say form without modifier
+     ((_ (((name :::))) (word :::) line :::)
+         #`(Speak (((name :::))) (()) (word :::) line :::))
+     ;; first modifier keyword after the name
+     ((_ (((name :::))) modifier line :::)
+         ;; append to mod helper form
+         #`(Speak (((name :::))) ((modifier)) line :::))
+     ;; Strip the name from lines with empty arguments
+     ((_ (((name :::))) symbol :::)
+         #`(begin #t symbol :::))))))
+
+
+(define-syntax Speak-indirect
+    (lambda (x)
+        (syntax-case x ()
+            ;; Adjust name and lines for Speak for the case where I
+            ;; cannot match for the whole name.
+            ;; input: (((name1 name2 ... (word ...) ...)))
+            
+            ;; grab the lines one by one from the back
+            ((_ (((symbols ... (word ...)))) lines ...)
+              #`(Speak-indirect (((symbols ...))) (word ...) lines ...))
+            ;; start with the last line
+            ((_ (((symbols ... (word ...)))))
+              #`(Speak-indirect (((symbols ...))) (word ...)))
+            ;; no more lines remain at the end: the rest must be the name
+            ((_ (((name ...))) lines ...)
+              #`(Speak (((name ...))) lines ...)))))
+
+
+(define (introduce! nameparts)
+    (set! introduced-names (cons (clean-name-definition nameparts) introduced-names)))
+
+(define-syntax Enter
+ (lambda (x)
+  (syntax-case x ()
+   ((_ (name more ...) b ...)
+     ; new binding: only create it if the binding is not already a macro
+     (not (eq? 'macro (syntax-local-binding (syntax name))))
+     #'(begin
+       ;; process the name: define special syntax for this name (only
+       ;; for the first word of the name, the correctness of the rest
+       ;; of the words is checked at runtime in the say procedure)
+       (define-syntax name
+        (lambda (y)
+         (with-ellipsis :::
+          (syntax-case y (more ...)
+           ; just forward matching rules to Speak
+           ((_ more ... symbol :::)
+             #'(Speak (((name more ...))) symbol :::))
+           ((_ symbols :::)
+               ; TODO: this does not correctly make the second name
+               ; part of the name, preventing differentiation between
+               ; name and modifier
+               #`(Speak-indirect (((name symbols :::)))))))))
+       ;; process the rest of the names
+       (Enter b ...)
+       ;; record that the name was introduced. I do not see a way to do
+       ;; this directly in the compiler, therefore it is checked later
+       ;; during runtime.
+       (introduce! '(name more ...))))
+       ;; add debug output, must be added it here, not in front
+       ; write 
+       ;   quote : list Enter (name more ...) b ...
+       ; newline
+   ((_ (name more ...) b ...)
+     ; existing binding: Just allow using this.
+     #'(begin
+        (Enter b ...)
+        (introduce! '(name more ...))))
+   ((_ b ...)
+     #'(begin #t)))))
+
+
+(define-syntax Scene
+  (lambda (x)
+    (syntax-case x ()
+      ((_ thisscene args ...)
+        (with-syntax ((c (datum->syntax x (module-name (current-module)))))
+          #`(begin ; FIXME: this currently requires the Scene identifier to be a valid symbol -> cannot use "Scene 1"
+             (module-re-export! (current-module)
+               (module-map (λ (x y) x)
+                  (module-import-interface (current-module) 'Scene ))); ensure that all symbols remain available
+             (define-module (scene thisscene))
+             (import c)
+             #t))))))
+
+(define (list->textline L)
+         (string-join (map ->string L)
+                     " "))
+
+(define (ask choices)
+    #(;; use via Choose
+        (example
+            (Choose
+                ((to the trees)
+                  (,(color 'red) NO ,(color #f)))
+                ((to the stones)
+                  (Yes)
+                  (There)))))
+    (define questions (map list->textline choices))
+    (define counter 0)
+    ;; FIXME: This is horrible, because it uses a plain string as content of a line
+    (say-lines
+      (
+        (
+          (unquote
+            (string-join
+              (map 
+                 (λ (x)
+                   (set! counter (+ 1 counter))
+                   (string-append
+                       (cdr (list-ref colortable (modulo (+ 1 counter) (length colortable))))
+                       (number->string counter)
+                       (cdr (list-ref colortable 0))
+                       "  "
+                       x))
+                 questions)
+              "\n  ")))))
+    (let*
+      ((input (format #f "~a" (peek-char))))
+      ;; drain all user input, most importantly the linebreak after the answer
+      (while (char-ready? (current-input-port))
+          (read-char (current-input-port)))
+      input))
+      
+(define-syntax-rule (respond line lines ...)
+    (say-lines (line lines ...)))
+
+(define-syntax QuoteFirsts
+  (lambda (x)
+    (syntax-case x (7c227022-d695-4485-834c-6d41ceabda4f)
+      ((_ () 7c227022-d695-4485-834c-6d41ceabda4f firsts ...)
+        #`(begin
+           (quote (firsts ...))))
+      ((_ ((firstfirst firstrest ...) rest ...) 7c227022-d695-4485-834c-6d41ceabda4f firsts ...)
+        #`(begin
+           (QuoteFirsts (rest ...) 7c227022-d695-4485-834c-6d41ceabda4f firsts ... firstfirst)))
+      ((_ ((firstfirst firstrest ...) rest ...))
+        #`(begin
+           (QuoteFirsts ((firstfirst firstrest ...) rest ...) 7c227022-d695-4485-834c-6d41ceabda4f)))
+      ((_ ())
+        #`(#f)))))
+
+(define-syntax Ask
+  (lambda (x)
+    (syntax-case x ()
+      ((_ (choices ...))
+        #`(begin
+           (ask (QuoteFirsts (choices ...))))))))
+
+(define-syntax Respond1
+  (lambda (x)
+    (syntax-case x ()
+      ((_ ((question consequences ...) choices ...))
+        #`(begin
+           (respond consequences ...)))
+      ((_ (choices ...))
+        #`(begin #f)))))
+
+(define-syntax Respond2
+  (lambda (x)
+    (syntax-case x ()
+      ((_ (choice choices ...))
+        #`(begin
+           (Respond1 (choices ...))))
+      ((_ (choices ...))
+        #`(begin #f)))))
+
+(define-syntax Respond3
+  (lambda (x)
+    (syntax-case x ()
+      ((_ (a b choices ...))
+        #`(Respond1 (choices ...)))
+      ((_ (choices ...))
+        #`(begin #f)))))
+
+(define-syntax Respond4
+  (lambda (x)
+    (syntax-case x ()
+      ((_ (a b c choices ...))
+        #`(Respond1 (choices ...)))
+      ((_ (choices ...))
+        #`(begin #f)))))
+
+(define-syntax Respond5
+  (lambda (x)
+    (syntax-case x ()
+      ((_ (a b c d choices ...))
+        #`(Respond1 (choices ...)))
+      ((_ (choices ...))
+        #`(begin #f)))))
+
+(define-syntax Respond6
+  (lambda (x)
+    (syntax-case x ()
+      ((_ (a b c d e choices ...))
+        #`(Respond1 (choices ...)))
+      ((_ (choices ...))
+        #`(begin #f)))))
+
+(define-syntax-rule (Choose . choices)
+   "Ask questions, apply consequences"
+   (begin 
+     (say-lines (("") ));; newline before choose, because it might not be asked by the previous speaker.
+     (let loop ()
+       (define resp (string->number (Ask choices)))
+       (or
+         (cond
+           ((equal? resp 1)
+             (Respond1 choices))
+           ((equal? resp 2)
+             (Respond2 choices))
+           ((equal? resp 3)
+             (Respond3 choices))
+           ((equal? resp 4)
+             (Respond4 choices))
+           ((equal? resp 5)
+             (Respond5 choices))
+           ((equal? resp 6)
+             (Respond6 choices))
+           (else
+             #f))
+         (loop)))))
+  
+(define (main args)
+  (Enter (First Witch)
+          (Second Witch)
+          (Third Witch)
+          (First Eldritch))
+
+  (First Witch
+      (When shall we three meet again)
+      (In ,(color 'cyan) thunder, ,(color #f) ,(color 'white) lightning, ,(color #f) or in ,(color 'blue) rain? ,(color #f)))
+  
+  (Second Witch :resolute
+      (When the hurlyburly's done, (we ,(+ 1 2)) ); inline-code is allowed!
+      (When the ,(color 'red) battle's ,(color #f) 
+         lost and won. )); ,(read-char) ; and executed when the word is shown
+
+  (Third Witch
+      (That will be ere the set of ,(color 'yellow) sun ,(color #f) ..))
+      ; .. can be used for a . without preceding space. It MUST be
+      ; used to get a trailing .
+
+  (First Eldritch :crazy
+      (,(color 'magenta) gnignigni! ,(color #f)))
+
+  (Enter (Second Eldritch))
+  
+  (Second Eldritch :quick
+      (,(color 'black) Guh!)
+      ; . :goo ; invalid ⇒ would be an error
+      ; . foo ; invalid ⇒ would be an error
+      (Moo ,(color #f))))
+
+;; Making the name longer throws an Error, but only at runtime:
+;  Second Eldritch shoo
+;      Guh!
+;; ⇒ ERROR: Tried to use (Second Eldritch shoo) who did not Enter. Introduced names: ((Second Eldritch) (First Witch) (Second Witch) (Third Witch) (First Eldritch))
+
+;; Adding one who did not enter throws an Error, but only at runtime:
+;  Third Eldritch
+;      Guh!
+;; ⇒ ERROR: Tried to use (Third Eldritch) who did not Enter. Introduced names: ((Second Eldritch) (First Witch) (Second Witch) (Third Witch) (First Eldritch))
+
+
+
+
+
+