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