# HG changeset patch # User Steve Losh # Date 1484571809 0 # Node ID 07621aaf57e27c52178db2c20726716a93aebbb6 # Parent 41f273df36731b9bb61237f12c626dd3adc39549 Add distributions diff -r 41f273df3673 -r 07621aaf57e2 examples/fantasy-weapons.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/examples/fantasy-weapons.lisp Mon Jan 16 13:03:29 2017 +0000 @@ -0,0 +1,41 @@ +(in-package :chancery) +(named-readtables:in-readtable :chancery) + +(define-rule (material :distribution (:zipf :exponent 0.7)) + :iron + :steel + :silver + :mithril + :meteoric-iron + :adamantine) + +(define-rule kind + :dagger + :short-sword + :long-sword + :axe + :mace + :hammer) + +(define-rule (bonus :distribution :zipf) + 1 2 3 4) + +(define-rule (monster :distribution :weighted) + (10 :goblin) + (5 :elf) + (5 :dwarf) + (1 :dragon)) + +(define-rule magic + (('+ bonus) material kind) + (material kind :of monster :slaying) + (:glowing material kind)) + +(define-rule vanilla + (material kind)) + +(define-rule (weapon :distribution :weighted) + (10 vanilla) + (2 magic)) + +(map nil #'print (gimme 40 (weapon))) diff -r 41f273df3673 -r 07621aaf57e2 examples/git-commands.lisp --- a/examples/git-commands.lisp Sat Jan 14 16:12:51 2017 +0000 +++ b/examples/git-commands.lisp Mon Jan 16 13:03:29 2017 +0000 @@ -67,6 +67,7 @@ "your .gitconfig" "the git man pages" "the git source code" + "the blockchain" "your home directory") (define-string location @@ -220,4 +221,7 @@ ("git" *command* options #\newline :. [description cap])))) -; (dotimes (_ 20) (princ (entry)) (terpri) (terpri)) +(defun p (s) + (format t "~A~2%" s)) + +; (map nil #'p (gimme 40 (entry))) diff -r 41f273df3673 -r 07621aaf57e2 src/chancery.lisp --- a/src/chancery.lisp Sat Jan 14 16:12:51 2017 +0000 +++ b/src/chancery.lisp Mon Jan 16 13:03:29 2017 +0000 @@ -1,6 +1,30 @@ (in-package :chancery) ;;;; Utils --------------------------------------------------------------------- +(deftype non-keyword-symbol () + '(and symbol (not keyword))) + + +(defmacro -<> (&rest forms) + ;; I am going to lose my fucking mind if I have to program lisp without + ;; a threading macro, but I don't want to add another dep to this library, so + ;; here we are. + (if (null forms) + '<> + `(let ((<> ,(first forms))) + (-<> ,@(rest forms))))) + +(defmacro assert-nonempty (place message) + `(assert (not (emptyp ,place)) (,place) ,message)) + +(defmacro gimme (n &body body) + `(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))) @@ -23,23 +47,6 @@ (defun vowelp (character) (ensure-boolean (member character '(#\a #\e #\i #\o #\u)))) -(defun random-elt (seq) - (elt seq (random (length seq)))) - - -(defmacro -<> (&rest forms) - ;; I am going to lose my fucking mind if I have to program lisp without - ;; a threading macro, but I don't want to add another dep to this library, so - ;; here we are. - (if (null forms) - '<> - `(let ((<> ,(first forms))) - (-<> ,@(rest forms))))) - -(defmacro assert-nonempty (place message) - `(assert (not (emptyp ,place)) (,place) ,message)) - - (defun separate-with-spaces (list) (-<> list (split-sequence :. <>) @@ -47,8 +54,65 @@ (apply #'append <>))) -(deftype non-keyword-symbol () - '(and symbol (not keyword))) +;;;; Weightlists -------------------------------------------------------------- +(defstruct (weightlist (:constructor %make-weightlist)) + weights sums items total) + +(defun make-weightlist (items weights) + "Make a weightlist of the given items and weights. + + Weights can be any `real` numbers. Weights of zero are fine, as long as at + least one of the weights is nonzero (otherwise there's nothing to choose). + + " + (%make-weightlist + :items items + :weights weights + :sums (prefix-sums weights) + :total (apply #'+ 0.0 weights))) + +(defun weightlist-random (weightlist) + "Return a random item from the weightlist, taking the weights into account." + (loop :with n = (random (weightlist-total weightlist)) + :for item :in (weightlist-items weightlist) + :for weight :in (weightlist-sums weightlist) + :when (< n weight) :do (return item))) + +(defmethod print-object ((wl weightlist) s) + (print-unreadable-object (wl s :type t) + (prin1 (mapcar #'list + (weightlist-weights wl) + (weightlist-items wl)) + s))) + + +(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 --------------------------------------------------------------------- @@ -87,10 +151,16 @@ (t expr))) -(defmacro define-rule (name &rest expressions) - `(defun ,name () - (evaluate-expression - (random-elt ,(coerce expressions 'vector))))) +(defun build-define-rule (evaluator name-and-options expressions) + (destructuring-bind (name &key (distribution :uniform)) + (ensure-list name-and-options) + `(defun ,name () + (,evaluator + (weightlist-random ,(build-weightlist distribution expressions)))))) + + +(defmacro define-rule (name-and-options &rest expressions) + (build-define-rule 'evaluate-expression name-and-options expressions)) (defmacro generate (expression) "Generate a single Chancery expression." @@ -141,7 +211,7 @@ (t expr))) -(defmacro define-string (name &rest expressions) +(defmacro define-string (name-and-options &rest expressions) "Define a Chancery string rule for the symbol `name`. Each expression in `expressions` can be any valid Chancery expression. When @@ -158,9 +228,7 @@ (name \"went to the\" place :. \".\")) " - `(defun ,name () - (evaluate-string-expression - (random-elt ,(coerce expressions 'vector))))) + (build-define-rule 'evaluate-string-expression name-and-options expressions)) (defmacro generate-string (expression) "Generate a single Chancery string expression." diff -r 41f273df3673 -r 07621aaf57e2 vendor/make-quickutils.lisp --- a/vendor/make-quickutils.lisp Sat Jan 14 16:12:51 2017 +0000 +++ b/vendor/make-quickutils.lisp Mon Jan 16 13:03:29 2017 +0000 @@ -6,6 +6,7 @@ :curry :ensure-boolean + :ensure-list :flip :rcurry :riffle diff -r 41f273df3673 -r 07621aaf57e2 vendor/quickutils.lisp --- a/vendor/quickutils.lisp Sat Jan 14 16:12:51 2017 +0000 +++ b/vendor/quickutils.lisp Mon Jan 16 13:03:29 2017 +0000 @@ -2,7 +2,7 @@ ;;;; See http://quickutil.org for details. ;;;; To regenerate: -;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:CURRY :ENSURE-BOOLEAN :FLIP :RCURRY :RIFFLE :SPLIT-SEQUENCE) :ensure-package T :package "CHANCERY.QUICKUTILS") +;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:CURRY :ENSURE-BOOLEAN :ENSURE-LIST :FLIP :RCURRY :RIFFLE :SPLIT-SEQUENCE) :ensure-package T :package "CHANCERY.QUICKUTILS") (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package "CHANCERY.QUICKUTILS") @@ -14,8 +14,8 @@ (when (boundp '*utilities*) (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION - :CURRY :ENSURE-BOOLEAN :FLIP :RCURRY - :RIFFLE :SPLIT-SEQUENCE)))) + :CURRY :ENSURE-BOOLEAN :ENSURE-LIST + :FLIP :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`, @@ -65,6 +65,13 @@ (and x t)) + (defun ensure-list (list) + "If `list` is a list, it is returned. Otherwise returns the list designated by `list`." + (if (listp list) + list + (list list))) + + (defun flip (f) "Return a function whose argument order of a binary function `f` is reversed." #'(lambda (y x) @@ -209,7 +216,7 @@ sequence start end count remove-empty-subseqs)))) (eval-when (:compile-toplevel :load-toplevel :execute) - (export '(curry ensure-boolean flip rcurry riffle split-sequence + (export '(curry ensure-boolean ensure-list flip rcurry riffle split-sequence split-sequence-if split-sequence-if-not))) ;;;; END OF quickutils.lisp ;;;;