2017-02-04: add enter three witches, precompiled

add enter three witches, precompiled

diff --git a/examples/enter-three-witches.scm b/examples/enter-three-witches.scm
new file mode 100644
--- /dev/null
+++ b/examples/enter-three-witches.scm
@@ -0,0 +1,267 @@
+#!/usr/bin/env sh
+(# -*- wisp -*-)
+(guile -L $(dirname $(dirname $(realpath "$0"))) -c '(import (wisp-scheme) (language wisp spec))')
+(exec guile -L $(dirname $(dirname $(realpath "$0"))) --language=wisp -e '(@@ (examples enter-three-witches) main)' -s "$0" "$@")
+; !#
+
+(define-module (examples enter-three-witches)
+    #:export (introduced-names ->string show colortable color say-words say-name say Speak Speak-indirect Enter Scene))
+
+(use-modules (ice-9 optargs)
+              (srfi srfi-1)
+              (system syntax))
+
+;; FIXME: This version currently does not allow using the same first
+;; name several times. It will need a more refined macro generator
+;; which first gathers all the necessary definitions and then builds
+;; them.
+
+(define introduced-names '())
+
+(define (->string x)
+       (cond
+         ((symbol? x)
+           (symbol->string x))
+         ((number? x)
+           (format #f "~a" 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")
+      (red . "\x1b[1;31m")
+      (green . "\x1b[1;32m")
+      (yellow . "\x1b[1;33m")
+      (blue . "\x1b[1;34m")
+      (magenta . "\x1b[1;35m")
+      (cyan . "\x1b[1;36m")
+      (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 words ...))) (() lines ...))
+              #`(begin
+                  (let ((w `word))
+                    (cond
+                     ((equal? w #f)
+                      #f)
+                     ((equal? w '..)
+                      (show "."))
+                     (else
+                      (show " ")
+                      (show (->string w)))))
+                  (say-words (((words ...))) (() lines ...))))
+            ((_ ((())) (() lines ...))
+              #`(begin
+                 (usleep 200000)
+                 (newline)
+                 (say-words (lines ...))))
+            ;; lines of form ,(...)
+            ((_ ((unq (word words ...)) lines ...))
+              #`(begin if (equal 'unquote `unq))
+              #`(begin ; add an extra level of parens
+                 (show " ")
+                 (say-words ((((unq (word words ...))))) (() lines ...))))
+            ((_ ((word words ...) lines ...))
+              #`(begin
+                 (show " ")
+                 (say-words (((word words ...))) (() lines ...))))
+            ((_ (() lines ...))
+              #`(say-words (lines ...)))
+            ((_ (lines ...))
+              #`(begin
+                 (newline))))))
+
+
+(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 (remove (lambda (x) (string-prefix? ":" (symbol->string x))) (remove pair? 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 "~A\n"
+         (string-join (map symbol->string nameparts))))
+
+
+(define-syntax say
+  (lambda (x)
+    (syntax-case x ()
+      ((_ nameparts lines)
+        #`(begin
+           (say-name nameparts)
+           (say-words lines))))))
+
+
+(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-words ((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-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 :::)
+               ; 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.
+       (set! introduced-names (cons '(name more ...) introduced-names))))
+       ;; 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 ...)
+        (set! introduced-names (cons '(name more ...) introduced-names))))
+   ((_ 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 (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))
+
+
+
+
+
+