--- a/docs/02-usage.markdown Thu Jan 12 22:39:04 2017 +0000
+++ b/docs/02-usage.markdown Fri Jan 13 00:00:05 2017 +0000
@@ -19,5 +19,3 @@
Evaluation
----------
-Binding
--------
--- a/examples/git-commands.lisp Thu Jan 12 22:39:04 2017 +0000
+++ b/examples/git-commands.lisp Fri Jan 13 00:00:05 2017 +0000
@@ -169,9 +169,11 @@
("-" :. letter)
("-" :. letter [noun shellify string-upcase]))
+(defparameter *noun* nil)
+
(define-rule long-option%
- (bind ((noun [noun shellify]))
- ("--" :. noun :. "=<" :. noun :. ">"))
+ (eval (let ((*noun* (generate [noun shellify])))
+ (generate ("--" :. *noun* :. "=<" :. *noun* :. ">"))))
("--" :. action-verb)
("--" :. extremum)
("--only-" :. adjective)
@@ -197,24 +199,28 @@
(long-option short-options))
+(defparameter *command* nil)
+(defparameter *commanding* nil)
+
(define-rule 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]))
+ (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]))
+
+(defun entry ()
+ (destructuring-bind (*command* *commanding*) (action)
+ (generate
+ ("git" *command* options #\newline :. [description cap]))))
-(define-rule entry
- (bind (((command commanding) action))
- ("git" command options #\newline :. [description cap])))
-
-
+(dotimes (_ 20) (princ (entry)) (terpri) (terpri))
--- a/examples/story.lisp Thu Jan 12 22:39:04 2017 +0000
+++ b/examples/story.lisp Fri Jan 13 00:00:05 2017 +0000
@@ -1,92 +1,6 @@
(in-package :chancery)
(named-readtables:in-readtable :chancery)
-(define-rule name
- "arjun"
- "yuuma"
- "jess"
- "bob smith")
-
-(define-rule nature-noun
- "ocean"
- "mountain"
- "forest"
- "cloud"
- "river"
- "tree"
- "sky"
- "sea"
- "desert")
-
-(define-rule animal
- "unicorn"
- "raven"
- "turkey"
- "wallaby"
- "sparrow"
- "scorpion"
- "coyote"
- "eagle"
- "owl"
- "lizard"
- "zebra"
- "duck"
- "kitten")
-
-(define-rule color
- "orange"
- "blue"
- "white"
- "black"
- "grey"
- "purple"
- "indigo"
- "turquoise")
-
-(define-rule activity
- "running"
- "jumping"
- "flying"
- "carousing")
-
-(define-rule sentence
- ("The" color animal "of the" nature-noun "is called" [name cap-all q] :. ".")
- ("The" animal "was" activity "in the" [nature-noun s] :. ".")
- ([name cap-all pos] "favorite color is" color :. ".")
- ([nature-noun cap] "air is fresh.")
- ("The" [animal s] "were" activity "in the" nature-noun :. "."))
-
-
-(define-rule pronoun
- "he" "she")
-
-(define-rule posessive-pronoun
- "his" "her")
-
-(define-rule omen
- "good omen"
- "bad omen")
-
-
-(define-rule story%
- ("There once was" [color a] animal "named" hero :. "."
- cap-pro "journeyed to a distant" nature-noun "to find" [animal a] :. "."
- "On the way" pronoun "saw" (eval (+ 10 (random 10))) [animal s] activity :. "."
- hero "considered this to be a" omen :. ".")
- (bind ((victim animal))
- (hero "came upon a sick" victim :. "."
- cap-pro "touched the" victim "and" posessive-pronoun "wounds were healed.")))
-
-(define-rule story
- (bind* ((hero [name cap-all])
- (pronoun pronoun)
- (cap-pro [pronoun cap]))
- (story%)))
-
-; (iterate (repeat 30) (pr (sentence)))
-
-
-;;;; Pronoun agreement through binding
(defun pronoun (gender)
(case gender
(:female "she")
@@ -101,6 +15,11 @@
(:neuter "its")
(t "their")))
+
+(defparameter *name* nil)
+(defparameter *pronoun* nil)
+(defparameter *possessive* nil)
+
(define-rule hero
(list "freyja" :female)
(list "loki" :male)
@@ -113,14 +32,18 @@
(define-rule animal
"mouse" "squirrel" "beaver" "antelope" "rabbit" "elk")
-(define-rule story%
- ([name cap] "took up" posessive "mighty" weapon "and went forth."
- [pronoun cap] "slew the dragon and the people rejoiced.")
- ("Once upon a time there was" [animal a] "named" [name cap] :. "."
- [pronoun cap] "went to the village and was very happy."))
+(define-rule monster
+ "dragon" "kraken" "chimera")
-(define-rule story
- (bind* (((name gender) hero)
- (pronoun [gender pronoun])
- (posessive [gender posessive-pronoun]))
- (story%)))
+(define-rule story%
+ ([*name* cap] "took up" *possessive* "mighty" weapon "and went forth."
+ [*pronoun* cap] "slew the" monster "and the people rejoiced.")
+ ("Once upon a time there was" [animal a] "named" [*name* cap] :. "."
+ [*pronoun* cap] "went to the village and was very happy."))
+
+(defun story ()
+ (destructuring-bind (name gender) (hero)
+ (let ((*name* name)
+ (*pronoun* (pronoun gender))
+ (*possessive* (posessive-pronoun gender)))
+ (story%))))
--- a/src/chancery.lisp Thu Jan 12 22:39:04 2017 +0000
+++ b/src/chancery.lisp Fri Jan 13 00:00:05 2017 +0000
@@ -52,39 +52,6 @@
;;;; Guts ---------------------------------------------------------------------
-(defparameter *bindings* nil)
-
-
-(defun create-binding (binding)
- (destructuring-bind (target expr) binding
- (let ((value (evaluate-expression expr)))
- (etypecase target
- (non-keyword-symbol (list target value))
- (cons (loop :for symbol :in target
- :for val :in value
- :append (list symbol val)))))))
-
-(defun evaluate-bind (bindings expr)
- (let* ((new-bindings (mapcan (rcurry #'create-binding) bindings))
- (*bindings* (cons new-bindings *bindings*)))
- (evaluate-expression expr)))
-
-(defun evaluate-bind* (bindings expr)
- (destructuring-bind (binding . remaining-bindings) bindings
- (let ((*bindings* (cons (create-binding binding)
- *bindings*)))
- (if remaining-bindings
- (evaluate-bind* remaining-bindings expr)
- (evaluate-expression expr)))))
-
-(defun lookup-binding (symbol)
- (loop :for frame :in *bindings*
- :for value = (getf frame symbol 'not-found)
- :do (unless (eq value 'not-found)
- (return-from lookup-binding (values value t))))
- (values nil nil))
-
-
(defun evaluate-combination (list)
(-<> list
(separate-with-spaces <>)
@@ -97,12 +64,9 @@
:initial-value (evaluate-expression (aref vector 0))))
(defun evaluate-symbol (symbol)
- (multiple-value-bind (value found) (lookup-binding symbol)
- (if found
- value
- (if (fboundp symbol)
- (funcall symbol)
- (symbol-value symbol)))))
+ (if (fboundp symbol)
+ (funcall symbol)
+ (symbol-value symbol)))
(defun evaluate-lisp (expr)
(eval expr))
@@ -118,8 +82,6 @@
(vector (evaluate-modifiers expr))
(cons (case (first expr)
(quote (second expr))
- (bind (evaluate-bind (second expr) (cddr expr)))
- (bind* (evaluate-bind* (second expr) (cddr expr)))
(eval (evaluate-lisp (second expr)))
(list (evaluate-list (rest expr)))
(t (evaluate-combination expr))))
@@ -147,6 +109,9 @@
(evaluate-expression
(random-elt ,(coerce expressions 'vector)))))
+(defmacro generate (expression)
+ `(evaluate-expression ',expression))
+
;;;; Modifiers ----------------------------------------------------------------
(defun cap (string)
--- a/vendor/make-quickutils.lisp Thu Jan 12 22:39:04 2017 +0000
+++ b/vendor/make-quickutils.lisp Fri Jan 13 00:00:05 2017 +0000
@@ -4,6 +4,7 @@
"quickutils.lisp"
:utilities '(
+ :compose
:curry
:ensure-boolean
:ensure-gethash
--- a/vendor/quickutils.lisp Thu Jan 12 22:39:04 2017 +0000
+++ b/vendor/quickutils.lisp Fri Jan 13 00:00:05 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-GETHASH :ENSURE-LIST :FLIP :MKSTR :ONCE-ONLY :RCURRY :RIFFLE :SPLIT-SEQUENCE :SYMB :WITH-GENSYMS) :ensure-package T :package "CHANCERY.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :FLIP :MKSTR :ONCE-ONLY :RCURRY :RIFFLE :SPLIT-SEQUENCE :SYMB :WITH-GENSYMS) :ensure-package T :package "CHANCERY.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "CHANCERY.QUICKUTILS")
@@ -14,9 +14,10 @@
(when (boundp '*utilities*)
(setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
- :CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH
- :ENSURE-LIST :FLIP :MKSTR :ONCE-ONLY
- :RCURRY :RIFFLE :SPLIT-SEQUENCE :SYMB
+ :COMPOSE :CURRY :ENSURE-BOOLEAN
+ :ENSURE-GETHASH :ENSURE-LIST :FLIP
+ :MKSTR :ONCE-ONLY :RCURRY :RIFFLE
+ :SPLIT-SEQUENCE :SYMB
:STRING-DESIGNATOR :WITH-GENSYMS))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun make-gensym-list (length &optional (x "G"))
@@ -42,6 +43,35 @@
(fdefinition function-designator)))
) ; eval-when
+ (defun compose (function &rest more-functions)
+ "Returns a function composed of `function` and `more-functions` that applies its ;
+arguments to to each in turn, starting from the rightmost of `more-functions`,
+and then calling the next one with the primary value of the last."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (reduce (lambda (f g)
+ (let ((f (ensure-function f))
+ (g (ensure-function g)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ (funcall f (apply g arguments)))))
+ more-functions
+ :initial-value function))
+
+ (define-compiler-macro compose (function &rest more-functions)
+ (labels ((compose-1 (funs)
+ (if (cdr funs)
+ `(funcall ,(car funs) ,(compose-1 (cdr funs)))
+ `(apply ,(car funs) arguments))))
+ (let* ((args (cons function more-functions))
+ (funs (make-gensym-list (length args) "COMPOSE")))
+ `(let ,(loop for f in funs for arg in args
+ collect `(,f (ensure-function ,arg)))
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ ,(compose-1 funs))))))
+
+
(defun curry (function &rest arguments)
"Returns a function that applies `arguments` and the arguments
it is called with to `function`."
@@ -328,7 +358,7 @@
`(with-gensyms ,names ,@forms))
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(curry ensure-boolean ensure-gethash ensure-list flip mkstr
+ (export '(compose curry ensure-boolean ensure-gethash ensure-list flip mkstr
once-only rcurry riffle split-sequence split-sequence-if
split-sequence-if-not symb with-gensyms with-unique-names)))