;;; -*- Mode: LISP; Syntax: Common-lisp; Package: DESIGN; Base: 10; Lowercase: Yes -*-

;;; Saving and loading files

;;; Toplevel save functions are #'save-design-model and #'save-territory-model.  (Need to
;;; update for new representation, e.g. that includes use-models.)  Save function writes
;;; call to #'setup-dmodel or #'setup-tmodel into file, so loading file instantiates
;;; models.  Setup functions now load related models as well; e.g. setup-dmodel loads
;;; edge model and territory models, setup-umodel loads use model, design model, edge
;;; model, territory models.  Circulation models are created when load edge and territory
;;; models. Currently no way to save edge-model or use-model (examples were edited by hand). 


;; Assumes design models have already been setup, so, don't make design-elements. Also
;; don't scale points.
(defmacro with-setup-labels (&body body)
  `(labels ((make-pt (x y)
		 (add-point edge-model (make-point x y)))
	   (make-and-add-edge (a b &optional elt deriv plist)
	     (let ((seg (make-model-edge a b elt deriv plist)))
	       (add-edge edge-model seg)))
	   (find-pt (x y)
	     (find `(,x ,y) (points edge-model)
		   :test #'(lambda (xy pt) (and (eq (car xy) (point-x pt))
						(eq (cadr xy) (point-y pt))))))
	   (find-edge (pts)
	     (find pts (edges edge-model)
		   :test #'(lambda (pts seg) (or (and (eq (car pts) (endpoint1 seg))
						  (eq (cadr pts) (endpoint2 seg)))
						 (and (eq (car pts) (endpoint2 seg))
						  (eq (cadr pts) (endpoint1 seg)))))))
	   (find-elt (name)
	     ;; won't work if element from which edge is derived is another edge
	     ;; probably have to make two passes
	     (when name
	       (find name (design-elements design-model) :key #'name)))
	   (find-or-make-pt (x y)
	     (or (find-pt x y)
		 (make-pt x y)))
	   (find-or-make-model-edge (a b &optional elt-name deriv plist)
	     (or (find-edge `(,a ,b))
		 (make-and-add-edge a b (find-elt elt-name) deriv plist))))
     (macrolet ((loop-with-edge-data (data-list &body body)
		  `(loop for edge-data in ,data-list
			 with prev-pt2
			 with pt1
			 as pt2 = (find-or-make-pt (third edge-data) (fourth edge-data))
			 do (progn
			      (if (eq (car edge-data) '*)
				  (setf pt1 prev-pt2)
				  (setf pt1 (find-or-make-pt (first edge-data)
							     (second edge-data))))
			      (setf prev-pt2 pt2)
			      ,@body))))
     ,@body)))

#+ignore
(defun setup-dmodel (plist &key design-elements markers)
  (delete-model (find-model (design-symbol (getf plist :name)) 'design-model))
  (let ((design-model (apply #'make-instance 'design-model plist)))
    (loop for info in design-elements
	  do (add-design-element design-model (apply #'make-instance (car info)
						     (cdr info))))
    (loop for marker-plist in markers
		do (add-marker design-model (apply #'make-instance marker-plist )))))

;; try new version that save names of edge-model, disjoint-territory-model,
;; default-territory-model and automatically loads them

;; assume functions that call load functions take care of deleting old models
;; e.g. see model-selection-commands.lisp

(defun setup-dmodel (plist &key design-elements markers)
  (let ((design-model (apply #'make-instance 'design-model plist)))
    (loop for info in design-elements
	  do (add-design-element design-model (apply #'make-instance (car info)
						     (cdr info))))
    (loop for marker-plist in markers
		do (add-marker design-model (apply #'make-instance marker-plist)))
    (load-edge-model design-model (edge-model design-model))
    (load-disjoint-territory-model design-model (disjoint-territory-model design-model))
    (load-default-territory-model design-model (default-territory-model design-model))
    (setup-circulation-model design-model)
    design-model))


(defun load-design-model (model model-name)
  (load (model-filename (or model-name (name model)) 'design-model))
  (find-model model-name 'design-model))

(defun load-edge-model (design-model model-name)
  (load (model-filename (or model-name (name design-model)) 'edge-model))
  (find-model model-name 'edge-model))

(defun load-use-model (design-model model-name)
  (load (model-filename (or model-name (name design-model)) 'use-model))
  (find-model model-name 'use-model))

(defun load-territory-model (dmodel model-name)
  ;; add-territory in case tmodel was loaded but not added to dmodel's list
  (if (typep model-name 'territory-model)
      model-name
    (let ((tmodel (find-model model-name 'territory-model)))
      (unless tmodel 
	(load (model-filename model-name 'territory-model))
	(setq tmodel (find-model model-name 'territory-model)))
     (add-territory-model (or dmodel (design-model tmodel)) tmodel)
      tmodel)))

(defun load-disjoint-territory-model (design-model model-name)
  (setf (disjoint-territory-model design-model)
	(load-territory-model design-model (or model-name (name design-model)))))

(defun load-default-territory-model (design-model model-name)
    (setf (default-territory-model design-model)
	  (load-territory-model design-model (or model-name (name design-model)))))


(defun setup-emodel (plist &key edges)
  (let* ((edge-model (apply #'make-instance 'edge-model plist))
	 (design-model (find-model (design-model edge-model) 'design-model)))
    (add-edge-model design-model edge-model)
    (setf (design-model edge-model) design-model)
    (with-setup-labels
      (loop-with-edge-data edges
	  (add-edge edge-model (find-or-make-model-edge pt1 pt2 (fifth edge-data)
							(sixth edge-data)
							(seventh edge-data)))))
    edge-model))

;; territories:  list of plist &rest edges
(defun setup-tmodel (plist &key territories)
  ;; load design-model if not already loaded
  ;; if design-model isn't loaded, load it, then check to see if loaded this territory model as
  ;; a side-effect
  (let* ((dmodel-name (getf plist :design-model))
	 (design-model (find-model dmodel-name 'design-model))
	edge-model)
    (unless design-model
      (setq design-model (load-design-model nil dmodel-name)))
    (setq edge-model (edge-model design-model))
  (let ((territory-model (find-model (getf plist :name) 'territory-model)))
    (unless territory-model
      (setq territory-model (apply #'make-instance 'territory-model plist))
      (setf (design-model territory-model) design-model)
      (add-territory-model design-model territory-model)
      (with-setup-labels
	(loop for info in territories
	    as region = (apply #'make-instance 'territory (car info))
	    do (progn
		 #+ignore
		 ;; don't have design-elements on regions anymore; would be use-space
		 (setf (design-element region)
		       (find-design-element (design-element region) design-model))
		 (add-territory territory-model region)
		 (loop-with-edge-data (cdr info)
		      (add-edge region (find-edge (list pt1 pt2)))))))
    (let ((edges (mapappend #'edges (territories territory-model))))
      (setf (edges territory-model) edges)
      (setf (points territory-model) (mapappend #'endpoints edges)))
    (setup-circulation-model territory-model))
    territory-model)))

(defun setup-umodel (plist &key use-spaces)
  ;; load design-model and territory-model if not already loaded?
  (let* ((use-model (apply #'make-instance 'use-model plist))
	 (territory-model (find-model (territory-model use-model) 'territory-model)))
    (unless territory-model
      (setq territory-model (load-territory-model nil (territory-model use-model))))
    (setf (territory-model use-model) territory-model)		;set backpointer?
    (loop for plist in use-spaces
	  do (add-use-space use-model (make-use-space plist territory-model)))
    use-model))


(defvar *data-dir* "designer:data;")

(defmethod model-filename ((model-name symbol) &optional (model-type 'design-model))
  ;; both args should be symbols
  (flet ((filename (x)
	   (merge-pathnames (concatenate 'string (symbol-name model-name)
					 (format nil "-~a" x) ".lisp")
		   *data-dir*)))
    (case model-type
      (design-model (filename 'design))
      (edge-model (filename 'edge))
      (territory-model (filename 'territory))
      (use-model (filename 'use)))))

(defmethod model-filename ((model basic-object) &optional model-type)
  model-type
  (model-filename (name model) (type-of model)))

(defun save-items (key things stream)
  (format stream "~&~s `(" key)
  (loop for x in things
	do (format stream "~&~s" (save-form x)))
  (format stream ")"))
			  
(defun save-design-model (design-model)
  (with-open-file (stream (model-filename design-model) :direction :output)
    (format stream "(in-package \"design\")")
    (format stream "~&(setup-dmodel `~s" (plist-for-save design-model))
    (save-items :design-elements (design-elements design-model) stream)
    (save-items :markers (markers-to-save design-model) stream)))

(defun save-territory-model (territory-model)
  (with-open-file (stream (model-filename territory-model) :direction :output)
    (format stream "(in-package \"design\")")
    (format stream "~&(setup-tmodel `~s" (plist-for-save territory-model))
    (save-items :edges (edges territory-model) stream)
    (save-items :territories (territories territory-model) stream)
    (format stream ")")))