# HG changeset patch # User Steve Losh # Date 1498224528 0 # Node ID d6aa232e6306f495ce8fbc6983d96496a459d627 # Parent 80ae10ef6b7e06ce08cad0c559a88b67702e940c Add `create-...` functions, clean up RNG system, add a test suite diff -r 80ae10ef6b7e -r d6aa232e6306 Makefile --- a/Makefile Tue Apr 04 16:15:23 2017 +0200 +++ b/Makefile Fri Jun 23 13:28:48 2017 +0000 @@ -10,6 +10,24 @@ vendor: vendor/quickutils.lisp +# Testing --------------------------------------------------------------------- +test: test-sbcl test-ccl test-ecl test-abcl + +test-sbcl: + echo; figlet -kf computer 'SBCL' | sed -Ee 's/ +$$//' | tr -s '\n' | lolcat --freq=0.25; echo + ros run -L sbcl --load test/run.lisp + +test-ccl: + echo; figlet -kf slant 'CCL' | sed -Ee 's/ +$$//' | tr -s '\n' | lolcat --freq=0.25; echo + ros run -L ccl-bin --load test/run.lisp + +test-ecl: + echo; figlet -kf roman 'ECL' | sed -Ee 's/ +$$//' | tr -s '\n' | lolcat --freq=0.25; echo + ros run -L ecl --load test/run.lisp + +test-abcl: + echo; figlet -kf broadway 'ABCL' | sed -Ee 's/ +$$//' | tr -s '\n' | lolcat --freq=0.25; echo + abcl --load test/run.lisp # Documentation --------------------------------------------------------------- $(apidocs): $(sourcefiles) diff -r 80ae10ef6b7e -r d6aa232e6306 chancery.asd --- a/chancery.asd Tue Apr 04 16:15:23 2017 +0200 +++ b/chancery.asd Fri Jun 23 13:28:48 2017 +0000 @@ -8,6 +8,8 @@ :depends-on (:named-readtables) + :in-order-to ((asdf:test-op (asdf:test-op :chancery.test))) + :serial t :components ((:module "vendor" :serial t :components ((:file "quickutils-package") diff -r 80ae10ef6b7e -r d6aa232e6306 chancery.test.asd --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/chancery.test.asd Fri Jun 23 13:28:48 2017 +0000 @@ -0,0 +1,18 @@ +(asdf:defsystem :chancery.test + :description "Test suite for Chancery" + + :author "Steve Losh " + :license "MIT" + + :depends-on (:chancery + :1am) + + :serial t + :components ((:file "package.test") + (:module "test" + :serial t + :components ((:file "tests")))) + + :perform (asdf:test-op + (op system) + (uiop:symbol-call :chancery.test :run-tests))) diff -r 80ae10ef6b7e -r d6aa232e6306 package.lisp --- a/package.lisp Tue Apr 04 16:15:23 2017 +0200 +++ b/package.lisp Fri Jun 23 13:28:48 2017 +0000 @@ -3,8 +3,12 @@ (:export :define-rule :define-string - :gen - :gen-string + + :create-rule + :create-string + + :generate + :generate-string :quote :eval @@ -16,4 +20,6 @@ :q :a :s - :pos)) + :pos + + :*random*)) diff -r 80ae10ef6b7e -r d6aa232e6306 package.test.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/package.test.lisp Fri Jun 23 13:28:48 2017 +0000 @@ -0,0 +1,4 @@ +(defpackage :chancery.test + (:use :cl :1am :chancery :chancery.quickutils) + (:export + :run-tests)) diff -r 80ae10ef6b7e -r d6aa232e6306 src/chancery.lisp --- a/src/chancery.lisp Tue Apr 04 16:15:23 2017 +0200 +++ b/src/chancery.lisp Fri Jun 23 13:28:48 2017 +0000 @@ -63,6 +63,13 @@ (apply #'cat (mapcar #'princ-to-string parts))) +;;;; RNG ---------------------------------------------------------------------- +(defparameter *random* #'random) + +(defun chancery-random (n) + (funcall *random* n)) + + ;;;; Weightlists -------------------------------------------------------------- (defstruct (weightlist (:constructor %make-weightlist)) weights sums items total) @@ -96,7 +103,7 @@ (defun weightlist-random (weightlist) "Return a random item from the weightlist, taking the weights into account." - (loop :with n = (random (weightlist-total weightlist)) + (loop :with n = (chancery-random (weightlist-total weightlist)) :for item :in (weightlist-items weightlist) :for weight :in (weightlist-sums weightlist) :when (< n weight) :do (return item))) @@ -153,7 +160,7 @@ (defun compile-selector-uniform (expressions) - (values `(random ,(length expressions)) + (values `(chancery-random ,(length expressions)) expressions)) (defun compile-selector-weighted (expressions) @@ -168,14 +175,14 @@ expressions)) (defun compile-selector (distribution-and-options expressions) - (destructuring-bind (distribution &rest options) + (destructuring-bind (distribution &rest distribution-options) (ensure-list distribution-and-options) (apply (ecase distribution (:uniform #'compile-selector-uniform) (:weighted #'compile-selector-weighted) (:zipf #'compile-selector-zipf)) expressions - options))) + distribution-options))) (defun compile-rule-body (expression-compiler expressions distribution) @@ -189,6 +196,7 @@ :for expression :in expressions :collect `(,i ,(funcall expression-compiler expression))))))) + (defun compile-define-rule (expression-compiler name-and-options expressions) (destructuring-bind (name &key documentation @@ -199,11 +207,27 @@ ,@(ensure-list documentation) ,(compile-rule-body expression-compiler expressions distribution)))) +(defun compile-create-rule (expression-compiler options expressions) + (destructuring-bind (&key documentation + (distribution :uniform) + (arguments '())) + options + (compile nil + `(lambda ,arguments + ,@(ensure-list documentation) + ,(compile-rule-body expression-compiler + expressions + distribution))))) + (defmacro define-rule (name-and-options &rest expressions) (compile-define-rule #'compile-expression name-and-options expressions)) -(defmacro gen (expression) +(defun create-rule (expressions &rest options) + (compile-create-rule #'compile-expression options expressions)) + + +(defmacro generate (expression) "Generate a single Chancery expression." (compile-expression expression)) @@ -232,9 +256,13 @@ (defmacro define-string (name-and-options &rest expressions) - (compile-define-rule 'compile-string-expression name-and-options expressions)) + (compile-define-rule #'compile-string-expression name-and-options expressions)) -(defmacro gen-string (expression) +(defun create-string (expressions &rest options) + (compile-create-rule #'compile-string-expression options expressions)) + + +(defmacro generate-string (expression) "Generate a single Chancery string expression." (compile-string-expression expression)) diff -r 80ae10ef6b7e -r d6aa232e6306 src/readtable.lisp --- a/src/readtable.lisp Tue Apr 04 16:15:23 2017 +0200 +++ b/src/readtable.lisp Fri Jun 23 13:28:48 2017 +0000 @@ -11,11 +11,11 @@ (defun gen-reader (stream char) (declare (ignore char)) - `(gen ,(read stream t t t))) + `(generate ,(read stream t t t))) (defun gen-string-reader (stream char) (declare (ignore char)) - `(gen-string ,(read stream t t t))) + `(generate-string ,(read stream t t t))) (named-readtables:defreadtable :chancery diff -r 80ae10ef6b7e -r d6aa232e6306 test/run.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/test/run.lisp Fri Jun 23 13:28:48 2017 +0000 @@ -0,0 +1,5 @@ +#+ecl (setf compiler:*user-cc-flags* "-Wno-shift-negative-value") + +(ql:quickload 'chancery) +(time (asdf:test-system 'chancery)) +(quit) diff -r 80ae10ef6b7e -r d6aa232e6306 test/tests.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/test/tests.lisp Fri Jun 23 13:28:48 2017 +0000 @@ -0,0 +1,75 @@ +(in-package :chancery.test) + + +;;;; Utils -------------------------------------------------------------------- +(defmacro define-test (name &body body) + `(test ,(symb 'test- name) + (let ((*package* ,*package*)) + ,@body))) + + +(defun run-tests () + (1am:run)) + + +(defun example-1 () + :example-1) + +(defun example-2 () + :example-2) + +(defun one () + 1) + + +(defparameter *choice* 0) + +(defun test-random (n) + (declare (ignore n)) + *choice*) + + +;;;; Tests -------------------------------------------------------------------- +(define-test rule-literals + (is (eql (funcall (create-rule '(:a))) :a)) + (is (eql (funcall (create-rule '(1))) 1)) + (is (string= (funcall (create-rule '("foo"))) "foo")) + (is (eql (funcall (create-rule '(nil))) nil))) + +(define-test rule-symbols + (is (eql (funcall (create-rule '(example-1))) :example-1)) + (is (eql (funcall (create-rule '(example-2))) :example-2))) + +(define-test rule-lists + (is (equal (funcall (create-rule '((:a 1 example-1)))) + '(:a 1 :example-1)))) + +(define-test rule-choices + (let ((*random* #'test-random)) + (let ((*choice* 0)) + (is (eql (funcall (create-rule '(:a :b :c))) :a))) + (let ((*choice* 1)) + (is (eql (funcall (create-rule '(:a :b :c))) :b))) + (let ((*choice* 2)) + (is (eql (funcall (create-rule '(:a :b :c))) :c))))) + +(define-test string-basics + (is (string= (funcall (create-string '("hello"))) "hello")) + (is (string= (funcall (create-string '(("hello")))) "hello")) + (is (string= (funcall (create-string '(("hello" "world")))) "hello world")) + (is (string= (funcall (create-string '(("hello" :. "world")))) "helloworld")) + (is (string= (funcall (create-string '(("hello" 1)))) "hello 1")) + (is (string= (funcall (create-string '(("hello" one)))) "hello 1"))) + + +(define-rule sample-rule + :foo) + +(define-string sample-string + ("Hello" sample-rule)) + +(define-test definition-macros + (is (eql (sample-rule) :foo)) + (is (string= (sample-string) "Hello FOO"))) + +;; (run-tests) diff -r 80ae10ef6b7e -r d6aa232e6306 vendor/make-quickutils.lisp --- a/vendor/make-quickutils.lisp Tue Apr 04 16:15:23 2017 +0200 +++ b/vendor/make-quickutils.lisp Fri Jun 23 13:28:48 2017 +0000 @@ -12,6 +12,7 @@ :rcurry :riffle :split-sequence + :symb ) :package "CHANCERY.QUICKUTILS") diff -r 80ae10ef6b7e -r d6aa232e6306 vendor/quickutils.lisp --- a/vendor/quickutils.lisp Tue Apr 04 16:15:23 2017 +0200 +++ b/vendor/quickutils.lisp Fri Jun 23 13:28:48 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 :RANGE :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 :SYMB) :ensure-package T :package "CHANCERY.QUICKUTILS") (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package "CHANCERY.QUICKUTILS") @@ -16,7 +16,7 @@ (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION :CURRY :ENSURE-BOOLEAN :ENSURE-LIST :FLIP :RANGE :RCURRY :RIFFLE - :SPLIT-SEQUENCE)))) + :SPLIT-SEQUENCE :MKSTR :SYMB)))) (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`, @@ -224,8 +224,25 @@ (position-if-not predicate sequence :start start :key key)) sequence start end count remove-empty-subseqs)))) + + (defun mkstr (&rest args) + "Receives any number of objects (string, symbol, keyword, char, number), extracts all printed representations, and concatenates them all into one string. + +Extracted from _On Lisp_, chapter 4." + (with-output-to-string (s) + (dolist (a args) (princ a s)))) + + + (defun symb (&rest args) + "Receives any number of objects, concatenates all into one string with `#'mkstr` and converts them to symbol. + +Extracted from _On Lisp_, chapter 4. + +See also: `symbolicate`" + (values (intern (apply #'mkstr args)))) + (eval-when (:compile-toplevel :load-toplevel :execute) (export '(curry ensure-boolean ensure-list flip range rcurry riffle - split-sequence split-sequence-if split-sequence-if-not))) + split-sequence split-sequence-if split-sequence-if-not symb))) ;;;; END OF quickutils.lisp ;;;;