;;; -*- Mode: Lisp; Package: DESIGN; Syntax: Ansi-common-lisp -*-

;;; What's the difference between save-form and plist-for-save?  save-form is toplevel
;;; function called to write form to file; plist-for-save is called when plist is included
;;; in save-form.

(defclass PRINT-OBJECT-MIXIN ()
    ())

(defmethod print-object ((x print-object-mixin) stream)
  (format stream "<~a: ~a>" (type-of x) (name x)))

(defclass NAME-MIXIN (print-object-mixin)
  ((name :initform nil :initarg :name :accessor name)))    

#+ignore
(defmethod print-object ((x name-mixin) stream)
  (format stream "<~a: ~a>" (type-of x) (name x)))

(defmethod name ((n list))
  (mapcar #'name n))

(defun name-string (x)
  (string (name x)))

(defmethod name ((n t))
  n)

(defgeneric plist-for-save (x) (:method-combination append))

(defmethod plist-for-save append ((x name-mixin))
  (with-slots (name) x
    `(:name ,name)))
  

(defclass NOTES-MIXIN ()
  ((notes :initform nil :initarg :notes :accessor notes)))	;lists of strings

(defmethod plist-for-save append ((x notes-mixin))
  (with-slots (notes) x
    `(:notes ,notes)))

(defmethod add-note ((x notes-mixin) (note string))
  (with-slots (notes) x
    (push note notes))
  note)

(defmethod clear-notes ((x notes-mixin))
  (with-slots (notes) x
    (setf notes nil)))

(defclass PLIST-MIXIN ()
    ((plist :initform nil :initarg :plist :accessor plist)))

(defmethod set-property-value ((x plist-mixin) property-name value)
  (with-slots (plist) x
    (setf (getf plist property-name) value)))

(defmethod get-property-value ((x plist-mixin) property-name)
  (with-slots (plist) x
    (getf plist property-name)))

(defmethod add-property-value ((x plist-mixin) property-name value)
  (with-slots (plist) x
    (push value (getf plist property-name))))

(defun remove-property (x property-name)
  (setf (plist x)
	(remove-item (plist x) property-name)))

(defmethod remove-property-value ((x plist-mixin) property-name value)
  (with-slots (plist) x
    (setf (getf plist property-name) (remove value (getf plist property-name)
					     :test #'equal))))

(defmethod remove-property-values ((x plist-mixin) property-name (values list))
  (with-slots (plist) x
    (setf (getf plist property-name) (set-difference (getf plist property-name) values
						     :test #'equal))))

(defmethod plist-for-save ((x plist-mixin))
  (with-slots (plist) x
    `(:plist ,(plist x))))

(defmethod add-pvalue (thing property-object value &optional args)
  (add-property-value thing (keyword-symbol (name property-object))
					    (list property-object args value)))


(defclass BASIC-OBJECT (name-mixin plist-mixin notes-mixin)
    ()) 



(defclass DERIVATION-INFO ()
    ((derivation :initform nil :initarg :derivation :accessor derivation)
     (derived-from :initform nil :initarg :derived-from :accessor derived-from)))

(defmethod print-object ((info derivation-info) stream)
  (with-slots (derivation derived-from) info
    (format stream "<DERIVATION: ~a of ~a>" derivation derived-from)))

(defmethod derived-from ((x (eql 'nil)))
  nil)

(defmethod derivation ((x (eql 'nil)))
  nil)

;; assume this kind of thing has multiple possible derivations (e.g. derivation of an edge)
;; need to add a method for tracing a derivation back to a design element; e.g. an edge
;; may derived form an edge, which is derived from a design element.

(defclass DERIVED-MIXIN ()
    ((derivation-info :initform nil :initarg :derivation-info :accessor derivation-info)))

(defmethod derived-from ((x derived-mixin))
  ;; returns a list
  (with-slots (derivation-info) x
    (loop for d in derivation-info
	  when (derived-from d) collect it)))

;; Add these methods for backward compatibility.  +++ Fix.

(defmethod design-element ((thing derived-mixin))
  (with-slots (derivation-info) thing
    (derived-from (car derivation-info))))

(defmethod add-derivation-info ((thing derived-mixin) elt derivation)
  (with-slots (derivation-info) thing
    (push (make-instance 'derivation-info :derived-from elt :derivation derivation)
	  derivation-info)))

;; assume this kind of thing only has one derivation (e.g. derivation of a new model)

(defclass DERIVED-OBJECT (derivation-info)
    ((modified-objects :initform nil :initarg :modified-objects :accessor modified-objects)))

(defmethod all-derived-froms ((x derived-object))
  (let ((derived-from (derived-from x)))
    (when derived-from 
      (cons derived-from (all-derived-froms derived-from)))))

(defmethod add-modified-object ((x derived-object) object)
  (with-slots (modified-objects) x
    (pushnew object modified-objects)))

(defmethod clear-modified-objects ((x derived-object))
  (with-slots (modified-objects) x
    (setf modified-objects nil)))

(defmethod remove-edge :after ((x derived-object) edge)
  (with-slots (modified-objects) x
    (when (find edge modified-objects)
      (setf modified-objects (remove edge modified-objects)))))

(defclass DESIGN-MODEL-MIXIN ()
  ((design-model :initform nil :initarg :design-model :accessor design-model)))    

(defmethod territory-model ((x design-model-mixin))
  (with-slots (design-model) x
    (territory-model design-model)))

(defmethod default-territory-model ((x design-model-mixin))
  (with-slots (design-model) x
    (default-territory-model x)))

(defmethod plist-for-save append ((x design-model-mixin))
  (with-slots (design-model) x
  `(:design-model ,(name design-model))))


(defclass TERRITORY-MODEL-MIXIN ()
    ((territory-model :initform nil :initarg :territory-model :accessor territory-model)))

(defclass CIRCULATION-MODEL-MIXIN ()
   ((circulation-model :initform nil :initarg :circulation-model :accessor circulation-model)))

(defmethod set-circulation-model ((x circulation-model-mixin) cmodel)
  (with-slots (circulation-model) x
    (setf circulation-model cmodel)))

(defclass EDGE-MODEL-MIXIN ()
   ((edge-model :initform nil :initarg :edge-model :accessor edge-model)))

(defmethod add-edge-model ((x edge-model-mixin) emodel)
  (with-slots (edge-model) x
    (setf edge-model emodel)))

(defmethod design-model ((x edge-model-mixin))
  (with-slots (edge-model) x
    (design-model edge-model)))

(defmethod default-territory-model ((x edge-model-mixin))
  (default-territory-model (design-model x)))

(defmethod edge-model ((x (eql 'nil)))
  nil)


(defclass DESIGN-ELEMENT-MIXIN ()
  ((design-element :initform nil :initarg :design-element :accessor design-element)))

(defmethod design-element ((x (eql 'nil)))
  nil)

(defmethod design-model ((x design-element-mixin))
  (with-slots (design-element) x
    (design-model design-element)))

(defmethod design-model ((x (eql 'nil)))
  nil)


(defclass TERRITORIES-MIXIN ()
    ((territories :initform nil :initarg :territories :accessor territories)))

(defmethod remove-segment :after ((x territories-mixin) seg)
  (dolist (region (territories seg))
    (remove-segment region seg)))

(defmethod add-territory ((x territories-mixin) region)
  (with-slots (territories) x
    (pushnew region territories)
    region))

(defmethod add-region ((x territories-mixin) region)
  (with-slots (territories) x
    (pushnew region territories))
  region)


;; Mix into edges.  Need place to cache the territories for which an edge is a boundary.
;; Since edge can be in more than one territory model, have to store model and territories
;; for that model.

(defclass MULTIPLE-TERRITORY-MODEL-MIXIN ()
    ((models+territories :initform nil :initarg :models+territories
			:accessor models+territories)))

(defmethod set-model+territories ((thing multiple-territory-model-mixin) territories
				  &optional (model (territory-model (car territories))))
  (with-slots (models+territories) thing
    (setf models+territories (acons model territories nil))))

(defmethod set-territories-for-model ((thing multiple-territory-model-mixin) territories
				      &optional (model (territory-model (car
									  territories))))
  (with-slots (models+territories) thing
    (let ((current-territories (cdr (assoc model models+territories))))
      (if current-territories
	  (rplacd (assoc model models+territories) territories)
	  (setf models+territories (acons model territories models+territories))))))

(defmethod add-territory-for-model ((thing multiple-territory-model-mixin) territory
				      &optional (model (territory-model territory)))
  (with-slots (models+territories) thing
    (let ((current-territories (cdr (assoc model models+territories))))
      (if current-territories
	  (pushnew territory (cdr (assoc model models+territories)))
	  (set-territories-for-model thing (list territory) model)))))

(defmethod territories-for-model ((thing multiple-territory-model-mixin) model)
  (with-slots (models+territories) thing
    (cdr (assoc model models+territories))))

;; Add these two methods for backward compatibility.  Use first model as default.
;; Not safe, but current implementation has only one territory model stored in this list.

(defmethod territory-model ((thing multiple-territory-model-mixin))
  (with-slots (models+territories) thing
    (caar models+territories)))

(defmethod territories ((thing multiple-territory-model-mixin))
(with-slots (models+territories) thing
    (cdar models+territories)))

(defmethod add-territory ((thing multiple-territory-model-mixin) territory)
  (add-territory-for-model thing territory))

(defclass INTERIORP-MIXIN ()
    ((interiorp :initform t :initarg :interiorp :accessor interiorp)))

(defmethod plist-for-save append ((x interiorp-mixin))
  (with-slots (interiorp) x
    `(:interiorp ,interiorp)))

(defmethod exteriorp ((x interiorp-mixin))
  (with-slots (interiorp) x
    (not interiorp)))



(defclass MARKERS-MIXIN ()
    ((markers :initform nil :initarg :markers :accessor markers)))

(defmethod markers-to-save ((model markers-mixin))
  (with-slots (markers) model
    (loop for marker in markers
	when (save-marker-p marker) collect marker)))

(defmethod add-marker ((thing markers-mixin) marker)
  (when marker
    (with-slots (markers) thing
      (pushnew marker markers))))

(defmethod delete-marker ((thing markers-mixin) marker)
  (when marker
    (with-slots (markers) thing
      (setf markers (delete marker markers)))))


(defmethod find-marker ((marker-string string) (model markers-mixin))
  (find marker-string (markers model) :test #'string-equal :key #'marker-note))

(defmethod find-marker ((marker-tag symbol) (model markers-mixin))
  (find marker-tag (markers model) :test #'eql :key #'marker-tag))


(defclass DOMAIN-RANGE-MIXIN ()
    ((domain :initform nil :initarg :domain :accessor domain)
     (range :initform nil :initarg :range :accessor range)))