--- a/bones-test.asd Thu May 12 18:52:30 2016 +0000
+++ b/bones-test.asd Fri May 13 20:00:52 2016 +0000
@@ -9,6 +9,7 @@
(:module "test"
:serial t
:components ((:file "bones")
+ (:file "circle")
(:file "paip")
(:file "wam")))))
--- a/bones.asd Thu May 12 18:52:30 2016 +0000
+++ b/bones.asd Fri May 13 20:00:52 2016 +0000
@@ -22,6 +22,7 @@
:serial t
:components ((:file "paip")
(:file "utils")
+ (:file "circle")
(:module "wam"
:serial t
:components ((:file "constants")
--- a/package-test.lisp Thu May 12 18:52:30 2016 +0000
+++ b/package-test.lisp Fri May 13 20:00:52 2016 +0000
@@ -27,3 +27,6 @@
#:facts
#:return-one
#:return-all))
+
+(defpackage #:bones-test.circle
+ (:use :cl :5am :bones.circle))
--- a/package.lisp Thu May 12 18:52:30 2016 +0000
+++ b/package.lisp Fri May 13 20:00:52 2016 +0000
@@ -13,12 +13,44 @@
#:topological-sort
#:push-if-new))
+(defpackage #:bones.circle
+ (:use #:cl #:defstar)
+ (:export
+ #:make-circle-with
+ #:make-empty-circle
+ #:circle-to-list
+ #:circle-prepend
+ #:circle-append
+ #:circle-forward
+ #:circle-backward
+ #:circle-value
+ #:circle-rotate
+ #:circle-nth
+ #:circle-insert-before
+ #:circle-insert-after
+ #:circle-sentinel-p
+ #:circle-empty-p
+ #:circle-remove
+ #:circle-backward-remove
+ #:circle-forward-remove
+ #:circle-replace
+ #:circle-backward-replace
+ #:circle-forward-replace
+ #:circle-splice
+ #:circle-backward-splice
+ #:circle-forward-splice
+ #:circle-insert-beginning
+ #:circle-insert-end
+ )
+ )
+
(defpackage #:bones.wam
(:use
#:cl
#:defstar
#:optima
#:cl-arrows
+ #:bones.circle
#:bones.quickutils
#:bones.utils)
(:import-from #:optima
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/circle.lisp Fri May 13 20:00:52 2016 +0000
@@ -0,0 +1,285 @@
+(in-package #:bones.circle)
+
+;;;; Circular, Doubly-Linked Lists
+;;; If you found this through a Google search or a link or something, turn back
+;;; now. You probably don't want this.
+;;;
+;;; When we're creating and optimizing the WAM instructions (before rendering
+;;; into bytecode) it would be really nice to have a data structure that
+;;; supports a few things:
+;;;
+;;; * O(1) appending (when building the initial list of instructions)
+;;; * O(n) forward traversal (when rendering and optimizing for `set_constant`)
+;;; * O(n) backward traversal (when optimizing for `unify_constant`)
+;;; * In-place removal/replacement, with the ability to choose "which side we
+;;; move to" after.
+;;;
+;;; That last one is tricky. We want to be able to remove/replace/splice
+;;; elements during a single traversal. For example, we want to perform the
+;;; following optimization for constants (taken from the WAM book erratum):
+;;;
+;;; unify_variable Xi -> unify_constant c
+;;; ...
+;;; get_structure c/0, Xi
+;;;
+;;; The nicest way to do this would be something like:
+;;;
+;;; 1. Iterate backward from end to start.
+;;; 2. When we see a `:get-structure-* CONSTANT LOCALREG` instruction:
+;;; A. Remove it in-place, so the next node will be processed on the next
+;;; iteration (remember, we're iterating backwards).
+;;; B. Search forward for the corresponding `:unify-variable` instruction and
+;;; replace it in-place with the `:unify-constant` instruction.
+;;;
+;;; Of course you could do all this with immutable data structures, but it'll be
+;;; pretty slow. And since one of the primary goals of this project is to be
+;;; fast, we don't want to do slow things.
+;;;
+;;; So instead we make our own data structure for the list of WAM instructions.
+;;; A "circle" is a circular, doubly-linked list, with a sentinel node to denote
+;;; the start/end of the list.
+;;;
+;;; TODO: explain further
+;;; TODO: docstrings below
+
+(defparameter *circle-sentinel* 'circle-sentinel)
+
+
+(declaim (inline circle-prev circle-value circle-next))
+
+(defstruct circle prev value next)
+
+
+(declaim (inline circle-tie))
+(defun* circle-tie ((c1 circle) (c2 circle))
+ (:returns :void)
+ (setf (circle-next c1) c2
+ (circle-prev c2) c1)
+ (values))
+
+
+(defun* make-empty-circle ()
+ (:returns circle)
+ "Create an empty circle.
+
+ It will still contain a sentinel.
+
+ "
+ (let ((circle (make-circle :value *circle-sentinel*)))
+ (setf (slot-value circle 'prev) circle
+ (slot-value circle 'next) circle)
+ circle))
+
+(defun* make-circle-with ((list list))
+ "Create a circle whose nodes contain the values in `list`."
+ (:returns circle)
+ (let ((sentinel (make-empty-circle)))
+ (loop :with prev = sentinel
+ :for value :in list
+ :for current = (make-circle :prev prev
+ :value value)
+ :do (setf (circle-next prev) current
+ prev current)
+ :finally (unless (null list)
+ (circle-tie current sentinel)))
+ sentinel))
+
+
+(defun* circle-sentinel-p ((circle circle))
+ (:returns boolean)
+ "Return whether this circle node is the sentinel."
+ (eql (circle-value circle) *circle-sentinel*))
+
+(defun* circle-empty-p ((circle circle))
+ (:returns boolean)
+ "Return whether this circle is empty."
+ (and (circle-sentinel-p circle)
+ (eql circle (circle-next circle))))
+
+
+(defun* circle-rotate ((circle circle) (n integer))
+ (:returns circle)
+ (cond
+ ((zerop n) circle)
+ ((> n 0) (circle-rotate (circle-next circle) (1- n)))
+ ((< n 0) (circle-rotate (circle-prev circle) (1+ n)))))
+
+(defun* circle-nth ((circle circle) (n integer))
+ (:returns circle)
+ (assert (circle-sentinel-p circle) ()
+ "Can only call circle-nth on the sentinel.")
+ (circle-rotate circle
+ (if (< n 0)
+ n
+ (1+ n))))
+
+
+(defun* circle-insert-before ((circle circle) value)
+ (:returns :void)
+ ;; L new old R
+ (let ((old circle)
+ (l (circle-prev circle))
+ ; (r (circle-next circle))
+ (new (make-circle :value value)))
+ (circle-tie l new)
+ (circle-tie new old))
+ (values))
+
+(defun* circle-insert-after ((circle circle) value)
+ (:returns :void)
+ ;; L old new R
+ (let ((old circle)
+ ; (l (circle-prev circle))
+ (r (circle-next circle))
+ (new (make-circle :value value)))
+ (circle-tie old new)
+ (circle-tie new r))
+ (values)
+ )
+
+
+(defun* circle-insert-beginning ((circle circle) value)
+ (:returns :void)
+ (assert (circle-sentinel-p circle) ()
+ "Can only insert-beginning at the sentinel.")
+ (circle-insert-after circle value))
+
+(defun* circle-insert-end ((circle circle) value)
+ (:returns :void)
+ (assert (circle-sentinel-p circle) ()
+ "Can only insert-end at the sentinel.")
+ (circle-insert-before circle value))
+
+
+(defun* circle-prepend ((circle circle) values)
+ (:returns :void)
+ (assert (circle-sentinel-p circle) ()
+ "Can only prepend to the sentinel.")
+ ;; S new-first ... new-last R
+ (if (null values)
+ circle
+ (let ((s circle)
+ (r (circle-next circle))
+ (new (make-circle-with values)))
+ (circle-tie s (circle-next new))
+ (circle-tie (circle-prev new) r)))
+ (values))
+
+(defun* circle-append ((circle circle) values)
+ (:returns :void)
+ (assert (circle-sentinel-p circle) ()
+ "Can only prepend to the sentinel.")
+ ;; L new-first ... new-last S
+ (if (null values)
+ circle
+ (let ((s circle)
+ (l (circle-prev circle))
+ (new (make-circle-with values)))
+ (circle-tie l (circle-next new))
+ (circle-tie (circle-prev new) s)))
+ (values))
+
+
+(defun* circle-forward ((circle circle))
+ (:returns (or circle null))
+ (let ((next (circle-next circle)))
+ (when (not (circle-sentinel-p next))
+ next)))
+
+(defun* circle-backward ((circle circle))
+ (:returns (or circle null))
+ (let ((prev (circle-prev circle)))
+ (when (not (circle-sentinel-p prev))
+ prev)))
+
+
+(defun* circle-remove ((circle circle))
+ (:returns :void)
+ ;; L rem R
+ (assert (not (circle-sentinel-p circle)) () "Cannot remove sentinel.")
+ (let ((l (circle-prev circle))
+ (r (circle-next circle)))
+ (circle-tie l r))
+ (values))
+
+(defun* circle-backward-remove ((circle circle))
+ (:returns (or circle null))
+ (prog1
+ (circle-backward circle)
+ (circle-remove circle)))
+
+(defun* circle-forward-remove ((circle circle))
+ (:returns (or circle null))
+ (prog1
+ (circle-forward circle)
+ (circle-remove circle)))
+
+
+(defun* circle-replace ((circle circle) value)
+ (:returns :void)
+ (assert (not (circle-sentinel-p circle)) ()
+ "Cannot replace sentinel.")
+ ;; L new R
+ (let ((l (circle-prev circle))
+ (r (circle-next circle))
+ (new (make-circle :value value)))
+ (circle-tie l new)
+ (circle-tie new r))
+ (values))
+
+(defun* circle-backward-replace ((circle circle) value)
+ (:returns (or circle null))
+ (prog1
+ (circle-backward circle)
+ (circle-replace circle value)))
+
+(defun* circle-forward-replace ((circle circle) value)
+ (:returns (or circle null))
+ (prog1
+ (circle-forward circle)
+ (circle-replace circle value)))
+
+
+(defun* circle-splice ((circle circle) values)
+ (:returns :void)
+ (if (null values)
+ (circle-remove circle)
+ (progn
+ (assert (not (circle-sentinel-p circle)) ()
+ "Cannot splice sentinel.")
+ ;; L new-first ... new-last R
+ (let ((l (circle-prev circle))
+ (r (circle-next circle))
+ (new (make-circle-with values)))
+ (circle-tie l (circle-next new))
+ (circle-tie (circle-prev new) r))))
+ (values))
+
+(defun* circle-backward-splice ((circle circle) values)
+ (:returns (or circle null))
+ (prog1
+ (circle-backward circle)
+ (circle-splice circle values)))
+
+(defun* circle-forward-splice ((circle circle) values)
+ (:returns (or circle null))
+ (prog1
+ (circle-forward circle)
+ (circle-splice circle values)))
+
+
+(defun* circle-to-list ((circle circle) &optional include-sentinel-p)
+ (:returns list)
+ (loop
+ :with node = circle
+ :when (or include-sentinel-p
+ (not (circle-sentinel-p node)))
+ :collect (circle-value node) :into results
+ :do (setf node (circle-next node))
+ :when (eql node circle) :do (return results)))
+
+
+(defmethod print-object ((object circle) stream)
+ (print-unreadable-object (object stream :type t :identity nil)
+ (format stream "~S" (subst '%%% *circle-sentinel* (circle-to-list object t)))))
+
--- a/src/utils.lisp Thu May 12 18:52:30 2016 +0000
+++ b/src/utils.lisp Fri May 13 20:00:52 2016 +0000
@@ -83,3 +83,5 @@
(remove minimal-element remaining-elements :test test)
(cons minimal-element result))))))
(reverse (recur constraints elements (list)))))
+
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/test/circle.lisp Fri May 13 20:00:52 2016 +0000
@@ -0,0 +1,305 @@
+(in-package #:bones-test.circle)
+
+(def-suite :bones.circle)
+(in-suite :bones.circle)
+
+(defmacro is-circle-contents (circle values)
+ `(is (equal ,values
+ (circle-to-list ,circle))))
+
+
+(test empty-circles
+ (is-true (circle-empty-p (make-empty-circle)))
+ (is-true (circle-empty-p (make-circle-with nil)))
+ (is-false (circle-empty-p (make-circle-with (list 1)))))
+
+(test make-circle-with
+ (is-circle-contents
+ (make-circle-with (list))
+ nil)
+ (is-circle-contents
+ (make-circle-with (list 1 2 3))
+ (list 1 2 3))
+ (is-circle-contents
+ (make-circle-with '(foo))
+ (list 'foo))
+ (is-circle-contents
+ (make-circle-with '((foo)))
+ (list (list 'foo))))
+
+
+(test prepending
+ (let ((c (make-empty-circle)))
+ (is-circle-contents c nil)
+
+ (circle-prepend c (list 1))
+ (is-circle-contents c '(1))
+
+ (circle-prepend c (list 2 3))
+ (is-circle-contents c '(2 3 1))
+
+ (circle-prepend c nil)
+ (is-circle-contents c '(2 3 1))))
+
+(test appending
+ (let ((c (make-empty-circle)))
+ (is-circle-contents c nil)
+
+ (circle-append c (list 1))
+ (is-circle-contents c '(1))
+
+ (circle-append c (list 2 3))
+ (is-circle-contents c '(1 2 3))
+
+ (circle-append c nil)
+ (is-circle-contents c '(1 2 3))))
+
+(test appending-and-prepending
+ (let ((c (make-empty-circle)))
+ (is-circle-contents c nil)
+
+ (circle-append c (list 1))
+ (is-circle-contents c '(1))
+
+ (circle-prepend c (list 'a 'b))
+ (is-circle-contents c '(a b 1))
+
+ (circle-append c (list 'p 'q))
+ (is-circle-contents c '(a b 1 p q))))
+
+
+(test forward
+ (let ((c (make-circle-with (list 1 2 3 4))))
+ (is (equal
+ '(1 2 3 4)
+ (loop :for node = (circle-forward c) :then (circle-forward node)
+ :while node
+ :collect (circle-value node))))))
+
+(test backward
+ (let ((c (make-circle-with (list 1 2 3 4))))
+ (is (equal
+ '(4 3 2 1)
+ (loop :for node = (circle-backward c) :then (circle-backward node)
+ :while node
+ :collect (circle-value node))))))
+
+
+(test rotate
+ (let ((c (make-circle-with (list 1 2 3 4))))
+ (is-circle-contents (circle-rotate c 0)
+ '(1 2 3 4))
+ (is-circle-contents (circle-rotate c 1)
+ '(1 2 3 4))
+ (is-circle-contents (circle-rotate c 2)
+ '(2 3 4 1))
+ (is-circle-contents (circle-rotate c 3)
+ '(3 4 1 2))
+ (is-circle-contents (circle-rotate c 4)
+ '(4 1 2 3))
+ (is-circle-contents (circle-rotate c 5)
+ '(1 2 3 4))
+ (is-circle-contents (circle-rotate c -1)
+ '(4 1 2 3))
+ (is-circle-contents (circle-rotate c -2)
+ '(3 4 1 2))
+ (is-circle-contents (circle-rotate c -3)
+ '(2 3 4 1))
+ (is-circle-contents (circle-rotate c -4)
+ '(1 2 3 4))
+ (is-circle-contents (circle-rotate (circle-rotate c 2) 0)
+ '(2 3 4 1))
+ (is-circle-contents (circle-rotate (circle-rotate c 2) 1)
+ '(3 4 1 2))
+ (is-circle-contents (circle-rotate (circle-rotate c 2) 2)
+ '(4 1 2 3))
+ (is-circle-contents (circle-rotate (circle-rotate c 2) -2)
+ '(1 2 3 4))
+ (is-circle-contents (circle-rotate (circle-rotate c 3) -1)
+ '(2 3 4 1))))
+
+(test nth
+ (let* ((data (list 'a 'b 'c 'd))
+ (c (make-circle-with data)))
+ (loop :for i :from 0 :below 4
+ :for v :in data
+ :do (is (eql v (circle-value (circle-nth c i)))))))
+
+
+(test insert-before
+ (let ((c (make-circle-with (list 1 2 3))))
+ (circle-insert-before c 'a)
+ (is-circle-contents c '(1 2 3 a))
+
+ (circle-insert-before (circle-nth c 0) 'b)
+ (is-circle-contents c '(b 1 2 3 a))
+
+ (circle-insert-before (circle-nth c 1) 'c)
+ (is-circle-contents c '(b c 1 2 3 a))
+
+ (circle-insert-before (circle-nth c 2) 'd)
+ (is-circle-contents c '(b c d 1 2 3 a))
+
+ (circle-insert-before (circle-nth c -1) 'e)
+ (is-circle-contents c '(b c d 1 2 3 e a))))
+
+(test insert-after
+ (let ((c (make-circle-with (list 1 2 3))))
+ (circle-insert-after c 'a)
+ (is-circle-contents c '(a 1 2 3))
+
+ (circle-insert-after (circle-nth c 0) 'b)
+ (is-circle-contents c '(a b 1 2 3))
+
+ (circle-insert-after (circle-nth c 1) 'c)
+ (is-circle-contents c '(a b c 1 2 3))
+
+ (circle-insert-after (circle-nth c 2) 'd)
+ (is-circle-contents c '(a b c d 1 2 3))
+
+ (circle-insert-after (circle-nth c -1) 'x)
+ (is-circle-contents c '(a b c d 1 2 3 x))))
+
+
+(test sentinel-p
+ (let ((c (make-circle-with (list 1 2 3))))
+ (is-true (circle-sentinel-p c))
+ (is-false (circle-sentinel-p (circle-nth c 0)))
+ (is-false (circle-sentinel-p (circle-nth c 1)))
+ (is-false (circle-sentinel-p (circle-nth c 2)))
+ (is-true (circle-sentinel-p (circle-nth c 3))))
+ (is-true (circle-sentinel-p (make-empty-circle)))
+ (is-true (circle-sentinel-p (circle-nth (make-empty-circle) 0)))
+ (is-true (circle-sentinel-p (circle-nth (make-empty-circle) -1))))
+
+
+(test remove
+ (let ((c (make-circle-with (list 1 2 3))))
+ (signals simple-error (circle-remove c))
+ (is-circle-contents c '(1 2 3))
+
+ (circle-remove (circle-nth c 0))
+ (is-circle-contents c '(2 3))
+
+ (circle-remove (circle-nth c 1))
+ (is-circle-contents c '(2))
+
+ (circle-remove (circle-nth c 0))
+ (is-circle-contents c '())))
+
+(test backward-remove
+ (let ((c (make-circle-with (list 1 2 3 4 5 6))))
+ (is-circle-contents c '(1 2 3 4 5 6))
+
+ (is-circle-contents (circle-backward-remove (circle-nth c 1))
+ '(1 3 4 5 6))
+
+ (is-false (circle-backward-remove (circle-nth c 0)))
+ (is-circle-contents c '(3 4 5 6))
+
+ (is-circle-contents (circle-backward-remove (circle-nth c -1))
+ '(5 3 4))
+
+ (is-circle-contents c '(3 4 5))))
+
+(test forward-remove
+ (let ((c (make-circle-with (list 1 2 3 4 5 6))))
+ (is-circle-contents c '(1 2 3 4 5 6))
+
+ (is-circle-contents (circle-forward-remove (circle-nth c 1))
+ '(3 4 5 6 1))
+
+ (is-false (circle-forward-remove (circle-nth c -1)))
+ (is-circle-contents c '(1 3 4 5))))
+
+
+(test replace
+ (let ((c (make-circle-with (list 1 2 3 4 5 6))))
+ (is-circle-contents c '(1 2 3 4 5 6))
+
+ (circle-replace (circle-nth c 0) 'foo)
+ (is-circle-contents c '(foo 2 3 4 5 6))
+
+ (circle-replace (circle-nth c 0) 'bar)
+ (is-circle-contents c '(bar 2 3 4 5 6))
+
+ (circle-replace (circle-nth c 1) 'a)
+ (is-circle-contents c '(bar a 3 4 5 6))
+
+ (circle-replace (circle-nth c 2) 'b)
+ (is-circle-contents c '(bar a b 4 5 6))
+
+ (circle-replace (circle-nth c -1) 'c)
+ (is-circle-contents c '(bar a b 4 5 c))))
+
+(test backward-replace
+ (let ((c (make-circle-with (list 1 2 3 4 5 6))))
+ (is-circle-contents c '(1 2 3 4 5 6))
+
+ (is-circle-contents (circle-backward-replace (circle-nth c 1) 'foo)
+ '(1 foo 3 4 5 6))
+
+ (is-circle-contents (circle-backward-replace (circle-nth c 1) 'bar)
+ '(1 bar 3 4 5 6))
+
+ (is-circle-contents (circle-backward-replace (circle-nth c 2) 'a)
+ '(bar a 4 5 6 1))
+
+ (is-false (circle-backward-replace (circle-nth c 0) 'dogs))
+ (is-circle-contents c '(dogs bar a 4 5 6))))
+
+(test forward-replace
+ (let ((c (make-circle-with (list 1 2 3 4 5 6))))
+ (is-circle-contents c '(1 2 3 4 5 6))
+
+ (is-circle-contents (circle-forward-replace (circle-nth c 1) 'foo)
+ '(3 4 5 6 1 foo))
+
+ (is-circle-contents (circle-forward-replace (circle-nth c 1) 'bar)
+ '(3 4 5 6 1 bar))
+
+ (is-false (circle-forward-replace (circle-nth c -1) 'cats))
+ (is-circle-contents c '(1 bar 3 4 5 cats))))
+
+
+(test splice
+ (let ((c (make-circle-with (list 1 2 3 4 5 6))))
+ (is-circle-contents c '(1 2 3 4 5 6))
+
+ (circle-splice (circle-nth c 0) (list 'a 'b))
+ (is-circle-contents c '(a b 2 3 4 5 6))
+
+ (circle-splice (circle-nth c 1) (list 'c))
+ (is-circle-contents c '(a c 2 3 4 5 6))
+
+ (circle-splice (circle-nth c -1) (list 'dogs 'cats))
+ (is-circle-contents c '(a c 2 3 4 5 dogs cats))
+
+ (circle-splice (circle-nth c 3) nil)
+ (is-circle-contents c '(a c 2 4 5 dogs cats))))
+
+(test backward-splice
+ (let ((c (make-circle-with (list 1 2 3 4 5 6))))
+ (is-circle-contents c '(1 2 3 4 5 6))
+
+ (is-circle-contents (circle-backward-splice (circle-nth c 2) '(a b))
+ '(2 a b 4 5 6 1))
+
+ (is-circle-contents (circle-backward-splice (circle-nth c -1) '())
+ '(5 1 2 a b 4))
+
+ (is-false (circle-backward-splice (circle-nth c 0) '(first second)))
+ (is-circle-contents c '(first second 2 a b 4 5))))
+
+(test forward-splice
+ (let ((c (make-circle-with (list 1 2 3 4 5 6))))
+ (is-circle-contents c '(1 2 3 4 5 6))
+
+ (is-circle-contents (circle-forward-splice (circle-nth c 0) '(a b))
+ '(2 3 4 5 6 a b))
+
+ (is-circle-contents (circle-forward-splice (circle-nth c 1) '())
+ '(2 3 4 5 6 a))
+
+ (is-false (circle-forward-splice (circle-nth c -1) '(last)))
+ (is-circle-contents c '(a 2 3 4 5 last))))
--- a/test/run.lisp Thu May 12 18:52:30 2016 +0000
+++ b/test/run.lisp Fri May 13 20:00:52 2016 +0000
@@ -10,8 +10,9 @@
(when (not (5am:results-status result))
(setf *passed* nil))))
-(test :bones)
-(test :bones.paip)
-(test :bones.wam)
+; (test :bones)
+; (test :bones.paip)
+; (test :bones.wam)
+(test :bones.circle)
(sb-ext:exit :code (if *passed* 0 1))