Conformal array displacement
Tagged as lisp
Written on 2020-06-04 by Daniel 'jackdaniel' Kochmański
In Common Lisp it is possible to displace one array to another. This is a useful feature which allows reusing the same memory for different array shapes. On LispM it was possible to displace arrays conformally and treat array as a multi-dimensional object instead of a continuous memory block.
It is said that one array is worth thousand of strings. Let's illustrate the difference with an example:
ARRAY*> (defparameter *arr* (make-array '(8 8) :initial-element 0))
*ARR*
ARRAY*> *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))
ARRAY*> (defparameter *dis*
(make-array '(4 4)
:displaced-to *arr*
:displaced-index-offset
(array-row-major-index *arr* 2 2)))
*DIS*
ARRAY*> (loop for i from 0 below (array-total-size *dis*)
do (setf (row-major-aref *dis* i) 1))
NIL
ARRAY*> *arr*
#2A((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))Had the array *dis* been displaced conformally, the result would be
different:
ARRAY*> (defparameter *arr* (make-array '(8 8) :initial-element 0))
*ARR*
ARRAY*> (defparameter *dis*
(make-array '(4 4)
:displaced-to *arr*
:displaced-index-offset '(2 2)))
*DIS*
ARRAY*> (loop for i from 0 below (array-total-size *dis*)
do (setf (row-major-aref *dis* i) 1))
NIL
ARRAY*> *arr*
#2A((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 1 1 1 1 0 0)
(0 0 1 1 1 1 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))Such displacement is especially attractive when you want to model the API to return a particular slice of an array (for instance representing a screen). From that there is only one step further to add a multi-dimensional fill pointer. It serves the same purpose as for vectors. In this post I'll sketch a hack which implements something resembling arrays which are conformally displaced.
First I'll shadow array symbols which will be implemented. Package
meant for consumption is named eu.turtleware.hacks.array* while the
actual code is put in the package eu.turtleware.hacks.array*.implementation.
(defpackage #:eu.turtleware.hacks.array*
(:use)
(:export #:array*
;; Constructors
#:make-array #:adjust-array
;; Predicates
#:arrayp
#:array-in-bounds-p
#:adjustable-array-p
#:array-has-fill-pointer-p
;; Accessors
#:row-major-aref #:aref
;; Readers
#:array-dimensions #:array-dimension #:array-rank
#:array-element-type #:array-displacement
#:array-total-size #:array-row-major-index))
(defpackage #:eu.turtleware.hacks.array*.implementation
(:use #:cl #:eu.turtleware.hacks.array*)
(:shadowing-import-from #:eu.turtleware.hacks.array*
#:array*
;; Constructors
#:make-array #:adjust-array
;; Predicates
#:arrayp
#:array-in-bounds-p
#:adjustable-array-p
#:array-has-fill-pointer-p
;; Accessors
#:row-major-aref #:aref
;; Readers
#:array-dimensions #:array-dimension #:array-rank
#:array-element-type #:array-displacement
#:array-total-size #:array-row-major-index))
(in-package #:eu.turtleware.hacks.array*.implementation)I don't particularly care here about performance and consing in this implementation, because the conformal displacement should be implemented by Common Lisp vendors. They could leverage non-portable parts of the array implementation (i.e weak references to arrays which are displaced to the array). Most functions are generic and each will works for "real" arrays too.
array* is a wrapper which has four slots. array is the array to
which we displace to, start and fillp define a slice of the array,
and the flag inner indicates whether the array is not shared.
(defclass array* ()
((array :initarg :array :accessor %array)
(start :initarg :start :accessor %start)
(fillp :initarg :fillp :accessor %fillp)
(inner :initarg :inner :accessor %inner)))Some generic functions are very mundane. Macro define-wrapper is
defined for such cases.
(defmacro define-wrapper (name (array-var &rest args) &body body)
(let ((cl-name (find-symbol (symbol-name name) (find-package 'cl))))
`(defgeneric ,name (,array-var ,@args)
(:method ((,array-var cl:array) ,@args)
(,cl-name ,array-var ,@args))
(:method ((,array-var array*) ,@args)
,@body))))Predicates are straightforward. arrayp works on any object, the rest
works only for arrays.
(defgeneric arrayp (array)
(:method (array) nil)
(:method ((array cl:array)) t)
(:method ((array array*)) t))
(define-wrapper adjustable-array-p (array)
t)
(define-wrapper array-has-fill-pointer-p (array)
t)
(defgeneric array-in-bounds-p (array &rest subscripts)
(:method ((array cl:array) &rest subscripts)
(apply #'cl:array-in-bounds-p array subscripts))
(:method ((array array*) &rest subscripts)
(loop for start in (%start array)
for fillp in (%fillp array)
for len = (- fillp start)
for sub in subscripts
unless (typep sub `(integer 0 ,len))
do (return-from array-in-bounds-p nil)
finally (return t))))Readers are also trivial. array-displacement returns the third value
indicating the last index in the displaced-to array.
(define-wrapper array-element-type (array)
(array-element-type (%array array)))
(define-wrapper array-rank (array)
(length (%start array)))
(define-wrapper array-dimensions (array)
(mapcar #'- (%fillp array) (%start array)))
(define-wrapper array-dimension (array axis-number)
(- (nth (%fillp array) axis-number)
(nth (%start array) axis-number)))
(define-wrapper array-total-size (array)
(reduce #'* (array-dimensions array)))
(define-wrapper array-displacement (array)
(values (%array array)
(%start array)
(%fillp array)))Accessors are more tricky. For aref I'll define a helper function
get-real-subscripts which translates supplied subscripts to the
underlying array's 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)))Now implementing aref and (setf aref) is a matter of translating
subscripts and calling the function on a displaced-to array.
(defgeneric aref (array &rest subscripts)
(:method ((array cl:array) &rest subscripts)
(apply #'cl:aref array subscripts))
(:method ((array array*) &rest subscripts)
(apply #'cl:aref
(%array array)
(apply #'get-real-subscripts array subscripts))))
(defgeneric (setf aref) (new-value array &rest subscripts)
(:argument-precedence-order array new-value)
(:method (new-value (array cl:array) &rest subscripts)
(apply #'(setf cl:aref) new-value array subscripts))
(:method (new-value (array array*) &rest subscripts)
(apply #'(setf aref)
new-value
(%array array)
(apply #'get-real-subscripts array subscripts))))To access the array with the row major index a function which
reconstructs subscripts from the integer is necessary. A reverse
operation computes the row major index from subscripts and it is of
course array-row-major-index.
(defun row-major-index-to-subscripts (array index)
(loop with ind = index
with sub
for rem on (array-dimensions array)
do (multiple-value-setq (sub ind)
(truncate ind (reduce #'* (cdr rem))))
collect sub))
(defgeneric array-row-major-index (array &rest subscripts)
(:method ((array cl:array) &rest subscripts)
(apply #'cl:array-row-major-index array subscripts))
(:method ((array array*) &rest subscripts)
;; Q: Can we do better?; A: Of course we can!
;; Q: Why won't we?; A: Too much hassle!
(loop for rem on (array-dimensions array)
for sub in subscripts
summing (* sub (reduce #'* (cdr rem))))))Having row-major-index-to-subscripts implemented, accessors
row-major-aref and (setf row-major-aref) are easy:
(define-wrapper row-major-aref (array index)
(apply #'aref array (row-major-index-to-subscripts array index)))
(defgeneric (setf row-major-aref) (new-value array index)
(:argument-precedence-order array index new-value)
(:method (new-value (array cl:array) index)
(setf (cl:row-major-aref array index) new-value))
(:method (new-value (array array*) index)
(apply #'(setf aref) new-value array
(row-major-index-to-subscripts array index))))As noted before, I don't care about offsetting computations to compilation time. However if I did I could have made an interesting blunder (which can be avoided by the implementation made by a vendor): write a hash function which takes row major index of the array and returns row major index of the displaced-to array. That would make access faster. The problem is that when the displaced-to array is adjusted, the hash function may be invalid because array dimensions change and there is no portable way to detect that - each function would need to explicitly check the displaced-to array dimensions if they are the same as previously.
Now it is time to implement constructors make-array and
adjust-array. They are quite similar, especially when it comes to
validating parameters. The next three functions are utilities shared
by both. check-conformal-args validates arguments. Most notably it
checks whether displacement arguments have the same arity as the array
rank.
(defun check-conformal-args
(dimensions initial-element initial-contents
fill-pointer displaced-to displaced-index-offset)
(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))))Slots start and fillp are expressed as indexes of the displaced-to
array (usually fill-pointer is expressed in vector indexes). I use a
helper function to return lists for displaced-index-offset and
fill-pointer which are computed based on array dimensions. This
function assumes, that arguments are already validated with
check-conformal-args.
(defun fix-displacement (dimensions displaced-index-offset 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
(make-list (length dimensions) :initial-element 0))
(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))))
(values displaced-index-offset fill-pointer))The last function checks whether final indexes have valid order:
(defun check-indexes (dimensions displaced-index-offset fill-pointer)
(every #'<=
(make-list (length dimensions) :initial-element 0)
displaced-index-offset
fill-pointer
(mapcar #'+ displaced-index-offset dimensions)))make-array may construct three different objects:
- cl:array instance when there is no conformal displacement
- array* instance with
inner=Yfor multi-dimensional fill-pointer - array* instance with
inner=Nfor conformally displaced 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)))
(check-conformal-args dimensions initial-element initial-contents
fill-pointer displaced-to displaced-index-offset)
(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 (make-list (length dimensions) :initial-element 0)
:fillp fill-pointer
:inner t)))
(multiple-value-setq (displaced-index-offset fill-pointer)
(fix-displacement dimensions displaced-index-offset fill-pointer))
;; Assert the indice correctness.
(if (and (check-indexes dimensions displaced-index-offset fill-pointer)
(every #'<= fill-pointer (array-dimensions displaced-to)))
(make-instance 'array*
:array displaced-to
:start displaced-index-offset
:fillp fill-pointer
:inner nil)
(error "Invalid FILL-POINTER or DISPLACED-INDEX-OFFSET specification.")))adjust-array, unless called on cl:array (in which case it calls
cl:adjust-array), always preserves the array identity. When the
array is confromally displaced to another one (inner=NIL), or the
parameter displaced-to is not NIL, A new array is created with
make-array and slots are copied from the result.
Otherwise the displaced-to array is private, so it is possible to
adjust start and fillp. If the result does not fit in the
displaced-to array, it is adjusted too.
(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))
(etypecase array
(cl:array
(apply #'adjust-array array dimensions args))
(array*
(when (or (not (%inner array)) displaced-to)
(let ((arr (apply #'make-array array dimensions args)))
(if (typep arr 'array*)
(setf (%array array) (%array arr)
(%start array) (%start arr)
(%fillp array) (%fillp arr)
(%inner array) nil)
(setf (%array array) arr
(%start array) (make-list (length dimensions) :initial-element 0)
(%fillp array) (array-dimensions arr)
(%inner array) t))))
(check-conformal-args dimensions initial-element initial-contents
fill-pointer displaced-to displaced-index-offset)
(setf displaced-to (%inner array))
(multiple-value-setq (displaced-index-offset fill-pointer)
(fix-displacement dimensions displaced-index-offset fill-pointer))
;; Assert the indice correctness.
(unless (check-indexes dimensions displaced-index-offset fill-pointer)
(error "Invalid FILL-POINTER or DISPLACED-INDEX-OFFSET specification."))
(unless (every #'<= fill-pointer displaced-to)
(remf args fill-pointer)
(remf args displaced-index-offset)
(setf displaced-to (apply #'adjust-array displaced-to fill-pointer args)))
(setf (%array array) displaced-to
(%start array) displaced-index-offset
(%fillp array) fill-pointer)
array)))That's all. As noted before, this is a mere sketch, but works fairly
good. I've written it to incorporate in the charming-clim tutorial,
but I've decided to not complicate description too much. Still I think
that it is an interesting insight so I've decided to make it into a
separate post. In the future I'd like to incorporate this very cool
feature into the Embeddable Common Lisp.
If you feel like supporting me with my FLOSS contributions and blogging you may become my patron.