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

;; Runtime management of models

(defvar *design-models* nil)
(defvar *territory-models* nil)
(defvar *use-models* nil)

(defun save-model (model)
  (typecase model
    (design-model (push model *design-models*))
    (territory-model (push model *territory-models*))
    (use-model (push model *use-models*))))

;; now a method
#+ignore
(defun delete-model (model)
  (typecase model
    (design-model (setq *design-models* (delete model *design-models*)))
    (territory-model (setq *territory-models* (delete model *territory-models*)))))

(defmethod delete-model ((model (eql nil)))
  nil)

(defmethod delete-model ((model territory-model))
  (setq *territory-models* (delete model *territory-models*))
  (remove-model model (design-model model)))			 
			 
(defmethod delete-model ((model design-model))
  ;; unsafe:  territory-model still has pointers to design-model design elements
  (setq *design-models* (delete model *design-models*))
  (loop for tmodel in (territory-models model)
	do (remove-model model tmodel)))

(defmethod delete-model ((model use-model))
  (setq *use-models* (delete model *use-models*)))


(defun find-model (name type)
  (case type
    (design-model (find name *design-models* :key #'name))
    (territory-model (find name *territory-models* :key #'name))
    (edge-model (edge-model
		  (find name *design-models* :key #'(lambda (x) (name (edge-model x))))))
    (use-model (find name *use-models* :key #'name))))

(defun find-dmodel (name)
  (find-model name 'design-model))

(defun find-tmodel (name)
  (find-model name 'territory-model))

(defun find-emodel (name)
  (find-model name 'edge-model))

(defun find-umodel (name)
  (find-model name 'use-model))

(defmethod find-derived-tmodels ((name symbol))
  ;; find by name because might have reloaded model (e.g. from file)
  (loop for model in *territory-models*
	when (eq name (name (derived-from model)))
	  collect model))

(defmethod find-derived-tmodels ((model territory-model))
  (find-derived-tmodels (name model)))

(defmethod find-all-derived-tmodels ((name symbol))
  ;; find by name because might have reloaded model (e.g. from file)
  (loop for model in *territory-models*
	when (member name (mapcar #'name (all-derived-froms model)))
	  collect model))

(defmethod find-all-derived-tmodels ((model territory-model))
  (find-all-derived-tmodels (name model)))

(defmethod delete-derived-models ((name symbol))
  (loop for model in *territory-models*
	when (and (or (eq name (name (derived-from model)))
		      (member name (mapcar #'name (all-derived-froms model))))
		  (y-or-n-p "Delete ~a? " model))
	       do (delete-model model)))

(defmethod delete-derived-models ((model territory-model))
  (delete-derived-models (name model)))

(defmethod delete-derived-models ((name (eql 'all)))
  (when (y-or-n-p "Delete all derived models? ")
    (loop for model in *territory-models*
	  when (derived-from model)
	    do (delete-model model))))

(defun find-or-make-model (name type)
  (let ((model
	  (case type
	    (design-model (find name *design-models* :key #'name))
	    (territory-model (find name *territory-models* :key #'name)))))
    (or model (make-instance type :name name))))

(defun clear-models (&optional type)
  (case type
    (design-model (setq *design-models* nil))
    (territory-model (setq *territory-models* nil))
    (otherwise (progn (setq *design-models* nil))
	       (setq *territory-models* nil))))

(defun get-models (&optional type)
  (case type
    (design-model *design-models*)
    (territory-model *territory-models* nil)
    (otherwise (values *design-models* *territory-models*))))

(defun get-design-models ()
  *design-models*)

(defun get-territory-models ()
  *territory-models*)

(defun get-use-models ()
  *use-models*)