We will now take a pity on the CPU and the memory. We excessively call
adjust-array and cons a new list for each written character. We'd
like to have arrays with a two-dimensional fill pointer instead and to
adjust the array only when it is too small.
Since we are at it, we'll make this array wrapper allow a conformal displacement. We'll sketch an implementation which introduces its own operators, but this could be an extension to Common Lisp, for instance Genera had such a feature.
Conformal displacement allows displacing an array into a slice of the another one (instead of simply offsetting the memory access). Consider the following example:
CL-USER> (defparameter *arr* (make-array '(16 16) :initial-element 0))
*ARR*
CL-USER> *arr*
#2A((0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))We can displace another array onto *arr*. To do that we need to
supply two argument :displaced-to and :displaced-index-offset, the
first argument is the source array and the second is the first element
of the source array at which our newly defined array starts. When we
modify the new array, then in reality the *arr* is modified.
CL-USER> (defparameter *displaced*
(make-array* '(4 4) :displaced-to *arr*
:displaced-index-offset '(4 4)))
*DISPLACED*
CL-USER> *displaced*
#2A((0 0 0 0) (0 0 0 0) (0 0 0 0) (0 0 0 0))
CL-USER> (loop for i from 0 below 4
do (loop for j from 0 below 4
do (setf (aref *displaced* i j) 1)))
NIL
CL-USER> *displaced*
#2A((1 1 1 1) (1 1 1 1) (1 1 1 1) (1 1 1 1))
CL-USER> *arr*
#2A((0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1)
(1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))Had *displaced* been a conformally displaced array, the result would
be far more intuitive, namely:
CL-USER> *arr*
#2A((0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 1 1 1 1 0 0 0 0 0 0 0 0)
(0 0 0 0 1 1 1 1 0 0 0 0 0 0 0 0)
(0 0 0 0 1 1 1 1 0 0 0 0 0 0 0 0)
(0 0 0 0 1 1 1 1 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))We can't portably extend existing array class, so we'll introduce a
wrapper. Create a file cd-array.lisp and add it to the system
definition (vconsole will depend on it). The class array* will
have three slots: start, fillp and array, which are counterparts
of displaced-index-offset, fill-pointer and displaced-to. The
array dimensions are determined by start and fillp.
(defclass array* ()
((array :initarg :array :accessor %array)
(start :initarg :start :accessor %start)
(fillp :initarg :fillp :accessor %fillp)))The class constructor will mimic the actual constructor for arrays and
will be named make-array*.
;;; Function works like MAKE-ARRAY except that it allows FILL-POINTER
;;; and DISPLACED-INDEX-OFFSET to be lists. In that case it creates a
;;; wrapper instance which is conformally displaced onto the array.
;;; When the fill pointer is specified, but no DISPLACED-TO, then we
;;; create an array of the requested size. Effective start and fillp
;;; are stored (that is valid subscripts of the destination array).
(defun make-array* (dimensions &rest args
&key
(element-type t)
initial-element
initial-contents
adjustable
fill-pointer
displaced-to
displaced-index-offset)
(declare (ignore element-type adjustable))
(when (and (atom displaced-index-offset)
(atom fill-pointer)
(not (typep displaced-to 'array*)))
(return-from make-array*
(apply #'cl:make-array dimensions args)))
(cond ((and (not displaced-to) displaced-index-offset)
(error "Can't specify ~s without ~s."
:displaced-index-offset :displaced-to))
((and displaced-to (or initial-element initial-contents))
(error "~s and ~s are mutually exclusive with ~s."
:initial-element :initial-contents :displaced-to))
((and (consp fill-pointer)
(/= (length fill-pointer) (length dimensions)))
(error "~s must have the same length as DIMENSIONS."
:fill-pointer))
((and (consp displaced-index-offset)
(/= (length displaced-index-offset) (length dimensions)))
(error "~s must have the same length as DIMENSIONS."
:displaced-index-offset)))
(let* ((rank (length dimensions))
(first (make-list rank :initial-element 0)))
(when (null displaced-to)
;; implies that D-I-O is NIL and that F-P is CONS
(remf args :fill-pointer)
(return-from make-array*
(make-instance 'array*
:array (apply #'cl:make-array dimensions args)
:start first
:fillp fill-pointer)))
;; Correct the FILL-POINTER and the DISPLACED-INDEX-OFFSET. Both
;; should be expressed in the destination array indexes.
(cond ((and (atom fill-pointer)
(atom displaced-index-offset))
(setf displaced-index-offset first)
(setf fill-pointer dimensions))
((atom fill-pointer)
(setf fill-pointer (mapcar #'+ displaced-index-offset dimensions)))
((atom displaced-index-offset)
(setf displaced-index-offset (mapcar #'- fill-pointer dimensions)))
(t
(setf fill-pointer (mapcar #'+ displaced-index-offset fill-pointer))))
;; Assert the indice correctness.
(if (every #'<=
first
displaced-index-offset
fill-pointer
(mapcar #'+ displaced-index-offset dimensions)
(array-dimensions* displaced-to))
(make-instance 'array*
:array displaced-to
:start displaced-index-offset
:fillp fill-pointer)
(error "Invalid FILL-POINTER or DISPLACED-INDEX-OFFSET specification."))))We still have a few essentials operator to implement. Each of them
will accept both cl:array and our own class as an argument. For
instance array-dimensions* looks like this:
(defun array-dimensions* (array)
(etypecase array
(cl:array
(cl:array-dimensions array))
(array*
(mapcar #'- (%fillp array) (%start array)))))Then we have a very important functions, that is aref* and its
setf variant. Both use the function get-real-subscripts.
(defun get-real-subscripts (array &rest subscripts)
(loop for sub in subscripts
for off in (%start array)
for flp in (%fillp array)
for ind = (+ sub off)
if (and (>= ind off) (< ind flp))
collect ind into subs
else
do (error "Invalid index.")
finally
(return subs)))
(defun aref* (array &rest subscripts)
(etypecase array
(cl:array
(apply #'cl:aref array subscripts))
(array*
(apply #'cl:aref
(%array array)
(apply #'get-real-subscripts array subscripts)))))
(defun (setf aref*) (new-value array &rest subscripts)
(etypecase array
(cl:array
(apply #'(setf cl:aref) new-value array subscripts))
(array*
(apply #'(setf aref*)
new-value
(%array array)
(apply #'get-real-subscripts array subscripts)))))The last function we will implement is adjust-array*. For real array
we will call the function cl:adjust-array, and for conformally
displaced arrays we will call make-array* with supplied arguments
and simply copy slots from the result.
(defun adjust-array* (array dimensions &rest args
&key
element-type
initial-element
initial-contents
fill-pointer
displaced-to
displaced-index-offset)
(declare (ignore element-type initial-element initial-contents)
(ignore fill-pointer displaced-to displaced-index-offset))
(etypecase array
(cl:array
(apply #'adjust-array array dimensions args))
(array*
(let ((arr (apply #'make-array* dimensions args)))
(setf (%array array) (%array arr)
(%start array) (%start arr)
(%fillp array) (%fillp arr)))
array)))Our implementation is not optimized and is slower than direct array
access. Moreover array* instances are not instances of the system
class cl:array (so we didn't bother to implement all array
operators, like array-displacement). Native implementation for
instance could create a hash function which translates a
row-major-index from the displaced array to its displaced-to array's
row-major-index. The hash function would be recreated when the
displaced-to array is adjusted. Since it is only a sketch, we'll
settle on what we have now.