#!/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)
         ((symbol? x)
           (symbol->string x))
         ((number? x)
           (format #f "~a" x))
           (format #f "~A" x))))

(define (show str)
      (let lp ((chars (string->list str)))
            ((null? chars)
              (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"
         ((assoc col colortable)
           (format #t (assoc-ref colortable col))
           (format #t (assoc-ref colortable #f))

(define-syntax say-words 
    (lambda (x)
        (syntax-case x ()
            ((_ (((word words ...))) (() lines ...))
                  (let ((w `word))
                     ((equal? w #f)
                     ((equal? w '..)
                      (show "."))
                      (show " ")
                      (show (->string w)))))
                  (say-words (((words ...))) (() lines ...))))
            ((_ ((())) (() lines ...))
                 (usleep 200000)
                 (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 ...))
                 (show " ")
                 (say-words (((word words ...))) (() lines ...))))
            ((_ (() lines ...))
              #`(say-words (lines ...)))
            ((_ (lines ...))

(define (say-name nameparts)
         ;; 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))
                (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)
           (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 :::)
            (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))))
       ;; 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.
        (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)

(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))