record-relation.scm

(use gauche.record)
(use util.relation)
(use util.match)
(use gauche.sequence)

(define-method rtd-equality-tester ((rtd <record-meta>))
  (let1 ac ($ map ($ rtd-accessor rtd $) $ rtd-all-field-names rtd)
    (^[x y]
      (equal? (map (cut <> x ) ac) (map (cut <> y ) ac) ) ) ) )

(define-method rtd-equality-tester ((rtd <pseudo-record-meta>))
  (let1 size (vector-length (slot-ref rtd'field-specs))
    (^ xy
      ($ equal? $* map (cut subseq <> 0 size) xy)
    ) ) )

(define-class <record-relation> [ <relation> ]
  [ (rows     :init-value '())
    (rtd      :init-value #f )
    (rtd-pred :init-value #f )
    (rtd-test :init-value #f ) ] )

(define-method initialize ((r <record-relation>) initargs)
  (next-method)
  (match initargs
    [( (? rtd? rtd) )
      (slot-set! r'rtd rtd)
      (slot-set! r'rtd-pred (rtd-predicate rtd) )
      (slot-set! r'rtd-test (rtd-equality-tester rtd) ) ] ) )

(define-method write-object ((r <record-relation>) port)
  (format port "<record-relation rtd:~a rows:~a >" (slot-ref r'rtd) (slot-ref r'rows) ) )

(define-method relation-column-names ((r <record-relation> ))
  (and-let* [[rtd (slot-ref r'rtd)]]
    (rtd-all-field-names rtd) ) )

(define-method relation-accessor ((r <record-relation> ))
  (and-let* [[rtd (slot-ref r'rtd)]]
    (^[row column-name]
      ((rtd-accessor rtd column-name) row) ) ) )

(define-method relation-modifier ((r <record-relation> ))
  (and-let* [[rtd (slot-ref r'rtd)]]
    (^[row column-name v]
      (and
        (rtd-field-mutable? rtd column-name)
        ((rtd-mutator rtd column-name) row v ) ) ) ) )

(define-method relation-rows ((r <record-relation> ))
  (slot-ref r'rows) )

(define-method relation-insertable? ((r <record-relation>)) #t)
(define-method relation-insert! ((r <record-relation>) row)
  (and-let* [[rtd      (slot-ref r'rtd)]
             [rtd-pred (slot-ref r'rtd-pred) ]]
    (unless (rtd-pred row) (errorf "~a is not ~a" row rtd) )
    (push! (slot-ref r'rows) row) ) )

(define-method relation-deletable? ((r <record-relation>)) #t)
(define-method relation-delete! ((r <record-relation>) row)
  (and-let* [[rtd      (slot-ref r'rtd)]
             [rtd-pred (slot-ref r'rtd-pred) ]
             [rtd-test (slot-ref r'rtd-test) ] ]
    (unless (rtd-pred row) (errorf "~a is not ~a" row rtd) )
    (update! (slot-ref r'rows) (cut delete! row <> rtd-test) ) ) )

;--------------------

(debug-print-width #f)
(define-record-type (point (pseudo-rtd <u8vector>) ) #t #f (x) (y) (z) attr )
(define r (make <record-relation> point) )
#?=r
#?=(relation-insert! r (make-point 1 2 3 4))
#?=(relation-insert! r #u8(11 22 33 44 55))
#?=(relation-insert! r (make-point 111 222 155 255))
#?=r

#?=(relation-fold r (^[x y z attr s] (print x " " y " " z " " attr) s ) #t 'x 'y 'z 'attr)
#?=(relation-delete! r (make-point 11 22 33 44))
#?=(relation-fold r (^[x y z attr s] (print x " " y " " z " " attr) s ) #t 'x 'y 'z 'attr)

#?=(let1 test (rtd-equality-tester point)
      (test (make-point 1 2 3 4) (make-point 1 2 3 4) ) )
#?=(let1 test (rtd-equality-tester point)
      (test (make-point 1 2 3 4) (make-point 1 2 3 5) ) )