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

KindCoveredAll%
expression0147 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 XOR 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-xor (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-xor :result-field result-field :base-field base-field :offset-field offset-field :rest args))
20
   
21
   (:method ((result-field null) base-field offset-field &rest args)
22
     (declare (dynamic-extent args))
23
     (complete-field-data (apply #'matrix-xor (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
     (if (intersection (solution-field-dimensions base-field)
30
                       (solution-field-dimensions offset-field) )
31
       (multiple-value-bind (base-field offset-field sort-order)
32
                            (reconcile-field-order base-field offset-field)
33
         (multiple-value-bind (operator result-dimensions)
34
                              (apply #'matrix-xor-operator
35
                                     (or (result-field-dimensions result-field)
36
                                         (join-result-dimensions (solution-field-dimensions base-field)
37
                                                                 (solution-field-dimensions offset-field)))
38
                                     (solution-field-dimensions base-field) (solution-field-dimensions offset-field)
39
                                     arguments)
40
           (incf-stat *algebra-operations*)
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
       ;; if no dimension is shared, treat it as a union
49
       (let ((operator (apply #'matrix-union-operator
50
                                (solution-field-dimensions result-field)
51
                                (solution-field-dimensions base-field)
52
                                (solution-field-dimensions offset-field)
53
                                arguments)))
54
           (apply operator result-field base-field offset-field arguments)))))
55
 
56
 
57
 
58
 (defun matrix-xor-operator (result-dimensions base-dimensions offset-dimensions &key start end test)
59
   (declare (ignore test))
60
   (let* ((base-projection (loop for dimension in base-dimensions
61
                                collect (position dimension result-dimensions)))
62
         (offset-projection (loop for dimension in offset-dimensions
63
                                  collect (position dimension result-dimensions)))
64
         (key-dimensions (join-key-dimensions base-dimensions offset-dimensions))
65
         (base-key (loop for dimension in key-dimensions
66
                         collect (or (position dimension base-dimensions)
67
                                     (error "dimension not present: ~s: ~s." dimension base-dimensions))))
68
         (offset-key (loop for dimension in key-dimensions
69
                           collect (or (position dimension offset-dimensions)
70
                                     (error "dimension not present: ~s: ~s." dimension offset-dimensions)))))
71
     (values (ensure-matrix-operator 'xor
72
                    :base-projection base-projection
73
                    :offset-projection offset-projection
74
                    :result-column-count (length result-dimensions)
75
                    :base-column-count (length base-dimensions)
76
                    :offset-column-count (length offset-dimensions)
77
                    :base-key base-key
78
                    :offset-key offset-key
79
                    :slice (not (null (or start end))))
80
             result-dimensions)))
81
 
82
 
83
 (defmethod compute-matrix-operator-lambda ((operator (eql 'xor)) &key 
84
                                            base-projection offset-projection result-column-count base-column-count offset-column-count base-key offset-key slice)
85
   "compute an operator which, given two field matrices which share key fields, peforms
86
  a natural merge or of the two into another, given result field matrix. resize the result
87
  as required."
88
   
89
   `(lambda (result-field base-field offset-field &key ,@(when slice '((start 0) end)))
90
      ,(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)
91
      (declare (type matrix-field result-field base-field offset-field)
92
               ;; (optimize ,@*field-optimization*)
93
               ,@(when slice '((type fixnum start)))
94
               )
95
 
96
      (unless (= (length (solution-field-dimensions result-field)) ,result-column-count) ()
97
              (matrix-dimension-error :matrix result-field :expected-dimensions '(* ,result-column-count)))
98
      (unless (= (length (solution-field-dimensions base-field)) ,base-column-count) ()
99
              (matrix-dimension-error :matrix base-field :expected-dimensions '(* ,base-column-count)))
100
      (unless (= (length (solution-field-dimensions offset-field)) ,offset-column-count) ()
101
              (matrix-dimension-error :matrix offset-field :expected-dimensions '(* ,offset-column-count)))
102
      
103
      (let* ((%base-data (cffi:null-pointer))
104
             (%offset-data (cffi:null-pointer))
105
             (%result-data (cffi::null-pointer))
106
             (base-row 0)
107
             (offset-row 0)
108
             (result-row 0))
109
        (declare (foreign-type (foreign-array ,+matrix-element-type+ (* ,base-column-count)) %base-data)
110
                 (foreign-type (foreign-array ,+matrix-element-type+ (* ,offset-column-count)) %offset-data)
111
                 (foreign-type (foreign-array ,+matrix-element-type+ (* ,result-column-count)) %result-data)
112
                 (type sb-sys:system-area-pointer %base-data %offset-data %result-data)
113
                 (type fixnum offset-segment-count)
114
                 (type fixnum base-row offset-row result-row))
115
        (setf (values %base-data base-row) (first-field-row base-field))
116
        (setf (values %offset-data offset-row) (first-field-row offset-field))
117
        
118
        ;; locate matched segments until either side is exhausted, at which point any remaining solutions are emitted
119
        ;; emit all matched base solutions in the segment
120
        ;; neither side must be offset side is materialized, as the offset side is skipped.
121
        (cffi:with-foreign-pointer (%cache-data ,(* base-column-count +matrix-element-size+))
122
          (declare (foreign-type (foreign-array ,+matrix-element-type+ (* ,base-column-count)) %cache-data))
123
          (loop ,@(when slice `(with result-count fixnum = 0 until (and end (>= result-count (the fixnum end)))))
124
                while (and (not (cffi:null-pointer-p %base-data)) (not (cffi:null-pointer-p %offset-data)))
125
                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)
126
                do (ecase (compare-foreign-solutions (%base-data base-row) (%offset-data offset-row) ',base-key ',offset-key)
127
                     (1
128
                      ;; if nothing matches and the offset preceeds, emit the offset solution
129
                      (trace-matrix "~&or.emit-offset")
130
                      (,@(if slice
131
                           '(when (> (incf result-count) start))
132
                           '(progn))
133
                       (setf (values %result-data result-row) (new-field-row result-field))
134
                       (trace-matrix "~&or.next-result ~@{~a ~}" :base base-row :offset offset-row :result result-row)
135
                       (project-foreign-solution (%result-data result-row) (%offset-data offset-row) ',offset-projection))
136
                      (trace-matrix "~&or.advance-offset")
137
                      (setf (values %offset-data offset-row) (next-field-row offset-field)))
138
                     (-1
139
                      ;; iff nothing matches, and the base preceeds, emit the base solution
140
                      (trace-matrix "~&or.emit-base")
141
                      (,@(if slice
142
                           '(when (> (incf result-count) start))
143
                           '(progn))
144
                       (setf (values %result-data result-row) (new-field-row result-field))
145
                       (trace-matrix "~&or.next-result ~@{~a ~}" :base base-row :offset offset-row :result result-row)
146
                       (project-foreign-solution (%result-data result-row) (%base-data base-row) ',base-projection))
147
                      (trace-matrix "~&or.advance-base")
148
                      (setf (values %base-data base-row) (next-field-row base-field)))
149
                     (0 
150
                      (trace-matrix "~&or.skip-equal")
151
                      ;; first, skip the offset
152
                      (loop while (and (not (cffi:null-pointer-p (setf (values %offset-data offset-row) (next-field-row offset-field))))
153
                                       (zerop (compare-foreign-solutions (%base-data base-row) (%offset-data offset-row) ',base-key ',offset-key))))
154
                      (move-foreign-solution (%cache-data 0) (%base-data base-row))
155
                      (loop while (and (not (cffi:null-pointer-p (setf (values %base-data base-row) (next-field-row base-field))))
156
                                       (zerop (compare-foreign-solutions (%cache-data 0) (%base-data base-row) ',base-key ',base-key))))
157
                      (trace-matrix "~&or.equal-complete  ~@{~a ~}" :base-data %base-data :base-row base-row)))
158
                ;;; emit remaining base solutions
159
                finally (progn (trace-matrix "~&or.extra ~@{~a ~}"  :base-data %base-data :offset-data %offset-data :base-row base-row :offset-row offset-row)
160
                               (loop ,@(when slice '(until (and end (>= result-count (the fixnum end)))))
161
                                     until (cffi:null-pointer-p %base-data)
162
                                     do (progn (,@(if slice
163
                                                    '(when (> (incf result-count) start))
164
                                                    '(progn))
165
                                                (setf (values %result-data result-row) (new-field-row result-field))
166
                                                (trace-matrix "~&or.next-result.extra-base ~@{~a ~}" :base base-row  :result result-row)
167
                                                (project-foreign-solution (%result-data result-row) (%base-data base-row) ',base-projection))
168
                                               (trace-matrix "~&or.advance-base.extra-base")
169
                                               (setf (values %base-data base-row) (next-field-row base-field))))
170
                               (loop ,@(when slice '(until (and end (>= result-count (the fixnum end)))))
171
                                     until (cffi:null-pointer-p %base-data)
172
                                     do (progn (,@(if slice
173
                                                    '(when (> (incf result-count) start))
174
                                                    '(progn))
175
                                                (setf (values %result-data result-row) (new-field-row result-field))
176
                                                (trace-matrix "~&or.next-result.extra-offset ~@{~a ~}" :offset offset-row :result result-row)
177
                                                (project-foreign-solution (%result-data result-row) (%offset-data offset-row) ',offset-projection))
178
                                               (trace-matrix "~&or.advance-offset.extra-base")
179
                                               (setf (values %offset-data offset-row) (next-field-row offset-field)))))))
180
        result-field)))