# HG changeset patch # User Steve Losh # Date 1484265605 0 # Node ID 9a223fdf99287b42265bab42c09af6ae5bb18992 # Parent 37d2a6b3aaf0f0c66e40982d07ca8c080f328a5f Remove possibly-unneeded binding bullshit diff -r 37d2a6b3aaf0 -r 9a223fdf9928 docs/02-usage.markdown --- 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 -------- diff -r 37d2a6b3aaf0 -r 9a223fdf9928 examples/git-commands.lisp --- 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)) diff -r 37d2a6b3aaf0 -r 9a223fdf9928 examples/story.lisp --- 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%)))) diff -r 37d2a6b3aaf0 -r 9a223fdf9928 src/chancery.lisp --- 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) diff -r 37d2a6b3aaf0 -r 9a223fdf9928 vendor/make-quickutils.lisp --- 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 diff -r 37d2a6b3aaf0 -r 9a223fdf9928 vendor/quickutils.lisp --- 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)))