;;; ;;; Self-ordering nets
;;;
;;; ;;; Utility sort functions
;;;
;;;

(defun net-equal(a b)
  (string-equal (string a) (string b)))

(defun net-lessp(a b)
  (string-lessp (string a) (string b)))

(defun netlist-lessp(a b)
  (cond ((and (not a)(not b)) t)
	((null a) b)
	((null b) nil)
	(t
	 (let (firsta resta firstb restb)
	   (if (listp a)
	       (setq firsta (car a) resta (cdr a))
	     (setq firsta a))
	   (if (listp b)
	       (setq firstb (car b) restb (cdr b))
	     (setq firstb b))
	   (cond
	     ((net-lessp firsta firstb) t)
	     ((net-equal firsta firstb) (netlist-lessp resta restb))
	     (t nil))))))

(defun host-lessp(a b)
  (string-lessp (string a) (string b)))

(defvar *std-net-sort* (list #'net-lessp))

(defvar *std-netlist-sort* (list #'netlist-lessp :key #'car))

(defvar *std-host-sort* (list #'host-lessp))

(defflavor ordered-net-mixin
	 ((net-order)
	  (net-sort *std-net-sort*)
	  (netlist-sort *std-netlist-sort*)
	  (host-sort *std-host-sort*))
	 (basic-net)
  (:inittable-instance-variables net-sort netlist-sort host-sort)
  (:settable-instance-variables net-sort netlist-sort host-sort)
  (:gettable-instance-variables net-order))

(defmethod (ordered-net-mixin :compute-net-order) ()
  (setq net-order nil)
  (loop for host in host-list
	as plist = (send self :host host)
	as host-nets = (getf plist :nets)
	as net-hosts = (assoc host-nets net-order)
	do
	(if net-hosts
	    (setq net-order
		  (cli:remove host-nets net-order
			      :key #'car
			      :test #'equal)))
	(push (cons host-nets (cons host (cdr net-hosts)))
	      net-order))
  (apply #'sort net-order netlist-sort))

(defmethod (ordered-net-mixin :order-nets) ()
  (apply #'sort net-list net-sort))

(defmethod (ordered-net-mixin :order-hosts) ()
  (apply #'sort host-list host-sort))

(defmethod (ordered-net-mixin :reorder)()
  (send self :order-nets)
  (send self :order-hosts)
  (send self :compute-net-order))

(defmethod (ordered-net-mixin :after :new-net) (&rest ignore)
  (send self :order-nets)
  (send self :compute-net-order))

(defmethod (ordered-net-mixin :after :new-host) (&rest ignore)
  (send self :order-hosts)
  (send self :compute-net-order))

(defmethod (ordered-net-mixin :after :pprint) (&optional (stream standard-output))
  (let((standard-output stream))
    (format t "~&Network physical layout~[ is not defined.; is:~:;s are:~]"
	    (length net-list))
    (format t "~{~&~5t~~s~~}" net-order)))

(compile-flavor-methods ordered-net-mixin)


;;; ;;; Self-validating nets
;;;

(defconst *valid-net-types* '(chaos tcp))

(defconst *valid-host-types*
	  '((lispm lispm)
	    (unix nu sun apollo dg sgi)
	    (vms vax)
	    (tops-20 pdp-10)
	    (foreign foreign)))

(defflavor validating-net-mixin
	 ((errors))
	 (basic-net)
  (:method-combination (:daemon-with-override :base-flavor-last :new-net :new-host)))

(defmethod (validating-net-mixin :fatal-error) (str &rest args)
  (apply #'ferror str args))

(defmethod (validating-net-mixin :continue-error) (error-str
						   &optional (resume-str "continue") str
						   &rest args)
  (let((format-str (string-append "Network validation, " error-str
				  (if str (string-append "~2&" str) "")
				   "~2&Press ~\lozenged-string\ to ~a, or"
				   "~&press ~\lozenged-string\ to give up.~%"))
       (format-args (append args (list "resume" resume-str "abort"))))
    (apply #'cerror :yes nil nil format-str format-args)))

(defmethod (validating-net-mixin :override :new-host) (host net &rest ignore)
  (when (send self :host host)
    (send self :continue-error "host ~s is already defined" "completely redefine it"
	  nil host)
    (send self :delete-host host)
    nil)
  (unless (send self :net net)
    (send self :continue-error "~s is not a valid network name" "define ~s it anyway"
	  nil host net))
  )

(compile-flavor-methods validating-net-mixin)


;;; ;;; Standard full-featured net  
;;;

(defflavor simple-net ()
	   (validating-net-mixin
	    ordered-net-mixin))