Skip to content

DRAFT: Transient vecs #2

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Draft
gefjon wants to merge 1 commit into
base: main
Choose a base branch
from
Draft

DRAFT: Transient vecs #2

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
226 changes: 224 additions & 2 deletions %simple-vector-utils.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,8 +1,19 @@
(uiop:define-package #:immutable/%simple-vector-utils
(:use :cl :iterate #:immutable/%generator)
(:import-from :alexandria
#:array-length #:array-index)
(:export #:sv-push-back #:sv-pop-back #:sv-retract #:sv-update-at #:sv-replace-at #:sv-insert-at #:sv-remove-at #:sv-2-other-index))
#:array-length #:array-index #:with-gensyms #:symbolicate)
(:export

#:sv-push-back
#:sv-pop-back
#:sv-retract
#:sv-update-at
#:sv-replace-at
#:sv-insert-at
#:sv-remove-at
#:sv-2-other-index

#:define-vector-struct))
(in-package #:immutable/%simple-vector-utils)

(declaim (ftype (function (simple-vector t) (values simple-vector &optional))
Expand Down Expand Up @@ -95,3 +106,214 @@
(defun sv-2-other-index (simple-vector index)
(svref simple-vector
(if (zerop index) 1 0)))

(defmacro define-vector-struct (name
(&key max-length
(ref nil ref-supplied-p)
(constructor nil ctor-supplied-p)
(conc-name (format nil "~a-" name))
((:length length-name) nil length-supplied-p)
(logical-index-to-true-index nil)
(logical-length-to-true-length nil))
&body slot-descriptors)
"Define a structured vector type with named slots followed by indexed elements.

Each of the SLOT-DESCRIPTORS may be either:
- A symbol SLOT-NAME.
- A list of the form (SLOT-NAME &key TYPE INITFORM).
If unsupplied, slots' types default to T, and their initforms to nil.

A accessor for each of the SLOT-DESCRIPTORS will be defined, named by concatenating CONC-NAME with the
SLOT-NAME, as per `defstruct'. `:read-only' slots are not supported; if you don't want to mutate the slots,
just don't mutate them.

NAME will be defined by `deftype' as an alias for `simple-vector'.

If MAX-LENGTH is supplied, it must be a literal integer. Instances will be restricted to containing at most
MAX-LENGTH indexed elements.

If REF is not nil, it will be defined as a function which accepts an instance and a zero-based index, and
returns the associated indexed element from the index. REF defaults to NAME-ref.

If LENGTH is not nil, it will be defined as a function which accepts an instance, and returns the number of
indexed elements. LENGTH defaults to NAME-length.

If CONSTRUCTOR is not nil, it will be defined as a function which accepts a keyword argument for each slot,
plus `:length', `:initial-element' and `:initial-contents'. `:length' is mandatory, and is the number of
indexed elements in the new instance. `:initial-element' and `:initial-contents' are mutually exclusive, but
neither is mandatory. `:initial-element', if supplied, is used to pre-populate each of the indexed
elements. `:initial-contents', if supplied, should be a `generator' which will yield at least `:length'
elements, which will be stored into the indexed elements.

If LOGICAL-INDEX-TO-TRUE-INDEX is supplied, it should be a symbol. It will be defined as a function which
transforms \"logical\" indices of the indexed elements, starting from zero, into \"true\" indices appropriate
for `svref' into the underlying vector.

LOGICAL-LENGTH-TO-TRUE-LENGTH is like LOGICAL-INDEX-TO-TRUE-INDEX, but with an inclusive rather than exclusive
upper bound. This is analogous to the difference between `alexandria:array-length' and
`alexandria:array-index'.

The constructor, length-function, ref-function, logical-index-to-true-index-function, and slot-accessors will
all be declared globally `inline'."
(flet ((make-name (&rest stuff)
(apply #'symbolicate conc-name stuff)))
(let* ((num-slots (length slot-descriptors))
(logical-length-type (make-name "LENGTH"))
(logical-index-type (make-name "INDEX"))
(max-logical-length (or max-length
(- array-dimension-limit num-slots)))
(max-logical-index (1- max-length))
(max-true-length (+ max-length num-slots))
(max-true-index (+ max-logical-index num-slots))

(ctor-name (if ctor-supplied-p
constructor
(symbolicate "MAKE-" name)))

(ref-name (if ref-supplied-p
ref
(symbolicate name "-REF")))

(length-name (if length-supplied-p
length-name
(symbolicate name "-LENGTH")))
(logical-index-to-true-index (or logical-index-to-true-index
(gensym "LOGICAL-INDEX-TO-TRUE-INDEX-")))
(logical-length-to-true-length (or logical-length-to-true-length
(gensym "LOGICAL-LENGTH-TO-TRUE-LENGTH-"))))

(with-gensyms (true-length-type
true-index-type
true-length-to-logical-length)
(labels ((slot-name (slot-descriptor)
(etypecase slot-descriptor
(symbol slot-descriptor)
(cons (first slot-descriptor))))

(slot-initarg (slot-descriptor)
(intern (string (slot-name slot-descriptor)) "KEYWORD"))

(slot-type (slot-descriptor)
(etypecase slot-descriptor
(symbol t)
(cons (getf (rest slot-descriptor) :type t))))

(slot-initform (slot-descriptor)
(etypecase slot-descriptor
(symbol nil)
(cons (getf (rest slot-descriptor) :initform))))

(slot-accessor-name (slot-descriptor)
(make-name (slot-name slot-descriptor)))

(define-accessor (slot-descriptor &aux (accessor-name (slot-accessor-name slot-descriptor)))
`(progn
(declaim (ftype (function (,name) (values ,(slot-type slot-descriptor) &optional))
,accessor-name)
(inline ,accessor-name))
(defun ,accessor-name (instance)
(svref instance ,(slot-position slot-descriptor)))

(declaim (ftype (function (,(slot-type slot-descriptor) ,name)
(values ,(slot-type slot-descriptor) &optional))
(setf ,accessor-name))
(inline (setf ,accessor-name)))
(defun (setf ,accessor-name) (new-value instance)
(setf (svref instance ,(slot-position slot-descriptor))
new-value))))

(slot-position (slot-descriptor)
(position slot-descriptor slot-descriptors :test #'eq))

(slot-kwarg-type (slot-descriptor)
`(,(slot-initarg slot-descriptor)
,(slot-type slot-descriptor)))

(slot-kw-arg (slot-descriptor)
`(,(slot-name slot-descriptor)
,(slot-initform slot-descriptor)))

(initialize-slot-form (slot-descriptor)
`(setf (,(slot-accessor-name slot-descriptor)
instance)
,(slot-name slot-descriptor))))
`(progn
(deftype ,name ()
'simple-vector)

(deftype ,logical-index-type ()
'(integer 0 ,max-logical-index))
(deftype ,logical-length-type ()
'(integer 0 ,max-logical-length))
(deftype ,true-index-type ()
'(integer ,num-slots ,max-true-index))
(deftype ,true-length-type ()
'(integer ,num-slots ,max-true-length))

(declaim (ftype (function (,logical-index-type) (values ,true-index-type &optional))
,logical-index-to-true-index)
(inline ,logical-index-to-true-index))
(defun ,logical-index-to-true-index (logical-index)
(+ logical-index ,num-slots))

(declaim (ftype (function (,logical-length-type) (values ,true-length-type &optional))
,logical-length-to-true-length)
(inline ,logical-length-to-true-length))
(defun ,logical-length-to-true-length (logical-length)
(+ logical-length ,num-slots))

(declaim (ftype (function (,true-length-type) (values ,logical-length-type &optional))
,true-length-to-logical-length)
(inline ,true-length-to-logical-length))
(defun ,true-length-to-logical-length (true-length)
(- true-length ,num-slots))

(declaim (ftype (function (,name) (values ,logical-length-type &optional))
,length-name)
(inline ,length-name))
(defun ,length-name (instance)
(,true-length-to-logical-length (length instance)))

,@(mapcar #'define-accessor slot-descriptors)

,@(when ctor-name
`((declaim (ftype (function (&key ,@(mapcar #'slot-kwarg-type slot-descriptors)
(:length ,logical-length-type)
(:initial-element t)
(:initial-contents (or null generator)))
(values ,name &optional))
,ctor-name)
(inline ,ctor-name))
(defun ,ctor-name (&key ,@(mapcar #'slot-kw-arg slot-descriptors)
(length (error ,(format nil "Must supply :LENGTH to ~a" ctor-name)))
(initial-element nil initial-element-p)
initial-contents)
(let* ((true-length (,logical-length-to-true-length length))
(instance (make-array true-length)))
,@(mapcar #'initialize-slot-form slot-descriptors)
(cond ((and initial-element-p initial-contents)
(error ,(format nil ":INITIAL-ELEMENT and :INITIAL-CONTENTS are mutually exclusive in ~a" ctor-name)))

(initial-element-p
(iter (declare (declare-variables))
(for (the fixnum idx) from ,num-slots below true-length)
(setf (svref instance idx) initial-element)))

(initial-contents
(iter (declare (declare-variables))
(for (the fixnum idx) from ,num-slots below true-length)
(setf (svref instance idx) (advance initial-contents)))))
instance))))

,@(when ref-name
`((declaim (ftype (function (,name ,logical-index-type) (values t &optional))
,ref-name)
(inline ,ref-name))
(defun ,ref-name (instance idx)
(svref instance (,logical-index-to-true-index idx)))

(declaim (ftype (function (t ,name ,logical-index-type) (values t &optional))
(setf ,ref-name))
(inline (setf ,ref-name)))
(defun (setf ,ref-name) (new-value instance idx)
(setf (svref instance (,logical-index-to-true-index idx)) new-value))))))))))
21 changes: 11 additions & 10 deletions test/vec.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -31,16 +31,17 @@ IN is an iterate keyword for iterating over SEQUENCE; IN for lists, IN-VECTOR fo

(defun is-body-balanced-and-length-in-elts (body height)
(if (zerop height)
(progn (is (typep body `(simple-vector ,vec::+branch-rate+))
(progn (is (typep body 'vec::full-node)
"Expected node of height zero to be a ~a but found ~a"
`(simple-vector ,vec::+branch-rate+)
'vec::full-node
body)
vec::+branch-rate+)
(progn
(is (typep body 'simple-vector))
(is (>= vec::+branch-rate+ (length body)))
(is (< 0 (length body)))
(iter (for child in-vector body)
(is (typep body 'vec::node))
(is (>= vec::+branch-rate+ (vec::node-length body)))
(is (< 0 (vec::node-length body)))
(iter (for idx below (vec::node-length body))
(for child = (vec::node-ref body idx))
(summing (is-body-balanced-and-length-in-elts child (1- height)))))))

(defun is-vec-valid (vec)
Expand All @@ -53,10 +54,10 @@ IN is an iterate keyword for iterating over SEQUENCE; IN for lists, IN-VECTOR fo
(is-body-balanced-and-length-in-elts body height)
0)))
(when tail
(is (typep tail 'simple-vector))
(is (>= vec::+branch-rate+ (length tail)))
(is (< 0 (length tail))))
(is (= length (+ found-body-length (length tail))))))
(is (typep tail 'vec::node))
(is (>= vec::+branch-rate+ (vec::node-length tail)))
(is (< 0 (vec::node-length tail))))
(is (= length (+ found-body-length (vec::tail-buf-length tail))))))
vec)

;;; testing round-trips between CL data structures and vecs
Expand Down
Loading