# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1484762681 0
# Node ID ddcf7ddf78f6b391a582fb745c71f7eb4a6c3979
# Parent  e736ba397f2a4e0ee05ff6f54c4029f7e9daacaa
Interpreter -> compiler

diff -r e736ba397f2a -r ddcf7ddf78f6 examples/git-commands.lisp
--- a/examples/git-commands.lisp	Wed Jan 18 10:18:50 2017 +0000
+++ b/examples/git-commands.lisp	Wed Jan 18 18:04:41 2017 +0000
@@ -75,31 +75,31 @@
   external-location)
 
 
-(define-string action
-  (list "bisect" "bisecting")
-  (list "clone" "cloning")
-  (list "commit" "committing")
-  (list "delete" "deleting")
-  (list "display" "displaying")
-  (list "fast-forward" "fast-forwarding")
-  (list "fetch" "fetching")
-  (list "merge" "merging")
-  (list "move" "moving")
-  (list "print" "printing")
-  (list "prune" "pruning")
-  (list "pull" "pulling")
-  (list "push" "pushing")
-  (list "record" "recording")
-  (list "revert" "reverting")
-  (list "remove" "removing")
-  (list "rename" "renaming")
-  (list "reset" "resetting")
-  (list "resolve" "resolving")
-  (list "show" "showing")
-  (list "sign" "signing")
-  (list "simplify" "simplifying")
-  (list "update" "updating")
-  (list "verify" "verifying"))
+(define-rule action
+  ("bisect" "bisecting")
+  ("clone" "cloning")
+  ("commit" "committing")
+  ("delete" "deleting")
+  ("display" "displaying")
+  ("fast-forward" "fast-forwarding")
+  ("fetch" "fetching")
+  ("merge" "merging")
+  ("move" "moving")
+  ("print" "printing")
+  ("prune" "pruning")
+  ("pull" "pulling")
+  ("push" "pushing")
+  ("record" "recording")
+  ("revert" "reverting")
+  ("remove" "removing")
+  ("rename" "renaming")
+  ("reset" "resetting")
+  ("resolve" "resolving")
+  ("show" "showing")
+  ("sign" "signing")
+  ("simplify" "simplifying")
+  ("update" "updating")
+  ("verify" "verifying"))
 
 (defun action-verb ()
   (first (action)))
@@ -158,7 +158,8 @@
 
 
 (defun letter ()
-  (random-elt "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"))
+  (aref "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
+        (random 52)))
 
 (defun shellify (str)
   (string-downcase (substitute #\- #\space str)))
@@ -167,11 +168,9 @@
   ("-" :. letter)
   ("-" :. letter [noun shellify string-upcase]))
 
-(defparameter *noun* nil)
-
 (define-string long-option%
-  (eval (let ((*noun* (generate-string [noun shellify])))
-          (generate-string ("--" :. *noun* :. "=<" :. *noun* :. ">"))))
+  !(let ((noun $[noun shellify]))
+     $("--" :. !noun :. "=<" :. !noun :. ">"))
   ("--" :. action-verb)
   ("--" :. extremum)
   ("--only-" :. adjective)
@@ -200,28 +199,24 @@
 (defparameter *command* nil)
 (defparameter *commanding* nil)
 
-(define-string description
-  (look-for location "for the" age noun "and" *command* "it")
-  ("read" (eval (+ 2 (random 2000))) "bytes from" location "and" *command* "them")
-  (*command* "the" extremum noun "in" git-location)
-  (*command* [noun a] temporal-adverb refreshing git-location)
-  (*command* "and push all" adjective [noun s] "to" location)
-  (*command* "all" adjective [noun s] "in" git-location)
-  (*command* "the" extremum "and merge it into" git-location)
-  (*command* "some" [noun s] "from a remote")
-  (*command* "two or more" [noun s] "and save them to" location)
-  ("move or" *command* [noun a] "in" git-location)
-  ("rebase" [noun a] "onto" location "after" *commanding* "it")
-  (*command* "and" refresh git-location)
-  ("list," *command* :. ", or delete" [noun s]))
+(define-string (description :arguments (command commanding))
+  (look-for location "for the" age noun "and" !command "it")
+  ("read" !(+ 2 (random 2000)) "bytes from" location "and" !command "them")
+  (!command "the" extremum noun "in" git-location)
+  (!command [noun a] temporal-adverb refreshing git-location)
+  (!command "and push all" adjective [noun s] "to" location)
+  (!command "all" adjective [noun s] "in" git-location)
+  (!command "the" extremum "and merge it into" git-location)
+  (!command "some" [noun s] "from a remote")
+  (!command "two or more" [noun s] "and save them to" location)
+  ("move or" !command [noun a] "in" git-location)
+  ("rebase" [noun a] "onto" location "after" !commanding "it")
+  (!command "and" refresh git-location)
+  ("list," !command :. ", or delete" [noun s]))
 
 (defun entry ()
-  (destructuring-bind (*command* *commanding*) (action)
-    (generate-string
-      ("git" *command* options #\newline :. [description cap]))))
+  (destructuring-bind (command commanding) (action)
+    $("git" !command options #\newline :.
+      [!(description command commanding) cap])))
 
 
-(defun p (s)
-  (format t "~A~2%" s))
-
-; (map nil #'p (gimme 40 (entry)))
diff -r e736ba397f2a -r ddcf7ddf78f6 src/chancery.lisp
--- a/src/chancery.lisp	Wed Jan 18 10:18:50 2017 +0000
+++ b/src/chancery.lisp	Wed Jan 18 18:04:41 2017 +0000
@@ -21,10 +21,6 @@
   `(loop :repeat ,n :collect (progn ,@body)))
 
 
-(defun prefix-sums (sequence &aux (sum 0))
-  (map 'list (lambda (n) (incf sum n)) sequence))
-
-
 (defun emptyp (string)
   (zerop (length string)))
 
@@ -48,12 +44,19 @@
   (ensure-boolean (member character '(#\a #\e #\i #\o #\u
                                       #\A #\E #\I #\O #\U))))
 
+
+(defun prefix-sums (sequence &aux (sum 0))
+  (map 'list (lambda (n) (incf sum n)) sequence))
+
 (defun separate-with-spaces (list)
   (-<> list
     (split-sequence :. <>)
-    (mapcar (rcurry #'riffle " ") <>)
+    (mapcar (rcurry #'riffle #\Space) <>)
     (apply #'append <>)))
 
+(defun join-string (&rest parts)
+  (apply #'cat (mapcar #'princ-to-string parts)))
+
 
 ;;;; Weightlists --------------------------------------------------------------
 (defstruct (weightlist (:constructor %make-weightlist))
@@ -94,35 +97,6 @@
         :when (< n weight) :do (return item)))
 
 
-(defun build-weightlist-uniform (values)
-  (make-weightlist values (loop :for nil :in values :collect 1)))
-
-(defun build-weightlist-weighted (values)
-  (make-weightlist (mapcar #'second values)
-                   (mapcar #'first values)))
-
-(defun build-weightlist-zipf (values &key (exponent 1.0))
-  (loop
-    :with size = (length values)
-    :with denominator = (loop :for n :from 1.0 :to size
-                              :sum (/ (expt n exponent)))
-    :repeat size
-    :for rank :from 1
-    :for weight = (/ (/ (expt rank exponent))
-                     denominator)
-    :collect weight :into weights
-    :finally (return (make-weightlist values weights))))
-
-(defun build-weightlist (distribution-and-options values)
-  (destructuring-bind (distribution &rest options)
-      (ensure-list distribution-and-options)
-    (apply (ecase distribution
-             (:uniform #'build-weightlist-uniform)
-             (:weighted #'build-weightlist-weighted)
-             (:zipf #'build-weightlist-zipf))
-           values options)))
-
-
 ;;;; Data ---------------------------------------------------------------------
 (defun data-special-form-p (form)
   (ensure-boolean (and (consp form)
@@ -132,47 +106,98 @@
   '(satisfies data-special-form-p))
 
 
-(defun evaluate-sequence (seq)
-  (map (type-of seq) #'evaluate-expression seq))
+(defun compile-sequence (seq)
+  (let ((contents (map 'list #'compile-expression seq)))
+    (etypecase seq
+      (list `(list ,@contents)))))
 
-(defun evaluate-symbol (symbol)
-  (if (fboundp symbol)
-    (funcall symbol)
-    (symbol-value symbol)))
+(defun compile-symbol (symbol)
+  `(,symbol))
 
-(defun evaluate-lisp (expr)
-  (eval expr))
-
-(defun evaluate-data-special-form (expr)
+(defun compile-data-special-form (expr)
   (destructuring-bind (symbol argument) expr
     (ecase symbol
-      (quote argument)
-      (eval (evaluate-lisp argument)))))
-
+      (quote `(quote ,argument))
+      (eval argument))))
 
-(defun evaluate-expression (expr)
+(defun compile-expression (expr)
   (typecase expr
-    (non-keyword-symbol (evaluate-symbol expr))
-    (data-special-form (evaluate-data-special-form expr))
+    (null expr)
+    (non-keyword-symbol (compile-symbol expr))
+    (data-special-form (compile-data-special-form expr))
     (string expr)
-    (sequence (evaluate-sequence expr))
+    (sequence (compile-sequence expr))
     (t expr)))
 
 
-(defun build-define-rule (evaluator name-and-options expressions)
-  (destructuring-bind (name &key (distribution :uniform))
+(defun build-weightlist-weighted (size weights)
+  (make-weightlist (range 0 size) weights))
+
+(defun build-weightlist-zipf (size exponent)
+  (loop
+    :with denominator = (loop :for n :from 1.0 :to size
+                              :sum (/ (expt n exponent)))
+    :repeat size
+    :for rank :from 1
+    :for item :from 0
+    :for weight = (/ (/ (expt rank exponent))
+                     denominator)
+    :collect item :into items
+    :collect weight :into weights
+    :finally (return (make-weightlist items weights))))
+
+
+(defun compile-selector-uniform (expressions)
+  (values `(random ,(length expressions))
+          expressions))
+
+(defun compile-selector-weighted (expressions)
+  (values `(weightlist-random
+             ,(build-weightlist-weighted (length expressions)
+                                         (mapcar #'first expressions)))
+          (mapcar #'second expressions)))
+
+(defun compile-selector-zipf (expressions &key (exponent 1.0))
+  (values `(weightlist-random
+             ,(build-weightlist-zipf (length expressions) exponent))
+          expressions))
+
+(defun compile-selector (distribution-and-options expressions)
+  (destructuring-bind (distribution &rest options)
+      (ensure-list distribution-and-options)
+    (apply (ecase distribution
+             (:uniform #'compile-selector-uniform)
+             (:weighted #'compile-selector-weighted)
+             (:zipf #'compile-selector-zipf))
+           expressions
+           options)))
+
+
+(defun compile-define-rule (expression-compiler name-and-options expressions)
+  (destructuring-bind (name &key
+                            documentation
+                            (distribution :uniform)
+                            (arguments '()))
       (ensure-list name-and-options)
-    `(defun ,name ()
-       (,evaluator
-         (weightlist-random ,(build-weightlist distribution expressions))))))
+    `(defun ,name ,arguments
+       ,@(ensure-list documentation)
+       ,(if (= 1 (length expressions))
+         (funcall expression-compiler (first expressions))
+         (multiple-value-bind (selector expressions)
+             (compile-selector distribution expressions)
+           `(case ,selector
+              ,@(loop
+                 :for i :from 0
+                 :for expression :in expressions
+                 :collect `(,i ,(funcall expression-compiler expression)))))))))
 
 
 (defmacro define-rule (name-and-options &rest expressions)
-  (build-define-rule 'evaluate-expression name-and-options expressions))
+  (compile-define-rule #'compile-expression name-and-options expressions))
 
 (defmacro gen (expression)
   "Generate a single Chancery expression."
-  `(evaluate-expression ',expression))
+  (compile-expression expression))
 
 
 ;;;; Strings ------------------------------------------------------------------
@@ -184,39 +209,43 @@
   '(satisfies string-special-form-p))
 
 
-(defun evaluate-string-combination (list)
-  (-<> list
-    (separate-with-spaces <>)
-    (mapcar #'evaluate-string-expression <>)
-    (apply #'cat (mapcar #'princ-to-string <>))))
+(defun compile-string-combination (list)
+  (let ((contents (-<> list
+                    (separate-with-spaces <>)
+                    (mapcar #'compile-string-expression <>))))
+    `(join-string ,@contents)))
 
-(defun evaluate-string-modifiers (vector)
-  (reduce (flip #'funcall) vector
-          :start 1
-          :initial-value
-          (princ-to-string (evaluate-string-expression (aref vector 0)))))
+(defun compile-string-modifiers (vector)
+  (labels ((recur (modifiers)
+             (if (null modifiers)
+               (compile-expression (aref vector 0))
+               `(,(first modifiers)
+                 ,(recur (rest modifiers))))))
+    (recur (nreverse (coerce (subseq vector 1) 'list)))))
 
-(defun evaluate-string-sequence (sequence-type seq)
-  (map sequence-type #'evaluate-string-expression seq))
+(defun compile-string-sequence (sequence-type seq)
+  (let ((contents (map 'list #'compile-string-expression seq)))
+    (ecase sequence-type
+      (list `(list ,@contents)))))
 
-(defun evaluate-string-special-form (expr)
+(defun compile-string-special-form (expr)
   (destructuring-bind (symbol . body) expr
     (ecase symbol
-      (quote (first body))
-      (list (evaluate-string-sequence 'list body))
-      (vector (evaluate-string-sequence 'vector body))
-      (eval (evaluate-lisp (first body))))))
+      (quote `(quote ,(first body)))
+      (list (compile-string-sequence 'list body))
+      (vector (compile-string-sequence 'vector body))
+      (eval (first body)))))
 
 
-(defun evaluate-string-expression (expr)
-  (typecase expr
-    (string expr)
+(defun compile-string-expression (expression)
+  (typecase expression
+    (string expression)
     (null "")
-    (non-keyword-symbol (evaluate-symbol expr))
-    (string-special-form (evaluate-string-special-form expr))
-    (vector (evaluate-string-modifiers expr))
-    (cons (evaluate-string-combination expr))
-    (t expr)))
+    (non-keyword-symbol (compile-symbol expression))
+    (string-special-form (compile-string-special-form expression))
+    (vector (compile-string-modifiers expression))
+    (cons (compile-string-combination expression))
+    (t expression)))
 
 
 (defmacro define-string (name-and-options &rest expressions)
@@ -236,11 +265,11 @@
       (name \"went to the\" place :. \".\"))
 
   "
-  (build-define-rule 'evaluate-string-expression name-and-options expressions))
+  (compile-define-rule 'compile-string-expression name-and-options expressions))
 
 (defmacro gen-string (expression)
   "Generate a single Chancery string expression."
-  `(evaluate-string-expression ',expression))
+  (compile-string-expression expression))
 
 
 ;;;; Modifiers ----------------------------------------------------------------
diff -r e736ba397f2a -r ddcf7ddf78f6 src/readtable.lisp
--- a/src/readtable.lisp	Wed Jan 18 10:18:50 2017 +0000
+++ b/src/readtable.lisp	Wed Jan 18 18:04:41 2017 +0000
@@ -5,7 +5,23 @@
   (coerce (read-delimited-list #\] stream t) 'vector))
 
 
+(defun eval-reader (stream char)
+  (declare (ignore char))
+  `(eval ,(read stream t t t)))
+
+(defun gen-reader (stream char)
+  (declare (ignore char))
+  `(gen ,(read stream t t t)))
+
+(defun gen-string-reader (stream char)
+  (declare (ignore char))
+  `(gen-string ,(read stream t t t)))
+
+
 (named-readtables:defreadtable :chancery
   (:merge :standard)
+  (:macro-char #\$ #'gen-string-reader nil)
+  (:macro-char #\@ #'gen-reader nil)
+  (:macro-char #\! #'eval-reader nil)
   (:macro-char #\[ #'vector-reader t)
   (:macro-char #\] (get-macro-character #\) nil)))
diff -r e736ba397f2a -r ddcf7ddf78f6 vendor/make-quickutils.lisp
--- a/vendor/make-quickutils.lisp	Wed Jan 18 10:18:50 2017 +0000
+++ b/vendor/make-quickutils.lisp	Wed Jan 18 18:04:41 2017 +0000
@@ -8,6 +8,7 @@
                :ensure-boolean
                :ensure-list
                :flip
+               :range
                :rcurry
                :riffle
                :split-sequence
diff -r e736ba397f2a -r ddcf7ddf78f6 vendor/quickutils.lisp
--- a/vendor/quickutils.lisp	Wed Jan 18 10:18:50 2017 +0000
+++ b/vendor/quickutils.lisp	Wed Jan 18 18:04:41 2017 +0000
@@ -2,7 +2,7 @@
 ;;;; See http://quickutil.org for details.
 
 ;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:CURRY :ENSURE-BOOLEAN :ENSURE-LIST :FLIP :RCURRY :RIFFLE :SPLIT-SEQUENCE) :ensure-package T :package "CHANCERY.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:CURRY :ENSURE-BOOLEAN :ENSURE-LIST :FLIP :RANGE :RCURRY :RIFFLE :SPLIT-SEQUENCE) :ensure-package T :package "CHANCERY.QUICKUTILS")
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (unless (find-package "CHANCERY.QUICKUTILS")
@@ -15,7 +15,8 @@
 (when (boundp '*utilities*)
   (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
                                          :CURRY :ENSURE-BOOLEAN :ENSURE-LIST
-                                         :FLIP :RCURRY :RIFFLE :SPLIT-SEQUENCE))))
+                                         :FLIP :RANGE :RCURRY :RIFFLE
+                                         :SPLIT-SEQUENCE))))
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun make-gensym-list (length &optional (x "G"))
     "Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
@@ -78,6 +79,14 @@
         (funcall f x y)))
   
 
+  (defun range (start end &key (step 1) (key 'identity))
+    "Return the list of numbers `n` such that `start <= n < end` and
+`n = start + k*step` for suitable integers `k`. If a function `key` is
+provided, then apply it to each number."
+    (assert (<= start end))
+    (loop :for i :from start :below end :by step :collecting (funcall key i)))
+  
+
   (defun rcurry (function &rest arguments)
     "Returns a function that applies the arguments it is called
 with and `arguments` to `function`."
@@ -216,7 +225,7 @@
                             sequence start end count remove-empty-subseqs))))
   
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (export '(curry ensure-boolean ensure-list flip rcurry riffle split-sequence
-            split-sequence-if split-sequence-if-not)))
+  (export '(curry ensure-boolean ensure-list flip range rcurry riffle
+            split-sequence split-sequence-if split-sequence-if-not)))
 
 ;;;; END OF quickutils.lisp ;;;;