d6aa232e6306

Add `create-...` functions, clean up RNG system, add a test suite
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Fri, 23 Jun 2017 13:28:48 +0000
parents 80ae10ef6b7e
children b006652f8a18
branches/tags (none)
files Makefile chancery.asd chancery.test.asd package.lisp package.test.lisp src/chancery.lisp src/readtable.lisp test/run.lisp test/tests.lisp vendor/make-quickutils.lisp vendor/quickutils.lisp

Changes

--- 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 ;;;;