Coverage report: /development/source/library/org/datagraph/spocq-shard/src/algebra/matrix-operators/or.lisp

KindCoveredAll%
expression0152 0.0
branch06 0.0
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 "Define the matrix-variant of the OR operator for the 'org.datagraph.spocq' RDF engine."
6
 
7
  (copyright
8
   "Copyright 2013 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved."))
9
 
10
 
11
 (defgeneric matrix-or (result-field base-field offset-field &rest arguments &key start end)
12
   (:documentation
13
    "Generate a disjunction field to a result given a base field, offset field, and optional slice (start, end) specifications.
14
  Require the fields to share dimensions and use them as a key to determine identity.
15
  Otherwise treat the operation as a union.")
16
   
17
   (:method :before (result-field base-field offset-field &rest args)
18
            (declare (dynamic-extent args))
19
            (trace-algebra  matrix-or :result-field result-field :base-field base-field :offset-field offset-field :args args))
20
   
21
   (:method ((result-field null) base-field offset-field &rest args)
22
     (declare (dynamic-extent args))
23
     (complete-field-data (apply #' matrix-or (make-matrix-field) base-field offset-field args)))
24
   
25
   (:method ((result-field matrix-field) base-field offset-field &rest arguments &key start end)
26
     (declare (ignore start end)
27
              (dynamic-extent arguments))
28
     
29
     (let* ((result-dimensions (or (matrix-field-dimensions result-field)
30
                                   (union-dimensions (solution-field-dimensions base-field)
31
                                                     (solution-field-dimensions offset-field)))))
32
       (if (intersection (solution-field-dimensions base-field)
33
                         (solution-field-dimensions offset-field) )
34
         (multiple-value-bind (base-field offset-field sort-order)
35
                              (reconcile-field-order base-field offset-field)
36
           (incf-stat *algebra-operations*)
37
           (let ((operator (apply #'matrix-or-operator
38
                                  result-dimensions
39
                                  (solution-field-dimensions base-field) (solution-field-dimensions offset-field)
40
                                  arguments)))
41
             (with-input-fields (base-field offset-field)
42
               (with-result-field (result-field :dimensions result-dimensions :sort-dimensions sort-order)
43
                 (apply operator result-field base-field offset-field
44
                        arguments)))
45
             (values result-field
46
                     (+ (solution-field-length base-field) (solution-field-length offset-field))
47
                     (solution-field-length result-field))))
48
         
49
         ;; if no dimension is shared, treat it as a union
50
         (let ((operator (apply #'matrix-union-operator
51
                                (solution-field-dimensions result-field)
52
                                (solution-field-dimensions base-field)
53
                                (solution-field-dimensions offset-field)
54
                                arguments)))
55
           (apply operator result-field base-field offset-field arguments))))))
56
 
57
 
58
 
59
 (defun matrix-or-operator (result-dimensions base-dimensions offset-dimensions &key start end test)
60
   (declare (ignore test))
61
   (let* ((base-projection (loop for dimension in base-dimensions
62
                                collect (position dimension result-dimensions)))
63
         (offset-projection (loop for dimension in offset-dimensions
64
                                  collect (position dimension result-dimensions)))
65
         (key-dimensions (join-key-dimensions base-dimensions offset-dimensions))
66
         (base-key (loop for dimension in key-dimensions
67
                         collect (or (position dimension base-dimensions)
68
                                     (error "key dimension not present in base field: ~s: ~s." dimension base-dimensions))))
69
         (offset-key (loop for dimension in key-dimensions
70
                           collect (or (position dimension offset-dimensions)
71
                                     (error "key dimension not present in offset field: ~s: ~s." dimension offset-dimensions)))))
72
     (values (ensure-matrix-operator 'or
73
                    :base-projection base-projection
74
                    :offset-projection offset-projection
75
                    :result-column-count (length result-dimensions)
76
                    :base-column-count (length base-dimensions)
77
                    :offset-column-count (length offset-dimensions)
78
                    :base-key base-key
79
                    :offset-key offset-key
80
                    :slice (not (null (or start end))))
81
             result-dimensions)))
82
 
83
 
84
 (defmethod compute-matrix-operator-lambda ((operator (eql 'or)) &key 
85
                                            base-projection offset-projection result-column-count base-column-count offset-column-count base-key offset-key slice)
86
   "compute an operator which, given two field matrices which share key fields, peforms
87
  a natural merge or of the two into another, given result field matrix. resize the result
88
  as required."
89
   
90
   `(lambda (result-field base-field offset-field &key ,@(when slice '((start 0) end)))
91
      ,(format nil "natural or operator for projection: ~s x ~s -> ~s keys: ~s x ~s." base-projection offset-projection result-column-count base-key offset-key)
92
      (declare (type matrix-field result-field base-field offset-field)
93
               ;; (optimize ,@*field-optimization*)
94
               ,@(when slice '((type fixnum start)))
95
               )
96
 
97
      (unless (= (length (solution-field-dimensions result-field)) ,result-column-count) ()
98
              (matrix-dimension-error :matrix result-field :expected-dimensions '(* ,result-column-count)))
99
      (unless (= (length (solution-field-dimensions base-field)) ,base-column-count) ()
100
              (matrix-dimension-error :matrix base-field :expected-dimensions '(* ,base-column-count)))
101
      (unless (= (length (solution-field-dimensions offset-field)) ,offset-column-count) ()
102
              (matrix-dimension-error :matrix offset-field :expected-dimensions '(* ,offset-column-count)))
103
 
104
      (let* ((%base-data (cffi:null-pointer))
105
             (%offset-data (cffi:null-pointer))
106
             (%result-data (cffi::null-pointer))
107
             (base-row 0)
108
             (offset-row 0)
109
             (result-row 0))
110
        (declare (foreign-type (foreign-array ,+matrix-element-type+ (* ,base-column-count)) %base-data)
111
                 (foreign-type (foreign-array ,+matrix-element-type+ (* ,offset-column-count)) %offset-data)
112
                 (foreign-type (foreign-array ,+matrix-element-type+ (* ,result-column-count)) %result-data)
113
                 (type sb-sys:system-area-pointer %base-data %offset-data %result-data)
114
                 (type fixnum offset-segment-count)
115
                 (type fixnum base-row offset-row result-row))
116
        (setf (values %base-data base-row) (first-field-row base-field))
117
        (setf (values %offset-data offset-row) (first-field-row offset-field))
118
        
119
        ;; locate matched segments until either side is exhausted, at which point any remaining solutions are emitted
120
        ;; emit all matched base solutions in the segment
121
        ;; neither side must be offset side is materialized, as the offset side is skipped.
122
        (cffi:with-foreign-pointer (%cache-data ,(* base-column-count +matrix-element-size+))
123
          (declare (foreign-type (foreign-array ,+matrix-element-type+ (* ,base-column-count)) %cache-data))
124
          (loop ,@(when slice `(with result-count fixnum = 0 until (and end (>= result-count (the fixnum end)))))
125
                while (and (not (cffi:null-pointer-p %base-data)) (not (cffi:null-pointer-p %offset-data)))
126
                do (trace-matrix "~&natural-diff.loop ~@{~s ~}" :base-data %base-data :offset-data %offset-data  :result-data %result-data :base base-row :offset offset-row :result result-row)
127
                do (ecase (compare-foreign-solutions (%base-data base-row) (%offset-data offset-row) ',base-key ',offset-key)
128
                     (1
129
                      ;; if nothing matches and the offset preceeds, emit the offset solution
130
                      (trace-matrix "~&or.emit-offset")
131
                      (,@(if slice
132
                           '(when (> (incf result-count) start))
133
                           '(progn))
134
                       (setf (values %result-data result-row) (new-field-row result-field))
135
                       (trace-matrix "~&or.next-result ~@{~a ~}" :base base-row :offset offset-row :result result-row)
136
                       (project-foreign-solution (%result-data result-row) (%offset-data offset-row) ',offset-projection))
137
                      (trace-matrix "~&or.advance-offset")
138
                      (setf (values %offset-data offset-row) (next-field-row offset-field)))
139
                     (-1
140
                      ;; iff nothing matches, and the base preceeds, emit the base solution
141
                      (trace-matrix "~&or.emit-base")
142
                      (,@(if slice
143
                           '(when (> (incf result-count) start))
144
                           '(progn))
145
                       (setf (values %result-data result-row) (new-field-row result-field))
146
                       (trace-matrix "~&or.next-result ~@{~a ~}" :base base-row :offset offset-row :result result-row)
147
                       (project-foreign-solution (%result-data result-row) (%base-data base-row) ',base-projection))
148
                      (trace-matrix "~&or.advance-base")
149
                      (setf (values %base-data base-row) (next-field-row base-field)))
150
                     (0 
151
                      (trace-matrix "~&or.emit-base-equal")
152
                      ;; first, skip the offset
153
                      (loop while (and (not (cffi:null-pointer-p (setf (values %offset-data offset-row) (next-field-row offset-field))))
154
                                       (zerop (compare-foreign-solutions (%base-data base-row) (%offset-data offset-row) ',base-key ',offset-key))))
155
                      (move-foreign-solution (%cache-data 0) (%base-data base-row))
156
                      (loop do (,@(if slice
157
                                    '(when (> (incf result-count) start))
158
                                    '(progn))
159
                                (setf (values %result-data result-row) (new-field-row result-field))
160
                                (trace-matrix "~&or.next-result ~@{~a ~}" :base base-row :offset offset-row :result result-row)
161
                                (project-foreign-solution (%result-data result-row) (%base-data base-row) ',base-projection))
162
                            while (and (not (cffi:null-pointer-p (setf (values %base-data base-row) (next-field-row base-field))))
163
                                       (zerop (compare-foreign-solutions (%cache-data 0) (%base-data base-row) ',base-key ',base-key))
164
                                       ,@(when slice `(until (and end (>= result-count (the fixnum end)))))))
165
                      (trace-matrix "~&or.equal-complete  ~@{~a ~}" :base-data %base-data :base-row base-row)))
166
                ;;; emit remaining base solutions
167
                finally (progn (trace-matrix "~&or.extra ~@{~a ~}"  :base-data %base-data :offset-data %offset-data :base-row base-row :offset-row offset-row)
168
                               (loop ,@(when slice '(until (and end (>= result-count (the fixnum end)))))
169
                                     until (cffi:null-pointer-p %base-data)
170
                                     do (progn (,@(if slice
171
                                                    '(when (> (incf result-count) start))
172
                                                    '(progn))
173
                                                (setf (values %result-data result-row) (new-field-row result-field))
174
                                                (trace-matrix "~&or.next-result.extra-base ~@{~a ~}" :base base-row  :result result-row)
175
                                                (project-foreign-solution (%result-data result-row) (%base-data base-row) ',base-projection))
176
                                               (trace-matrix "~&or.advance-base.extra-base")
177
                                               (setf (values %base-data base-row) (next-field-row base-field))))
178
                               (loop ,@(when slice '(until (and end (>= result-count (the fixnum end)))))
179
                                     until (cffi:null-pointer-p %base-data)
180
                                     do (progn (,@(if slice
181
                                                    '(when (> (incf result-count) start))
182
                                                    '(progn))
183
                                                (setf (values %result-data result-row) (new-field-row result-field))
184
                                                (trace-matrix "~&or.next-result.extra-offset ~@{~a ~}" :offset offset-row :result result-row)
185
                                                (project-foreign-solution (%result-data result-row) (%offset-data offset-row) ',offset-projection))
186
                                               (trace-matrix "~&or.advance-offset.extra-base")
187
                                               (setf (values %offset-data offset-row) (next-field-row offset-field)))))))
188
        result-field)))