;;; -*- Mode:LISP; Base:10; Syntax:Common-lisp -*-

;;;; ===========================================================================
;;;; PARTS EXAMPLE
;;;; ===========================================================================
;;;
;;; 23-Oct-91, Christoph Wernhard
;;; revised 20-Aug-92
;;;
;;; An example for CLOS-DB taken from M. Atkinson, P. Bunemann, "Types and
;;; Persistence in Database Programming Langauages", ACM Computing Surveys,
;;; Vol. 19, No. 2, June 1987.
;;;
;;; Remark: Because this example is intended by Atkinson and Buneman as an
;;; example for persistent programming languages, it goes beyond the scope
;;; of a database interface: CLOS-DB provides no built-in means for creating
;;; "persistent instances", i.e.  creating an instance and at the same time
;;; creating the corresponding database tuple, but, as our example programm
;;; shows, that can easily be programmed.  Anyway, this example shows many
;;; aspects of CLOS-DB and has become a "standard example" in the field.


(use-package :clos-db)
(use-package :db-rep)


;;;; -------------------
;;;; AUXILIARY FUNCTIONS


(defun compose-2 (f g)
  #'(lambda (x &rest r) (apply f (funcall g x) r)))

(defun mapper (function)
  #'(lambda (&rest lists) (apply #'mapcar function lists)))


;;;; INSERT-NEW-INSTANCE-TUPLE generic function.
;;; 
;;; This generic function is used to create a "persistent instance", i.e.
;;; it "allocates" the tuple corresponding to a newly created instance in
;;; the database.  Since in CLOS-DB the creation of a db instance requires
;;; the existence of a corresponding database tuple, this function is called
;;; with a prototypical instance before the real instance is created. 

(defgeneric insert-new-instance-tuple (prototypical-instance key-value))


;;;; ------------------------------
;;;; SCHEMAS OF THE GIVEN RELATIONS
;;;
;;; part (pno integer, name char(24))
;;; base_part (pno integer, cost money, mass integer)
;;; composite_part (pno integer, assembly_cost money, mass_increment integer)
;;; made_from (assembly integer, component integer, quantity integer)


;;;; --------------------
;;;; "SCHEMA" DESCRIPTION
;;; 
;;; An almost completely updateable database view is specified (deletion of
;;; part objects is not considered).
;;;
;;; Initargs are used to initialize objects which previously were not in the
;;; database - the database then is updated in the same way as if the slot
;;; were written after being initialized from the database.


;;;; PART db-class.

(def-db-class part ()
     ((name 
        :accessor  part-name
        :initform  p.name
	:initarg   :name
	db-update  (update-attributes :attributes 'name))
      (pno
    	:reader    part-pno 		 
   	:initform  p.pno)
      (used-in
        :reader    part-used-in
        :initform  (identify-member-list
		    'composite-part	
		    :db-cond (format nil
				     "p.pno IN (SELECT m.assembly ~
				                FROM   made_from m ~
						WHERE  m.component = ~
						       ~/sql-literal/)"
				     p.pno))))
  (:metaclass live-db-class)
  (db-connection :relational
		 :db             parts-db 
		 :key-attributes (p.pno)
		 :attributes     (p.pno p.name)
		 :from           ((part p)))
  (abstract-member-class t))


;;;; BASE-PART db-class.

(def-db-class base-part (part)  	
     ((cost
        :accessor  part-cost
	:initform  bp.cost
	:initarg   :cost
	db-update  (update-attributes :attributes 'cost))
      (mass
        :accessor  part-mass
	:initform  bp.mass
	:initarg   :mass
	db-update  (update-attributes :attributes 'mass)))
  (:metaclass live-db-class)
  (db-connection :relational
		 :key-attributes (bp.pno)
		 :attributes     (bp.pno bp.cost bp.mass)
		 :from           ((base_part bp))))

;;;; COMPOSITE-PART db-class.

(def-db-class composite-part (part)
     ((assembly-cost 
        :accessor  part-assembly-cost
	:initform  cp.assembly_cost
	:initarg   :assembly-cost
	db-update  (update-attributes :attributes 'assembly_cost))
      (mass-increment
        :accessor  part-mass-increment
	:initform  cp.mass_increment
	:initarg   :mass-increment
	db-update  (update-attributes :attributes 'mass_increment))
      (uses 
        :accessor  part-uses
        :initform  (make-instance-list
		    'db-use
		    :db-cond (format nil "m.assembly = ~/sql-literal/" 
				     cp.pno))
	db-update  (compose-2
		    (adjust-relation :attributes (component quantity)
			             :relation made_from
				     :self-key-attributes '(assembly))
		    (mapper #'(lambda (use)
				(list (part-pno (use-component use))
				      (use-quantity use)))))))
  (:metaclass live-db-class)
  (db-connection :relational
		 :key-attributes (cp.pno)
		 :attributes     (cp.pno cp.assembly_cost cp.mass_increment)
		 :from           ((composite_part cp))))
    

;;; The uses relationship is multiply represented in the object system:
;;; there are pointers in both directions - part-uses and part-used-in. In
;;; this implementation part-used-in is read-only, "(setf part-uses) :before
;;; (t composite-part)" and "initialize-instance :after (composite-part)"
;;; maintain consistency within the object system. Another way to cope with
;;; this would be the invalidation of affected used-in slots. 

(defmethod (setf part-uses) :before (new-value (part composite-part))
  (let ((old-parts (mapcar #'use-component (part-uses part)))
	(new-parts (mapcar #'use-component new-value)))
    (dolist (added-part (set-difference new-parts old-parts :test #'eq))
      (push part (slot-value added-part 'used-in)))
    (dolist (removed-part (set-difference old-parts new-parts :test #'eq))
      (setf (slot-value removed-part 'used-in)
	    (remove part (slot-value removed-part 'used-in) :test #'eq)))))

(defmethod initialize-instance :after ((part composite-part)
				       &key (uses nil uses-p))
  ;; assumes the uses slot is already bound (e.g. by an initform)
  (when uses-p
    (setf (part-uses part) uses)))


;;;; USE standard-class.

(defclass use ()
     ((component
        :reader   use-component
	:initarg  :component)
      (quantity 
        :reader   use-quantity
	:initarg  :quantity)))


;;; slots of members of use may not be written, members of use may be
;;; freely created and inserted into or removed from a uses slot via (setf
;;; part-uses). 


;;;; DB-USE db-class.

(def-db-class db-use (use)
     ((component
        :initform (identify-member 'part :db-key m.component))
      (quantity
        :initform m.quantity))
  (:metaclass snapshot-db-class)
  (db-connection :relational
		 :db             parts-db
		 :key-attributes (m.assembly m.component)
		 :attributes     (m.component m.quantity)
		 :from           ((made_from m))))


;;;; METHODS FOR INSERTING NEW INSTANCE TUPLES

(defmethod insert-new-instance-tuple ((part part) pno)
  (db-command (format nil
		      "INSERT INTO PART (PNO) VALUES (~A)" (sql-literal pno))
	      :db 'parts-db))

(defmethod insert-new-instance-tuple :after ((part base-part) pno)
  (db-command (format nil
		      "INSERT INTO BASE_PART (PNO) VALUES (~A)"
		      (sql-literal pno))
	      :db 'parts-db))

(defmethod insert-new-instance-tuple :after ((part composite-part) pno)
  (db-command (format nil
		      "INSERT INTO COMPOSITE_PART (PNO) VALUES (~A)"
		      (sql-literal pno))
	      :db 'parts-db))


;;;; ---------------
;;;; EXPENSIVE-PARTS
;;;
;;; "Print the names, cost and mass of all imported parts that cost more than
;;; $100."

(defun expensive-parts-1 ()
  (mapcar #'(lambda (part)
	      (list (part-name part) (part-cost part) (part-mass part)))
	  (identify-member-list 'base-part :db-cond "bp.cost > 100")))

(defun expensive-parts-2 ()
  (with-open-lstream
      (lstream (identify-member-lstream 'base-part :db-cond "bp.cost > 100"))
    (do ((part (lstream-next lstream) (lstream-next lstream)))
	((null part) (values))
	(format 't "~&name: ~A, cost: ~D, mass: ~D~%"
		(part-name part) (part-cost part) (part-mass part)))))


;;;; -------------
;;;; COST-AND-MASS
;;;
;;; "Print the total mass and total cost of a composite part."

(defgeneric cost-and-mass-1 (part))

(defmethod cost-and-mass-1 ((part base-part))
  (values (part-cost part) (part-mass part)))

(defmethod cost-and-mass-1 ((part composite-part))
  (let ((cost-sum (part-assembly-cost part))
	(mass-sum (part-mass-increment part)))
    (dolist (use (part-uses part) (values cost-sum mass-sum))
      (with-accessors ((component use-component) (quantity  use-quantity))
		      use
	  (multiple-value-bind (component-cost component-mass)
	      (cost-and-mass-1 component)
            (setq cost-sum (+ cost-sum (* quantity component-cost))
		  mass-sum (+ mass-sum (* quantity component-mass))))))))


;;;; COST-AND-MASS WITH MEMOIZING

(defgeneric cost-and-mass-2 (part &optional memo-table))

(defmethod cost-and-mass-2 ((part base-part) &optional memo-table)
  (declare (ignore memo-table))
  (list (part-cost part) (part-mass part)))

(defmethod cost-and-mass-2 ((part composite-part)
			    &optional (memo-table (make-hash-table :test #'eq)))
  (or (gethash part memo-table)
      (let ((cost-sum (part-assembly-cost part))
	    (mass-sum (part-mass-increment part)))
	(dolist (use (part-uses part)
		     (setf (gethash part memo-table) (list cost-sum mass-sum)))
	  (with-accessors ((component use-component) (quantity  use-quantity))
			  use
	    (destructuring-bind (component-cost component-mass)
 	        (cost-and-mass-2 component memo-table)
	      (setq cost-sum (+ cost-sum (* quantity component-cost))
		    mass-sum (+ mass-sum (* quantity component-mass)))))))))


;;;; FIND-PART

(defun find-part (name)
  (car (identify-member-list
         'part
         :db-cond (format nil "p.name = ~/sql-literal/" name)
         :max-no-of-elements 1)))


;;;; ------------------
;;;; NEW COMPOSITE PART

;;;; IDENTIFY-NEW-PART function.
;;;
;;; Assumes that the initargs are already checked.

(defun identify-new-part (class &rest initargs)
  (let* ((pno 
	  (1+ (db-query-literal "SELECT max (pno) FROM part" :db 'parts-db))))
    (insert-new-instance-tuple
     (amop:class-prototype (if (symbolp class) (find-class class) class))
     pno)
    (apply #'identify-instance 'composite-part :db-key pno initargs)))