forked from tpapp/cl-slice
-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathselect-dev.lisp
208 lines (169 loc) · 9.27 KB
/
select-dev.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-Lisp; Package: SELECT-DEV -*-
;;; Copyright (c) 2012 by Tamas K. Papp <[email protected]>
;;; Copyright (c) 2018-2020, 2024 by Symbolics Pte. Ltd. All rights reserved.
;;; SPDX-License-identifier: MS-PL
(in-package #:select-dev)
;;;
;;; Resolve selections into canonical representations
;;;
(defun canonical-singleton (index)
"Canonical representation of a singleton index (a nonnegative integer, which is a valid array index)."
(assert (typep index 'array-index))
index)
(defstruct canonical-range
"Canonical representation of a contiguous set of array indices from START (inclusive) to END (exclusive)."
(start nil :type array-index)
(end nil :type array-index))
(defun canonical-range (start end)
"Canonical representation of a contiguous set of array indices from START (inclusive) to END (exclusive)."
(assert (and (typep start 'array-index)
(typep end 'array-index)
(<= start end))); SN:20171101: Changing < to <= partially fixes item 3 of issue 3 in Papp's repository.
(make-canonical-range :start start :end end))
(defstruct canonical-sequence
"Canonical representation of a sequence of array indexes."
(vector nil :type (simple-array array-index (*))))
(defun canonical-sequence (sequence)
"Canonical representation of array indexes from canonical-sequence SEQUENCE.
May share structure. Vectors of the upgraded type of (SIMPLE-ARRAY ARRAY-INDEX (*)) are preferred
for efficiency, otherwise they are coerced."
(let ((vector (coerce sequence '(simple-array array-index (*)))))
(assert (and (plusp (length vector))
(every (lambda (index)
(typep index 'array-index))
vector)))
(make-canonical-sequence :vector vector)))
(defgeneric axis-dimension (axis)
(:documentation "Return the dimension of axis. Needs to be defined for non-integer axes."))
(defun select-reserved-symbol? (symbol)
"Test if SYMBOL has special semantics for SELECTION."
(or (eq symbol t) (eq symbol nil)))
(defgeneric canonical-representation (axis selection)
(:documentation "Canonical representation of SELECTION, given information in AXIS. The default methods use dimensions as AXIS.
Each selection needs to be resolved into a canonical representation, which is either a singleton, a range, or a sequence of subscripts. They should only be constructed with the corresponding CANONICAL-SINGLETION, CANONICAL-RANGE and CANONICAL-SEQUENCE functions.
@c(CANONICAL-REPRESENTATION) needs to ensure that the represented subscripts are valid for the axis.
Unless a specialized method is found, the dimension of the axis is queried with AXIS-DIMENSION and resolution is attempted using the latter. Methods that resolve symbols should test them with SELECT-RESERVED-SYMBOL? and use CALL-NEXT-METHOD.")
(:method (axis selection)
;; fallback: try to get dimension and proceed based that
(canonical-representation (axis-dimension axis) selection))
;;; TODO: Should canonical representations resolve to themselves unchecked?
(:method (axis (canonical-range canonical-range))
(declare (ignore axis)) ; Silence compiler warnings
canonical-range)
(:method (axis (canonical-sequence canonical-sequence))
(declare (ignore axis)) ; Silence compiler warnings
canonical-sequence)
;;; DSL for selections
(:method ((axis integer) (slice null))
(canonical-singleton axis))
(:method ((axis integer) (selection integer))
(canonical-singleton
(if (minusp selection)
(aprog1 (+ axis selection)
(assert (<= 0 it)))
(aprog1 selection
(assert (<= selection axis)))))) ; SN:20171104: Changing < to <= fixes item 2 of issue 3 in Papp's repository.
(:method (axis (selection sequence)) ;SN:20171130 Added ability to pass in lists too
(let+ (subscripts
((&flet collect (value)
(push value subscripts))))
(loop for s across (coerce selection 'vector)
do (aetypecase (canonical-representation axis s)
(array-index
(collect it))
(canonical-range
(loop for index
from (canonical-range-start it)
below (canonical-range-end it)
do (collect index)))
(canonical-sequence ;SN:20171209: Genera claims this clause can never be reached.
(map 'nil #'collect (canonical-sequence-vector it)))))
(canonical-sequence (nreverse subscripts))))
(:method ((axis integer) (selection (eql t)))
(canonical-range 0 axis))
(:method (axis (selection bit-vector))
(declare (ignore axis)) ; Silence compiler warnings
(canonical-sequence (loop for bit across selection
for index from 0
when (plusp bit) collect index))))
(defun canonical-representations (axes selections)
"Return the canonical representations of SELECTIONS given the corresponding AXES, checking for matching length."
(assert (length= axes selections)) ;SN:20171209: Genera claims this form will never be executed.
(mapcar #'canonical-representation axes selections))
;;;
;;; Iterating over selections
;;;
(defun singleton-representation? (representation)
"Test if a canonical REPRESENTATION is a singleton."
(integerp representation))
(defun all-singleton-representations? (representations)
"Test if all canonical representations are singletons."
(every #'singleton-representation? representations))
(defun representation-dimension (representation)
"Return the dimension of a canonical-representation, or NIL for singleton selections (they are dropped)."
(aetypecase representation
(array-index nil)
(canonical-range (- (canonical-range-end it) (canonical-range-start it)))
(canonical-sequence (length (canonical-sequence-vector it)))))
(defun representation-dimensions (representations)
"Return a list for the dimensions of canonical representations, dropping singletons."
(loop for r in representations
for d = (representation-dimension r)
when d collect d))
(defun representation-initial-value (representation)
"Initial value for iteration."
(aetypecase representation
(array-index it)
(canonical-range (canonical-range-start it))
(canonical-sequence (aref (canonical-sequence-vector it) 0))))
(defun representation-iterator (representation carry cons)
"Return a closure that sets the car of CONS to the next value each time it is called, resetting and calling CARRY when it reaches the end of its range."
(flet ((save (value)
(setf (car cons) value))
(carry ()
(funcall carry)))
(aetypecase representation
(array-index carry)
(canonical-range (let+ (((&structure-r/o canonical-range- start end) it)
(selection start))
(lambda ()
(let ((carry? (= (incf selection) end)))
(when carry?
(setf selection start))
(save selection)
(when carry?
(carry))))))
(canonical-sequence (let* ((vector (canonical-sequence-vector it))
(dimension (length vector))
(position 0))
(lambda ()
(when (= (incf position) dimension)
(setf position 0)
(carry))
(save (aref vector position))))))))
(defun row-major-setup (representations terminator)
"Return SUBSCRIPTS (a list) and ITERATOR (a closure, no arguments) that increments the contents of SUBSCRIPTS in row-major order. TERMINATOR is called when all subscripts have been visited."
(let ((iterator terminator)
(subscripts (mapcar #'representation-initial-value representations)))
(loop for r in representations
for cons on subscripts
do (setf iterator
(representation-iterator r iterator cons)))
(values subscripts iterator)))
(defun column-major-setup (representations terminator)
"Return SUBSCRIPTS (a list) and ITERATOR (a closure, no arguments) that increments the contents of SUBSCRIPTS in column-major order. TERMINATOR is called when all subscripts have been visited."
(let+ (((&values subscripts iterator)
(row-major-setup (reverse representations) terminator)))
(values (nreverse subscripts) iterator)))
(defmacro traverse-representations ((subscripts representations
&key index
(setup 'row-major-setup))
&body body)
"Loops over all possible subscripts in REPRESENTAITONS, making them available in SUBSCRIPTS during the execution of BODY. The iterator is constructed using the function SETUP (see for example ROW-MAJOR-SETUP). When INDEX is given, a variable with that name is provided, containing an index that counts iterations."
(with-unique-names (block-name next)
`(block ,block-name
(let+ (((&values ,subscripts ,next)
(,setup ,representations (lambda () (return-from ,block-name)))))
(loop ,@(when index `(for ,index from 0))
do ,@body
(funcall ,next))))))