--- a/Makefile Sat Nov 05 19:36:53 2016 +0000
+++ b/Makefile Sun Nov 06 12:28:54 2016 +0000
@@ -1,4 +1,4 @@
-.PHONY: vendor
+.PHONY: vendor test test-sbcl test-ccl test-ecl test-abcl
# Vendor ----------------------------------------------------------------------
vendor/quickutils.lisp: vendor/make-quickutils.lisp
@@ -6,3 +6,22 @@
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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/cl-digraph.asd Sun Nov 06 12:28:54 2016 +0000
@@ -0,0 +1,35 @@
+(asdf:defsystem :cl-digraph
+ :name "digraph"
+ :description "Simple directed graphs for Common Lisp."
+
+ :author "Steve Losh <steve@stevelosh.com>"
+
+ :license "MIT/X11"
+ :version "1.0.0"
+
+ :depends-on ()
+
+ :serial t
+ :components ((:module "vendor" :serial t
+ :components ((:file "quickutils-package")
+ (:file "quickutils")))
+ (:file "package")
+ (:module "src" :serial t
+ :components ((:file "directed-graph")))))
+
+
+
+(asdf:defsystem #:digraph-test
+ :name "digraph-test"
+
+ :depends-on (#:1am)
+
+ :serial t
+ :components ((:file "package-test")
+ (:module "test"
+ :serial t
+ :components ((:file "tests"))))
+
+ :perform (asdf:test-op
+ (op system)
+ (uiop:symbol-call :digraph-test :run-tests)))
--- a/cl-directed-graph.asd Sat Nov 05 19:36:53 2016 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,18 +0,0 @@
-(asdf:defsystem :cl-digraph
- :name "digraph"
- :description "Simple directed graphs for Common Lisp."
-
- :author "Steve Losh <steve@stevelosh.com>"
-
- :license "MIT/X11"
- :version "1.0.0"
-
- :depends-on ()
-
- :serial t
- :components ((:module "vendor" :serial t
- :components ((:file "quickutils-package")
- (:file "quickutils")))
- (:file "package")
- (:module "src" :serial t
- :components ((:file "directed-graph")))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/package-test.lisp Sun Nov 06 12:28:54 2016 +0000
@@ -0,0 +1,7 @@
+(defpackage :digraph-test
+ (:use
+ :cl
+ :1am
+ :digraph)
+ (:export
+ :run-tests))
--- a/src/directed-graph.lisp Sat Nov 05 19:36:53 2016 +0000
+++ b/src/directed-graph.lisp Sun Nov 06 12:28:54 2016 +0000
@@ -1,16 +1,36 @@
(in-package :digraph)
+
+;;;; Utils --------------------------------------------------------------------
+(defun make-hash-table-portably (&key size test hash-function)
+ ;; Only try to pass :hash-function if we were given it, so we don't explode in
+ ;; implementations that don't support it.
+ ;;
+ ;; Also, use `apply` instead of a simple `if` because we don't want spurious
+ ;; compiler warnings... This is ugly.
+ (apply #'make-hash-table :test test :size size
+ (if hash-function
+ (list :hash-function hash-function)
+ '())))
+
+
;;;; Data ---------------------------------------------------------------------
(defclass digraph ()
((nodes :initarg :nodes :accessor digraph-nodes)
- (test :initarg :test :accessor digraph-test)))
+ (test :initarg :test :accessor digraph-test)
+ (hash-function :initarg :hash-function :accessor digraph-hash-function)))
-(defun make-digraph (&key (test #'eql) initial-vertices)
+(defun make-digraph (&key initial-vertices
+ (test #'eql)
+ (hash-function nil))
(let ((digraph (make-instance 'digraph
- :nodes (make-hash-table :test test
- :size (length initial-vertices))
- :test test)))
+ :nodes (make-hash-table-portably
+ :test test
+ :size (length initial-vertices)
+ :hash-function hash-function)
+ :test test
+ :hash-function hash-function)))
(mapc (curry #'insert-vertex digraph) initial-vertices)
digraph))
@@ -26,13 +46,6 @@
`(cdr (gethash ,object (digraph-nodes ,digraph))))
-(defun copy-digraph (digraph)
- ;; todo make this faster, but at least this works
- (let ((copy (make-digraph :test (digraph-test digraph)
- :initial-vertices (vertices digraph))))
- (do-edges (p s digraph) (insert-edge digraph p s))
- copy))
-
;;;; Basic API ----------------------------------------------------------------
(defun vertices (digraph)
@@ -109,10 +122,10 @@
:do (progn ,@body)))
(defmacro do-edges ((predecessor-symbol successor-symbol digraph) &body body)
- (with-gensyms (preds succs)
+ (with-gensyms (succs)
`(loop
:for ,predecessor-symbol :being :the hash-keys :of (digraph-nodes ,digraph)
- :using (hash-value (,preds . ,succs))
+ :using (hash-value (nil . ,succs))
:do (loop :for ,successor-symbol :in ,succs ; i miss u, iterate
:do (progn ,@body)))))
@@ -143,6 +156,14 @@
(digraph-nodes digraph))
(values))
+;;;; Copying ------------------------------------------------------------------
+(defun copy-digraph (digraph)
+ ;; todo make this faster, but at least this works
+ (let ((copy (make-digraph :test (digraph-test digraph)
+ :initial-vertices (vertices digraph))))
+ (do-edges (p s digraph) (insert-edge digraph p s))
+ copy))
+
;;;; Scratch ------------------------------------------------------------------
(defparameter *d* (make-digraph))
@@ -156,4 +177,4 @@
(remove-edge *d* 'a 'a)
(remove-vertex *d* 'a)
-(dump *d*)
+; (dump *d*)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/test/run.lisp Sun Nov 06 12:28:54 2016 +0000
@@ -0,0 +1,5 @@
+#+ecl (setf compiler:*user-cc-flags* "-Wno-shift-negative-value")
+
+(ql:quickload 'cl-digraph)
+(time (asdf:test-system 'cl-digraph))
+(quit)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/test/tests.lisp Sun Nov 06 12:28:54 2016 +0000
@@ -0,0 +1,9 @@
+(in-package :digraph-test)
+
+(defmacro define-test (name &body body)
+ `(test ,name
+ (let ((*package* ,*package*))
+ ,@body)))
+
+(defun run-tests ()
+ (1am:run))