--- 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)
--- 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")
--- /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 <steve@stevelosh.com>"
+ :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)))
--- 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*))
--- /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))
--- 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))
--- 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
--- /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)
--- /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)
--- 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")
--- 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 ;;;;