;;; -*- Mode:LISP; Package:USER; Base:10 -*-

;;; ;;; Flavor defs for handling network / host objects
;;;

;;; ;;; Canonical net 

(defflavor basic-net-mixin
	 ((name)
	  (net-list)
	  (net-plists)
	  (host-list)
	  (host-plists))
	 ()
  :inittable-instance-variables
  :gettable-instance-variables
  (:settable-instance-variables name))

;;; Nets: maintained plist items are 
;;;  :name      <string>
;;;  :type      [:tcp | :chaos]
;;;  :net-id    [<chaos-subnet-number> | <internet-network-id>]
;;;  :hosts     (<list-of-hosts>)

(defmethod (basic-net-mixin :add-net) (net plist)
  (setf (getf net-plists net)
	(or plist (list :name (string net))))
  (pushnew net net-list))

(defmethod (basic-net-mixin :new-net) (net &rest plist)
  (send self :add-net net (copy-list plist)))

(defmethod (basic-net-mixin :net) (net)
  (getf net-plists net))

(defmethod (basic-net-mixin :hosts) (net)
  (let ((plist (send self :net net)))
    (getf plist :hosts)))

(defmethod (basic-net-mixin :delete-net) (net)
  (cli:remove net net-list)
  (setf (getf net-plists net) nil))

(defmethod (basic-net-mixin :net-type) (net)
  (let((plist (send self :net net)))
    (getf plist :type)))

(defmethod (basic-net-mixin :chaos-subnet) (net &aux plist)
  (if (equal (setq plist (send self :net-type net))
	     'chaos)
      (getf plist :net-id)))

(defmethod (basic-net-mixin :internet-id) (net &aux plist)
  (if (equal (setq plist (send self :net-type net))
	     'tcp)
      (getf plist :net-id)))


;;; Hosts: maintained plist items are
;;;  :name      <string>
;;;  :type      (<system-type> <machine-type>)
;;;  :nets      (<list-of-nets>)
;;;  :address   [<chaos-id> | <internet-id>]
;;;  :nicknames (<string> ... )

(defmethod (basic-net-mixin :add-host) (host nets plist)
  (setq nets (if (atom nets) (list nets) nets))
  (setf (getf plist :nets)
	(union nets (getf plist :nets)))
  (setf (getf plist :name)
	(or (string host) (getf plist :name)))
  (setf (getf host-plists host) plist)
  (pushnew host host-list))

(defmethod (basic-net-mixin :new-host) (host nets &rest plist)
  (send self :add-host host nets (copy-list plist)))
  
(defmethod (basic-net-mixin :host) (host)
  (getf host-plists host))

(defmethod (basic-net-mixin :host-nets) (host)
  (let((plist (send self :host host)))
    (getf plist :nets)))

(defmethod (basic-net-mixin :delete-host) (host)
  (cli:remove host host-list)
  (setf (getf host-plists host) nil))

;; Miscellany

(defmethod (basic-net-mixin :pprint) (&optional (stream standard-output))
  (let((standard-output stream))
    (format t "~&")
    (format t "*** Network ~@[(~a) ~]has ~[no hosts.~:;~:*~s hosts:~]"
	    name (length host-list))
    (format t "~{~&~8t~~s~~}" host-list)
    (format t "~%")
  ))

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


;;; ;;; 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-mixin)
  (: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 :net)
	as net-hosts = (assoc host-nets net-order)
	do
	(if net-hosts
	    (setq net-order
		  (cli:remove host-nets net-order :key #'car)))
	(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-mixin)
  (: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))
	   
(defun test(&aux foo)
  (setq foo (make-instance 'simple-net :name "Andover"))
  (send foo :new-net 'tcp :address "100.0.0.0" :name "Tcp")
  (send foo :describe)
  (send foo :new-net 'chaos :network-id 7 :name "Chaos")
  (send foo :describe)
  (send foo :new-host 'it 'chaos :address #o3741 :name "Cousin It")
  (send foo :describe)
  foo)