Sequence viewer

view.lisp

(defpackage #:view
  (:use #:cl)
  (:export #:make-view #:adjust-view)
  (:export #:underlying #:offset #:stride)
  (:export #:vref))

;;;; I don't like displaced arrays.

(in-package #:view)

;;; Would be kind of nice to make this a struct, but then we can't
;;; make it a SEQUENCE. oops
(defclass view (sequence standard-object)
  ((%underlying :initarg :underlying :reader underlying)
   (%offset :initarg :offset :accessor %offset :reader offset)
   (%length :initarg :length :accessor %length :reader sequence:length)
   (%stride :initarg :stride :accessor %stride :reader stride)))

(defmethod print-object ((view view) stream)
  (print-unreadable-object (view stream :type t)
    (write (coerce view 'list) :stream stream)) ; foreshadowing!
  view)

(defun make-view (array length &key (offset 0) (stride 1))
  (check-type array array)
  (check-type length (integer 0))
  (check-type offset (integer 0))
  (check-type stride (integer 1))
  (make-instance 'view
    :underlying array :offset offset :stride stride :length length))

;;; make-sequence-like and adjust-sequence are deliberately unimplemented,
;;; since they don't really make any sense here

(defun adjust-view (view length
                    &key (offset (%offset view)) (stride (%stride view)))
  (setf (%length view) length
        (%offset view) offset
        (%stride view) stride)
  view)

(declaim (inline vref-index))
(defun vref-index (view index)
  "Compute a row major index into the underlying array for this index.
Result undefined if out of bounds."
  (+ (offset view) (* (stride view) index)))

(declaim (inline vref (setf vref)))
(defun vref (view index)
  (row-major-aref (underlying view) (vref-index view index)))
(defun (setf vref) (new view index)
  (setf (row-major-aref (underlying view) (vref-index view index)) new))

(defun vnext (sequence iterator from-end)
  (declare (ignore sequence from-end))
  (+ iterator 1))
(defun vprev (sequence iterator from-end)
  (declare (ignore sequence from-end))
  (- iterator 1))

(defun vindex (sequence iterator)
  (declare (ignore sequence))
  iterator)

(defun vendp (sequence iterator limit from-end)
  (declare (ignore sequence from-end))
  (= iterator limit))

(defmethod sequence:make-sequence-iterator ((sequence view)
                                            &key from-end (start 0) end)
  (when (null end) (setf end (sequence:length sequence)))
  (if from-end
      (values (1- end) (1- start) t
              #'vprev #'vendp #'vref #'(setf vref) #'vindex #'vindex)
      (values start end nil
              #'vnext #'vendp #'vref #'(setf vref) #'vindex #'vindex)))

;;;

;;; These shouldn't be required, but SBCL used to sometimes (bug #1855375)

(defmethod sequence:iterator-copy ((sequence view) iterator) iterator)
(defmethod sequence:iterator-index ((sequence view) iterator) iterator)
(defmethod sequence:iterator-element ((sequence view) iterator)
  (vref sequence iterator))
(defmethod (setf sequence:iterator-element) (new (sequence view) iterator)
  (setf (vref sequence iterator) new))
(defmethod sequence:iterator-step ((sequence view) iterator from-end)
  (if from-end (- iterator 1) (+ iterator 1)))

#|
Let's try it out.

(defvar *arr* (make-array '(3 2) :initial-contents '((0 1) (2 3) (4 5))))
*arr* => #2A((0 1) (2 3) (4 5))

;; Get a view into the second column.
(defvar *view* (make-view *arr* 3 :offset 1 :stride 2))
*view* => #<VIEW (1 3 5)>

(map 'list #'1+ *view*) => (2 4 6)
(map-into *view* #'1+ *view*)
*arr* => #2A((0 2) (2 4) (4 6))

(fill *view* 0)
*arr* => #2A((0 0) (2 0) (4 0))

;; Put it back to how we started
(replace *view* '(1 3 5))
*arr* => #2A((0 1) (2 3) (4 5))

;; Let's fuck up the first column instead.
(adjust-view *view* 3 :offset 0)
(fill *view* 17)
*arr* => #2A((17 1) (17 3) (17 5))
|#