(defpackage :relation (:use :cl) (:shadow :union :equal))

(in-package :relation)

(defclass unknown () ())
(defvar *unknown* (make-instance 'unknown))

(defun geta (attribute tuple)
  (cl:getf tuple attribute *unknown*))

(defgeneric equal (a b)
  (:method (a b)
    (cl:equal a b))
  (:method ((a list) (b list))
    (loop for (name val) on a by #'cddr
          always (equal val (geta name b))))
  (:method ((a unknown) b)
    *unknown*)
  (:method (a (b unknown))
    *unknown*))

(deftype tuple () 'list)

(defun filter-tuple (tuple test)
  (cond ((null tuple) nil)
        ((cdr tuple)
         (destructuring-bind (att val . rest) tuple
           (cond ((funcall test att val)
                  (list* att val (filter-tuple rest test)))
                 (t (filter-tuple rest test)))))))

(defun without (tuple attributes)
  (filter-tuple tuple
                (lambda (att val)
                  (declare (ignore val))
                  (not (member att attributes)))))

(defun only (tuple attributes)
  (filter-tuple tuple
                (lambda (att val)
                  (declare (ignore val))
                  (member att attributes))))

(deftype relation () 'list)

(defun relation (&rest plist)
  "(relation :age 59 :weight 250)"
  (list plist))

(defun tuple-attributes (tuple)
  (cond ((null tuple) nil)
        ((cdr tuple)
         (cons (car tuple)
               (tuple-attributes (cddr tuple))))))

(defun relation-attributes (relation)
  (tuple-attributes (first relation)))

(defun rename (relation name-mapping)
  (sublis name-mapping relation))

(defun select (relation predicate)
  (remove-if-not predicate relation))

(defun project (relation attributes)
  (mapcar #'(lambda (tuple) (only tuple attributes)) relation))

(defun exclude (relation attributes)
  (mapcar #'(lambda (tuple) (without tuple attributes)) relation))

(defun union (&rest relations)
  (reduce #'(lambda (a b) (cl:union a b :test #'equal)) relations))

(defun flat-map (fn list)
  (reduce #'append (mapcar fn list) :initial-value ()))

(defun cross-filter (list1 list2 test)
  (remove-duplicates
   (flat-map (lambda (elt1)
               (flat-map (lambda (elt2)
                           (funcall test elt1 elt2))
                         list2))
             list1)
   :test #'equal))

(defun intersect (r1 r2)
  (cross-filter r1 r2
                (lambda (t1 t2)
                  (cond ((equal t1 t2) (list t1))
                        (t ())))))

(defun difference (r1 r2)
  (flat-map (lambda (t1)
              (cond ((find t1 r2 :test #'equal) ())
                    (t (list t1))))
            r1))

(defun natural-join-attributes (r1 r2)
  (intersection (relation-attributes r1)
                (relation-attributes r2)))

(defun join (r1 r2)
  (let ((attributes (natural-join-attributes r1 r2)))
    (cross-filter r1 r2
                  (lambda (t1 t2)
                    (cond ((every (lambda (att)
                                    (equal (geta att t1) (geta att t2)))
                                  attributes)
                           (list (append t1 (without t2 attributes))))
                          (t ()))))))

(defun join-on (attributes r1 r2)
  (cross-filter r1 r2
                (lambda (t1 t2)
                  (cond ((every (lambda (att)
                                  (equal (geta att t1) (geta att t2)))
                                attributes)
                         (list (append t1 (without t2 attributes))))
                        (t ())))))

(defun semi-join (r1 r2)
  (let ((attributes (natural-join-attributes r1 r2)))
    (cross-filter r1 r2
                  (lambda (t1 t2)
                    (cond ((every (lambda (att)
                                    (equal (geta att t1) (geta att t2)))
                                  attributes)
                           (list t1))
                          (t ()))))))

;;; examples

(defparameter $S
  (union (relation :sno 's1 :sname "Smith" :status 20 :city "London")
         (relation :sno 's2 :sname "Jones" :status 10 :city "Paris")
         (relation :sno 's3 :sname "Blake" :status 30 :city "Paris")
         (relation :sno 's4 :sname "Clark" :status 20 :city "London")
         (relation :sno 's5 :sname "Adams" :status 30 :city "Athens")))

(defparameter $P
  (union (relation :pno 'p1 :pname "Nut"   :color 'red   :weight 12.0 :city "London")
         (relation :pno 'p2 :pname "Bold"  :color 'green :weight 17.0 :city "Paris")
         (relation :pno 'p3 :pname "Screw" :color 'blue  :weight 17.0 :city "Oslo")
         (relation :pno 'p4 :pname "Screw" :color 'red   :weight 14.0 :city "London")
         (relation :pno 'p5 :pname "Cam"   :color 'blue  :weight 12.0 :city "Paris")
         (relation :pno 'p6 :pname "Cog"   :color 'red   :weight 19.0 :city "London")))

(defparameter $SP
  (union (relation :sno 's1 :pno 'p1 :qty 300)
         (relation :sno 's1 :pno 'p2 :qty 200)
         (relation :sno 's1 :pno 'p3 :qty 400)
         (relation :sno 's1 :pno 'p4 :qty 200)
         (relation :sno 's1 :pno 'p5 :qty 100)
         (relation :sno 's1 :pno 'p6 :qty 100)
         (relation :sno 's2 :pno 'p1 :qty 300)
         (relation :sno 's2 :pno 'p2 :qty 400)
         (relation :sno 's3 :pno 'p2 :qty 200)
         (relation :sno 's4 :pno 'p2 :qty 200)
         (relation :sno 's4 :pno 'p4 :qty 300)
         (relation :sno 's4 :pno 'p5 :qty 400)))

(rename $S '((:sno . :foo.sno) (:sname . :supname)))
;;->
;; ((:FOO.SNO S4 :SUPNAME "Clark" :STATUS 20 :CITY "London")
;;  (:FOO.SNO S2 :SUPNAME "Jones" :STATUS 10 :CITY "Paris")
;;  (:FOO.SNO S1 :SUPNAME "Smith" :STATUS 20 :CITY "London")
;;  (:FOO.SNO S3 :SUPNAME "Blake" :STATUS 30 :CITY "Paris")
;;  (:FOO.SNO S5 :SUPNAME "Adams" :STATUS 30 :CITY "Athens"))

(select $S (lambda (tuple)
             (equal (geta :city tuple) "London")))
;;->
;; ((:SNO S4 :SNAME "Clark" :STATUS 20 :CITY "London")
;;  (:SNO S1 :SNAME "Smith" :STATUS 20 :CITY "London"))

(project $S '(:sname :city))
;;->
;; ((:SNAME "Clark" :CITY "London") (:SNAME "Jones" :CITY "Paris")
;;  (:SNAME "Smith" :CITY "London") (:SNAME "Blake" :CITY "Paris")
;;  (:SNAME "Adams" :CITY "Athens"))

(join $S $SP)
;;->
;; ((:SNO S4 :SNAME "Clark" :STATUS 20 :CITY "London" :PNO P4 :QTY 300)
;;  (:SNO S4 :SNAME "Clark" :STATUS 20 :CITY "London" :PNO P2 :QTY 200)
;;  (:SNO S4 :SNAME "Clark" :STATUS 20 :CITY "London" :PNO P5 :QTY 400)
;;  (:SNO S2 :SNAME "Jones" :STATUS 10 :CITY "Paris" :PNO P1 :QTY 300)
;;  (:SNO S2 :SNAME "Jones" :STATUS 10 :CITY "Paris" :PNO P2 :QTY 400)
;;  (:SNO S1 :SNAME "Smith" :STATUS 20 :CITY "London" :PNO P5 :QTY 100)
;;  (:SNO S1 :SNAME "Smith" :STATUS 20 :CITY "London" :PNO P3 :QTY 400)
;;  (:SNO S1 :SNAME "Smith" :STATUS 20 :CITY "London" :PNO P1 :QTY 300)
;;  (:SNO S1 :SNAME "Smith" :STATUS 20 :CITY "London" :PNO P2 :QTY 200)
;;  (:SNO S1 :SNAME "Smith" :STATUS 20 :CITY "London" :PNO P4 :QTY 200)
;;  (:SNO S1 :SNAME "Smith" :STATUS 20 :CITY "London" :PNO P6 :QTY 100)
;;  (:SNO S3 :SNAME "Blake" :STATUS 30 :CITY "Paris" :PNO P2 :QTY 200))

;; select the parts  of 's1
(join (select (join $S $SP)
              (lambda (tuple)
                (equal (geta :sno tuple) 's1)))
      $P)
;;->
;; ((:SNO S1 :SNAME "Smith" :STATUS 20 :CITY "London" :PNO P1 :QTY 300 :PNAME
;;   "Nut" :COLOR RED :WEIGHT 12.0)
;;  (:SNO S1 :SNAME "Smith" :STATUS 20 :CITY "London" :PNO P4 :QTY 200 :PNAME
;;   "Screw" :COLOR RED :WEIGHT 14.0)
;;  (:SNO S1 :SNAME "Smith" :STATUS 20 :CITY "London" :PNO P6 :QTY 100 :PNAME
;;   "Cog" :COLOR RED :WEIGHT 19.0))

(semi-join $S $SP)
;;->
;; ((:SNO S4 :SNAME "Clark" :STATUS 20 :CITY "London")
;;  (:SNO S2 :SNAME "Jones" :STATUS 10 :CITY "Paris")
;;  (:SNO S1 :SNAME "Smith" :STATUS 20 :CITY "London")
;;  (:SNO S3 :SNAME "Blake" :STATUS 30 :CITY "Paris"))      

(intersect (project $S '(:city)) (project $P '(:city)))
;;->
;; ((:CITY "London") (:CITY "Paris"))

(defun suppliers-located-near (sno-1 sno-2 &optional (restriction #'identity))
  (select (join (rename (project $s `(:sno :city)) `((:sno . ,sno-1)))
                (rename (project $s `(:sno :city)) `((:sno . ,sno-2))))
          (lambda (tuple)
            (and (not (equal (geta sno-1 tuple)
                             (geta sno-2 tuple)))
                 (funcall restriction tuple)))))

(defun suppliers-located-near-city (city)
  (suppliers-located-near :sno-1 :sno-2
                          (lambda (tuple)
                            (equal (geta :city tuple) city))))

(suppliers-located-near-city "London")
;;->
;; ((:SNO-1 S4 :CITY "London" :SNO-2 S1) (:SNO-1 S1 :CITY "London" :SNO-2 S4))

(defun suppliers-located-near-supplier (sno)
  (suppliers-located-near :sno-1 :sno-2
                          (lambda (tuple)
                            (equal (geta :sno-1 tuple) sno))))

(suppliers-located-near-supplier 's2)
;;->
;; ((:SNO-1 S2 :CITY "Paris" :SNO-2 S3))
Advertisements



    Leave a Reply

    Fill in your details below or click an icon to log in:

    WordPress.com Logo

    You are commenting using your WordPress.com account. Log Out / Change )

    Twitter picture

    You are commenting using your Twitter account. Log Out / Change )

    Facebook photo

    You are commenting using your Facebook account. Log Out / Change )

    Google+ photo

    You are commenting using your Google+ account. Log Out / Change )

    Connecting to %s



%d bloggers like this: