Coverage report: /development/source/library/org/datagraph/spocq-shard/src/store/field.lisp

KindCoveredAll%
expression216405 53.3
branch1834 52.9
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.datagraph.spocq.implementation; -*-
2
 
3
 (in-package :org.datagraph.spocq.implementation)
4
 
5
 (:documentation "fields"
6
   "data manipulation for solution fields")
7
 
8
 ;;; 
9
 
10
 (defun term-number-statements (repository-handle quad-or-triple-data &key (skolemize (skolemize-insertions-p)) (context nil))
11
   "Project a field of symbolic terms into one which is expressed in term numbers.
12
  Handle special cases which cannot appear in the store:
13
  - preclude null terms,
14
  - map wildcard graph terms to their true term numbers
15
  - permit statements as either tagged
16
      (quad s p o c)
17
      (triple s p o)
18
    or as match results
19
      (c s p o)
20
  "
21
 
22
   (let* ((graphs ())
23
          (quads ())
24
          (triples ())
25
          (cspos ())
26
          (node-map ()))
27
     (labels ((map-node (node)
28
                (rest (or (assoc node node-map)
29
                          (first (push (cons node (cons-global-blank-node))
30
                                       node-map)))))
31
              (map-term (term)
32
                (case term
33
                  ((nil :undef) (error "term-number-statements: invalid term: ~s." term))
34
                  (|urn:dydra|:|all| *true-all-context-term-number*)
35
                  (|urn:dydra|:|default| *true-default-context-term-number*)
36
                  (|urn:dydra|:|named| *true-named-context-term-number*)
37
                  (t (cond ((undistinguished-variable-p term)
38
                            (repository-object-term-number repository-handle (map-node term)))
39
                           ((spocq:blank-node-p term)
40
                            (if skolemize
41
                              (repository-object-term-number repository-handle (map-node term))
42
                              (repository-object-term-number repository-handle term)))
43
                           (term
44
                            (repository-object-term-number repository-handle term))
45
                           (t
46
                            (error "Invalid term: ~s." term)))))))
47
       (let ((default-graph-id (when context (map-term context) #xffffffff)))
48
         (flet ((intern-triples (triples) ;; as quads _or_ triples
49
                  (if context
50
                      (let ((field (make-page (length triples) 4)))
51
                        (loop for statement in triples
52
                          for (s p o) = (triple-terms statement)
53
                          for index from 0
54
                          do (setf (aref field index 0) (map-term s)
55
                                   (aref field index 1) (map-term p)
56
                                   (aref field index 2) (map-term o)
57
                                   (aref field index 2) default-graph-id))
58
                        field)
59
                      (let ((field (make-page (length triples) 3)))
60
                        (loop for statement in triples
61
                          for (s p o) = (triple-terms statement)
62
                          for index from 0
63
                          do (setf (aref field index 0) (map-term s)
64
                                   (aref field index 1) (map-term p)
65
                                   (aref field index 2) (map-term o)))
66
                        field)))
67
                (intern-cspos (cspos)
68
                  (let ((field (make-page (length cspos) 4)))
69
                    (loop for statement in cspos
70
                      for (c s p o) = (quad-terms statement)
71
                      for index from 0
72
                      ;;!!!  rdf 1.1 intends to allow blank nodes for graph terms
73
                      ;;!!!  a. optionally skolemize
74
                      ;;!!!  b. exclude other than iri and blank node
75
                      do (progn (setf (aref field index 0) (map-term s)
76
                                      (aref field index 1) (map-term p)
77
                                      (aref field index 2) (map-term o)
78
                                      ;; don't map, as no blank node allowed, but allow for truncated quad
79
                                      (aref field index 3) (repository-context-term-number repository-handle c))))
80
                    field))
81
                (intern-quads (quads)
82
                  (let ((field (make-page (length quads) 4)))
83
                    (loop for statement in quads
84
                      for (s p o c) = (quad-terms statement)
85
                      for index from 0
86
                      do (progn (setf (aref field index 0) (map-term s)
87
                                      (aref field index 1) (map-term p)
88
                                      (aref field index 2) (map-term o)
89
                                      ;; don't map, as no blank node allowed, but allow for truncated quad
90
                                      (aref field index 3) (repository-context-term-number repository-handle c))))
91
                    field))
92
                (intern-graph (form)
93
                  (destructuring-bind (graph triples) (rest form)
94
                    (let ((field (make-page (length triples) 4))
95
                          ;; no blank node allowed
96
                          (graph-id (repository-object-term-number repository-handle graph)))
97
                      (loop for statement in triples
98
                        for (s p o) = (triple-terms statement)
99
                        for index from 0
100
                        ;; place in the same order an sexp-quad
101
                        do (setf (aref field index 0) (map-term s)
102
                                 (aref field index 1) (map-term p)
103
                                 (aref field index 2) (map-term o)
104
                                 (aref field index 3) graph-id))
105
                      field))))
106
           (if (graph-form-p quad-or-triple-data)
107
               (push quad-or-triple-data graphs)
108
               (dolist (expression quad-or-triple-data)
109
                 (cond ((graph-form-p expression)
110
                        (push expression graphs))
111
                       ((triple-form-p expression)
112
                        (push expression triples))
113
                       ((quad-form-p expression)
114
                        (push expression quads))
115
                       ((consp expression)
116
                        (push expression cspos))
117
                       (t
118
                        (error "Invalid statement: ~s." expression)))))
119
           (let ((interned (append (when triples (list (intern-triples (reverse triples))))
120
                                   (when quads (list (intern-quads (reverse quads))))
121
                                   (when cspos (list (intern-cspos (reverse cspos))))
122
                                   (mapcar #'intern-graph (reverse graphs)))))
123
             (values (if (rest interned)
124
                         (coerce interned 'vector)
125
                         (first interned))
126
                     node-map)))))))
127
 
128
 (defmethod intern-quad-or-triple-data ((repository rdfcache-repository) quad-or-triple-data &rest args)
129
   (declare (dynamic-extent args))
130
   (apply #'term-number-statements repository quad-or-triple-data args))
131
 
132
 (defmethod repository-intern-statements ((repository rdfcache-repository) quad-or-triple-data &rest args)
133
   (declare (dynamic-extent args))
134
   (apply #'term-number-statements repository quad-or-triple-data args))
135
 
136
 (defmethod repository-intern-statements ((transaction rdfcache-transaction) quad-or-triple-data &rest args)
137
   (declare (dynamic-extent args))
138
   (apply #'term-number-statements transaction quad-or-triple-data args))
139
 
140
 (defun term-number-field (solution-data &key (skolemize (skolemize-insertions-p))
141
                                             (field-length (length solution-data))
142
                                             (field-width (length (first solution-data)))
143
                                             (field (make-page field-length field-width))
144
                                             (context nil))
145
   (let* ((node-map ())
146
          ;; if no transaction is present, just the persistent terms will bind
147
          (context-id (context-term-number context)))
148
     (labels ((map-node (node)
149
                (rest (or (assoc node node-map)
150
                          (first (push (cons node (cons-global-blank-node))
151
                                       node-map)))))
152
              (map-term (term)
153
                (cond ((member term '(nil :undef))
154
                       0)
155
                      ((undistinguished-variable-p term)
156
                       (object-term-number (map-node term)))
157
                      ((spocq:blank-node-p term)
158
                       (if skolemize
159
                         (object-term-number (map-node term))
160
                         (object-term-number term)))
161
                      (t
162
                       (object-term-number term)))))
163
       
164
       (loop for solution in solution-data
165
             for solution-index from 0
166
             do (loop for term in solution
167
                  for term-index from 0 below field-width
168
                  do (setf (aref field solution-index term-index)
169
                           (map-term term))
170
                  finally (case term-index
171
                            (3 )  ;; already a quad
172
                            (2 ;; augment triple with default graph id
173
                             (when (= field-width 4)
174
                               (setf (aref field solution-index term-index) context-id))))))
175
       field)))
176
 
177
 (defgeneric term-value-field (solution-data)
178
   (:documentation "Transform a term-number matrix/array into the object-solution field,
179
    that is a list of solutions")
180
   (:method ((solution-data array))
181
     (let* ((field-length (array-dimension solution-data 0))
182
            (field-width (array-dimension solution-data 1)))
183
       (loop for solution-index from 0 below field-length
184
           collect (loop for term-index from 0 below field-width
185
                     collect (term-number-object (aref solution-data solution-index term-index))))))
186
   (:method ((datum integer))
187
     (term-number-object datum))
188
 
189
   (:method ((datum t)) datum)
190
 
191
   #+sbcl
192
   (:method ((matrix sb-sys:system-area-pointer))
193
     (let ((numeric-field (rdfcache:matrix-to-list matrix)))
194
       (term-value-field (make-array (list (length numeric-field) (length (first numeric-field)))
195
                                      :initial-contents numeric-field))))
196
 
197
   (:method ((datum matrix-field))
198
     (let ((solutions (solution-field-solutions datum)))
199
       (unless (cffi:null-pointer-p solutions)
200
         (let ((numeric-field (subseq (rdfcache:matrix-to-list solutions)
201
                                      0 (solution-field-row-count datum))))
202
           (term-value-field (make-array (list (length numeric-field) (length (first numeric-field)))
203
                                              :initial-contents numeric-field))))))
204
 
205
   (:method ((generator solution-generator))
206
     (let ((channel (abstract-field-generator-channel generator))
207
           (dimensions (abstract-field-generator-dimensions generator))
208
           (results ()))
209
       (do-pages (page channel)
210
                 (push (term-value-field page) results))
211
       (values (reduce #'nconc (nreverse results) :from-end t)
212
               dimensions))))
213
 
214
 
215
 
216
 (defun transaction-intern-shuffeled-field (transaction solution-data from-dimensions to-dimensions &key (skolemize (skolemize-insertions-p))
217
                                                       (from-field-width (length (first solution-data)))
218
                                                       (to-field-width (length to-dimensions))
219
                                                       (field (make-page (length solution-data) to-field-width))
220
                                                       (partial nil))
221
   (assert (or partial (null (set-exclusive-or from-dimensions to-dimensions))) ()
222
           "invalid shuffle dimensions ~a -> ~a" from-dimensions to-dimensions)
223
   (let* ((node-map ())
224
          ;; if no transaction is present, just the persistent terms will bind
225
          (x-record (when transaction (transaction-record transaction))))
226
     (labels ((map-node (node)
227
                (rest (or (assoc node node-map)
228
                          (first (push (cons node (cons-global-blank-node :transaction x-record))
229
                                       node-map)))))
230
              (map-term (term)
231
                (case term
232
                  ((nil :undef) (error "transaction-intern-shuffeled-field: invalid term: ~s." term))
233
                  (|urn:dydra|:|all| *true-all-context-term-number*)
234
                  (|urn:dydra|:|default| *true-default-context-term-number*)
235
                  (|urn:dydra|:|named| *true-named-context-term-number*)
236
                  (t
237
                   (cond ((undistinguished-variable-p term)
238
                          (rdfcache-object-term-number x-record (map-node term)))
239
                         ((spocq:blank-node-p term)
240
                          (if skolemize
241
                            (rdfcache-object-term-number x-record (map-node term))
242
                            (rdfcache-object-term-number x-record term)))
243
                         (t
244
                          (rdfcache-object-term-number x-record term)))))))
245
       (loop with map = (loop for from in from-dimensions
246
                          collect (position from to-dimensions))
247
         for solution in solution-data
248
         for solution-index from 0
249
         do (progn (assert (= (length solution) from-field-width) ()
250
                           "Inconsistent solution (@~d not x ~d): ~s."
251
                           solution-index from-field-width solution)
252
              (loop for term in solution
253
                for term-index in map
254
                when term-index
255
                do (setf (aref field solution-index term-index)
256
                         (map-term term))))))
257
     field))
258
 
259
 
260