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

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

#| Picture of the world:
 
     NET
     ---
    /   \
    |    \
  SUBNET  SUBNET
   /  \    /  \
  /   |   |   |
 :    |   |  MACHINE
 :    |   |     |
 :  MACHINE     |
      |        .----------. 
      |-HOST-->|HOST-TABLE|
      |-HOST-->.----------.

|#

;;; ;;; Canonical host
;;;
;;; Hosts: maintained items are
;;;  :name      <string>
;;;  :type      (<system-type> <machine-type>)
;;;  :nicknames (<string> ... )
;;;  :ids       ( (<subnet> . <id> ... )

(defflavor basic-host
	 ((name)
	  (type (list :lispm :lispm))
	  (nicknames)
	  (ids))
	 ()
  :inittable-instance-variables
  :gettable-instance-variables
  :settable-instance-variables)

;;; ;;; Canonical machine
;
;;;  :name         <string>
;;;  :system-type  <keyword>
;;;  :machine-type <keyword>)
;;;  :multi-p      [ T | NIL]
;;;  :hosts        (<host> ... )

(defflavor basic-machine
	 ((name)
	  (multi-p t)
	  (system-type :lispm)
	  (machine-type :lispm)
	  (hosts))
	 ()
  :inittable-instance-variables
  :gettable-instance-variables
  :settable-instance-variables)

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

(defflavor basic-subnet
	 ((name)
	  (machines)
	  (type :chaos)
	  (id 7))
	 ()
  :inittable-instance-variables
  :gettable-instance-variables
  :settable-instance-variables)

;;; ;;; Canonical network
;;;
;;; Networks: maintained items are
;;;  :name     <string>
;;;  :subnets  (<list-of-subnets>)

(defflavor basic-net
	 ((name)
	  (subnets))
	 ()
  :inittable-instance-variables
  :gettable-instance-variables
  :settable-instance-variables)


;;; Accessing functions

;; Names, objects

(defmethod (basic-subnet :hosts) ()
  (loop for machine in machines
	appending (send machine :hosts)))

(defmethod (basic-net :hosts) ()
  (loop for subnet in subnets
	appending (send subnet :hosts)))

(defmethod (basic-machine :host-names) ()
  (loop for host in hosts
	collect (send host :name)))

(defmethod (basic-subnet :host-names) ()
  (loop for host in (send self :hosts)
	collect (send host :name)))

(defmethod (basic-net :host-names) ()
  (loop for host in (send self :hosts)
	collect (send host :name)))

(defmethod (basic-net :subnet-names) ()
  (loop for subnet in subnets
	collect (send subnet :name)))

(defmethod (basic-machine :type) ()
  (and system-type machine-type
       (cons system-type machine-type)))

;;; Adding objects

(defmethod (basic-machine :add-host) (host)
  (push host hosts)
  (if (null (send host :type))
      (send host :set-type (send self :type))))

(defmethod (basic-subnet :add-machine) (machine)
  (push machine machines))

(defmethod (basic-net :add-subnet) (subnet)
  (push subnet subnets))

;;; Finding stuff

(deff id-equal #'equal)

(defmethod (basic-machine :host-with) (key value)
  (loop for host in hosts
	until (id-equal (send host key) value)
	return host))

(defmethod (basic-machine :host-with-name) (named)
  (send self :host-with :name named))

(defmethod (basic-machine :host-with-id) (findid)
  (loop for host in hosts
	as ids = (send host :ids)
	until (rassq findid ids)
	return host))

(defmethod (basic-net :subnet-with) (key value)
  (loop for subnet in subnets
	until (id-equal (send subnet key) value)
	return subnet))

(defmethod (basic-net :subnet-with-id) (findid)
  (send self :subnet-with :id findid))

(defmethod (basic-net :subnet-with-name) (named)
  (send self :subnet-with :name named))

;; Printing

(defmethod (basic-host :pprint) (&optional (stream standard-output))
  (let((s stream))
    (format
      s
      "~&  HOST ~~s is a ~{~a machine running ~a~}~&also known as ~{~a~@[//~]~}~"
      name type nicknames)))

(defmethod (basic-machine :pprint) (&optional (stream standard-output))
  (let((s stream))
    (format
      s
      "~&--MACHINE ~s is a ~@[~*multi-processor ~]~a machine running ~a"
	    name multi-p machine-type system-type)
    (loop for host in hosts
	  do (send host :pprint))))

(defmethod (basic-subnet :pprint) (&optional (stream standard-output))
  (let((s stream))
    (format s "~&Subnet is: ~a." name)
    (loop for machine in machines
	  do (format t "~&")
	  (send machine :pprint))))

(defmethod (basic-net :pprint) (&optional (stream standard-output))
  (let((s stream)
       (host-list (send self :host-names)))
    (format s "~&")
    (format s "*** Network ~@[(~a) ~]has ~[no hosts.~:;~:*~s hosts:~]"
	    name (length host-list))
    (format s "~{~&~8t~~s~~}" host-list)
    (format s "~%")
    (loop for subnet in subnets
	  do (send subnet :pprint))
  ))

(compile-flavor-methods basic-host)
(compile-flavor-methods basic-machine)
(compile-flavor-methods basic-subnet)
(compile-flavor-methods basic-net)
	   

(defvar net)
(defvar chaos)
(defvar cs1)
(defvar it)
(defvar thing)

(defun test()
  (setq net (make-instance 'basic-net :name "LMI"))
  (setq chaos (make-instance 'basic-subnet :name "Chaos 1" :type :chaos))
  (setq cs1 (make-instance 'basic-machine :name "CS 1" :system-type :lispm :machine-type :lispm))
  (setq it (make-instance 'basic-host :name "it" :nicknames '("Cousin It")))
  (setq thing (make-instance 'basic-host :name "thing" :nicknames '("Thing")))
  (send net :add-subnet chaos)
  (send chaos :add-machine cs1)
  (send cs1 :add-host it)
  (send cs1 :add-host thing)
  (send net :pprint)
  net)