Deque object in Common Lisp


I created a library of functions to implement a deque structure in Common Lisp based on the one available in C++, plus a few Lisp-ian twists. The library is based on two objects: node, which implements a doubly linked list; and deque, which uses node to implement the actual deque.

The main deque operations are available, including push and pop on both ends, iterate, search, find (element or position of an element), and check-if-null. Individual elements of the deque are also setfable.

Here’s the beast.

;;;; Deque class


;;; Node class to create doubly linked lists
(defclass node ()
  ((content
    :initarg :content
    :accessor content)
   (prev
    :initform nil
    :accessor prev)
   (next
    :initform nil
    :accessor next)))

(defun make-node (content &key prev next)
  "Creates a new node, doubly linked to nodes prev and next. Returns the new node"
  (let ((n (make-instance 'node :content content)))
    (if prev (setf (next prev) n (prev n) prev))
    (if next (setf (prev next) n (next n) next))
    (values n)))

(defun copy-node (node)
  "Returns a copy of node"
  (make-node (content node) :prev (prev node) :next (next node)))

(defun bind-nodes (a b)
  "Bind nodes a and b, placing a after b"
  (setf (next a) b (prev b) a))

(defmethod print-object ((obj node) stream)
  "Prints a node object and its content. Output has the format:

<NODE content sole|first|middle|last>

  The descriptors mean:
  
  * sole   - the node is not linked to other nodes
  * first  - the node is the first in a list
  * middle - the node is in the middle of a list
  * last   - the node is the last in a list" 
  (print-unreadable-object (obj stream :type t)
    (with-accessors ((content content)
                     (next next)
                     (prev prev))
        obj
      (format stream "~a ~:(~:(sole~;first~)~;~:(last~;middle~)~)" content prev next))))

(defun print-list (lst &key from-end)  
  "Prints out the items of a linked list in separate lines"
  (let ((direction (if from-end 'prev 'next)))
    (loop for i = lst then (slot-value i direction)
          while i do (pprint i))))

(defmacro do-linked-list ((var lst &key from-end) &body body)
  (let ((i (gensym)))
    "Iterates over lst in either direction"
    `(loop for ,i = ,lst
           then (,(if from-end 'prev 'next) ,i)
           while ,i
           do (let ((,var (content ,i))) (progn ,@body)))))

(defun make-linked-list (lst)
  "Creates a doubly linked list from a common list. Returns
pointers to the first and last elements in the list and the
number of nodes in the list."
  (if lst 
      (loop with 1st = (make-node (car lst))
            for i in lst
            for j = 1st then (make-node i :prev j)
            counting t into n
            finally (return (values 1st j n)))
      (values nil nil 0)))


;;; Deque class

(defclass deque ()
  ((element-count
    :initarg :element-count
    :accessor element-count)
   (first-element
    :initform nil
    :accessor first-element)
   (last-element
    :initform nil
    :accessor last-element)))

(defmethod print-object ((obj deque) stream)
    "Prints a deque object. Output has the format:

<DEQUE :elements <element-count> :contents (first ... last)>"
    (print-unreadable-object (obj stream :type t)    
      (with-accessors ((first first-element)
                       (last last-element)
                       (c element-count)
                       (p pointer))
          obj
        (format stream "~(empty~:;:elements ~:*~d :content ~:*(~(~;~a~;~a ~a~:;~a ... ~a~))~)"
                c
                (if first (content first))
                (if last (content last))))))


(defun make-deque (&optional lst)
  "Constructor for deque object. Takes a list as argument and returns a deque
with the same elements in order."
  (multiple-value-bind (first last n)
      (make-linked-list lst)
    (let ((d (make-instance 'deque :element-count n)))
      (setf (first-element d) first
            (last-element d) last)
      (values d))))


;;; Ancillary functions for pop and append functions
(declaim (inline add-first-element remove-single-element))

(defmethod add-first-element ((obj deque) element)
  "Adds one element to an empty deque"
  (let ((new-node (make-node element)))
    (setf (element-count obj) 1
          (first-element obj) new-node 
          (last-element obj) new-node)))

(defmethod remove-single-element ((obj deque))
  "Empties a deque containing one element"
  (setf (element-count obj) 0
        (first-element obj) nil
        (last-element obj) nil))

(defmethod empty-deque-p ((obj deque))
  "Tests whether a deque is empty"
  (zerop (element-count obj)))

(defmethod append-element ((obj deque) element)
  "Add one element to the end of a deque. Return the enlarged deque."
  (if (empty-deque-p obj)
      (add-first-element obj element)
      (progn (make-node element :prev (last-element obj))
             (incf (element-count obj))
             (setf (last-element obj)
                   (next (last-element obj)))))
  (values obj))


;;; Functions for appending, prepending and removing elements from
;;; either end of the deque.
(defmethod prepend-element ((obj deque) element)
  "Add one element to the start of a deque. Return the enlarged deque."
  (if (zerop (element-count obj))
      (add-first-element obj element)
      (progn (make-node element :next (first-element obj))
             (incf (element-count obj))
             (setf (first-element obj)
                    (prev (first-element obj)))))
  (values obj))


(defmethod pop-last ((obj deque))
  "Remove one element from the end of a deque. Return the shortened deque."
  (let ((result (unless (zerop (element-count obj))
                  (content (last-element obj)))))
    (case (element-count obj)
      (0
       (values nil nil))
      (1
       (remove-single-element obj)
       (values result t))
      (otherwise
       (setf (last-element obj) (prev (last-element obj))
             (next (last-element obj)) nil)
       (decf (element-count obj))
       (values result t)))))

(defmethod pop-first ((obj deque))
  "Remove one element from the start of a deque. Return the shortened deque."
  (let ((result (unless (zerop (element-count obj))
                  (content (first-element obj)))))
    (case (element-count obj)
      (0
       (values nil nil))
      (1
       (remove-single-element obj)
       (values result t))
      (otherwise
       (setf (first-element obj) (next (first-element obj))
             (prev (first-element obj)) nil)
       (decf (element-count obj))
       (values result t)))))

(defmethod insert-element ((obj deque) content position)
  "Inserts an element containing 'content' in position 'position' (zero offset).
Returns the resulting deque."
  (cond ((zerop position)
         (prepend-element obj content))
        ((= position (element-count obj))
           (append-element obj content))
        (t
         (loop repeat position
               for j = (first-element obj) then (next j)
               finally (progn (make-node content :prev j :next (next j))
                              (incf (element-count obj))))))
  (values obj))

(defmethod nth-element ((obj deque) n &key from-end  &aux (c (element-count obj)))
  "Returns the nth element of a deque. If from-end is non-nil, returns the nth element before last."
  (assert (<= n c)
          ()
          "Index out of range. Position ~d requested, but deque has only ~d elements" n c)
  (loop with d = (if from-end 'prev 'next)
        repeat (1+ n)
        for k = (slot-value obj (if from-end 'last-element 'first-element))
        then (slot-value k d)
        finally (return (content k))))

(defmethod change-nth-element ((obj deque) pos value &key from-end &aux (c (element-count obj)))
  "Changes the value of the 'pos' element in a deque to 'value'.
If 'from-end' is T, the deque is traversed in reverse order."
  (assert (<= pos c)
          ()
          "Index out of range. Position ~d requested, but deque has only ~d elements" pos c)
  (loop with d = (if from-end 'prev 'next)
        repeat (1+ pos)
        for k = (slot-value obj (if from-end 'last-element 'first-element))
        then (slot-value k d)
        finally (return (setf (content k) value))))

(define-setf-expander nth-element (obj n &key from-end)
  "Makes individual elements of a deque setf-able using the change-nth-element function."
  (let ((input (gensym)))
    (values '()
            '()
            `(,input)
            `(progn (change-nth-element ,obj ,n ,input :from-end ,from-end) ,input)
            `(nth-element obj pos &key from-end))))


(defmacro do-deque ((var deque &key from-end) &body body)
  "Executes the closure 'body' for each element of a deque. If from-end is t,
iterates over the deque in reverse order."
  `(do-linked-list (,var 
                    ,@(if from-end `((last-element ,deque) :from-end t)
                          `((first-element ,deque))))
     ,@body))

(defmethod find-element ((obj deque) element)
  "Finds the first occurrence of element in a deque, scanning it from
start to end. Returns the element if successful, nil otherwise"
  (let ((i (first-element obj)))
    (block nil
      (tagbody
       ::loop
         (if (eq (content i) element) (return-from nil (content i)))
         (setf i (next i))
         (if (null i) (return-from nil nil))
         (go ::loop)))))


(defmethod find-element-pos ((obj deque) element)
  "Finds the position of element in a deque, scanning it from start to end.
Returns the element if successful, nil otherwise"
  (let ((i (first-element obj)) (pos 0))
    (block nil
      (tagbody
       ::loop
         (if (eq (content i) element) (return-from nil pos))
         (setf i (next i) pos (1+ pos))
         (if (null i) (return-from nil nil))
         (go ::loop)))))

Test cases

Create a deque from a list

CL-USER> (defvar v (make-deque '(1 2 3 4 5 6)))
V

deque and node have their own print-methods.

CL-USER> v
#<DEQUE :elements 6 :content (1 ... 6)>
CL-USER> (make-node 0)
#<NODE 0 sole>

Append and prepend elements

CL-USER> (append-element v 7)
#<DEQUE :elements 7 :content (1 ... 7)>
CL-USER> (prepend-element v 0)
#<DEQUE :elements 8 :content (0 ... 7)>

Pop first or last element. In both cases, the second value indicates whether an element was removed. pop-first and pop-last will return Nil Nil if the deque is empty.

CL-USER> (pop-first v)
0
T
CL-USER> v
#<DEQUE :elements 7 :content (1 ... 7)>
CL-USER> (pop-last v)
7
T
CL-USER> v
#<DEQUE :elements 6 :content (1 ... 6)>

Iterate over a deque (in either direction)

CL-USER> (do-deque (p v) (format t "~d~%" p))
1
2
3
4
5
6
NIL
CL-USER> (do-deque (p v :from-end t) (format t "~d~%" p))
6
5
4
3
2
1
NIL

Random access to elements (from either direction, like in standard functions position or find)

CL-USER> (nth-element v 0)
1
CL-USER> (nth-element v 0 :from-end t)
6

Individual elements are setfable.

CL-USER> (setf (nth-element v 0) 1000) => #(1000 2 3 4 5 6)
1000
CL-USER> (setf (nth-element v 0 :from-end t) 6000) => #(1000 2 3 4 5 6000)
6000

Simplified versions of find and position are also implemented.

CL-USER> (find-element v 2)
2
CL-USER> (find-element v 6000)
6000
CL-USER> (find-element-pos v 2)
1

This library is a work in progress, but the basic functionality is up and running. I intend to add some more bells and whistles and then wrap everything up in a package.

Any feedback is appreciated.

Thanks,