;; -*- Mode:LISP; Package:(HOSTOBJ :USE (LISP OBJ GLOBAL)); Readtable:CL; Base:10 -*-

(unless (find-package 'hostobj)
	(make-package 'hostobj :use '(lisp obj global)))

(in-package 'hostobj :use '(lisp obj global))

;(import '(obj:defkind
;	   obj:defclassvars obj:definstancevars obj:defobfun
;	   obj:have obj:ask
;	   obj:remake-obj obj:exist
;	   user:editable-thing
;	   user:defobedit
;	   user:editlist user:editlabel
;	   user:edit user:editfunc))

(import '(user:editable-thing))

(eval-when (eval compile load)
  (defconstant obj-types
	       '(*simple-host*
		  *multi-host*
		  *network-host*
		  *chaos-host*
		  *tcp-host*
		  *lambda-tcp-host*
		  *unix-host*
		  *unix-chaos-host*
		  *unix-tcp-host*
		  *unix-numachine*
		  *lispm-host*
		  *lam1* *lam1p*
		  *lam2* *lam2p*
		  *lam3*))
  (mapcar #'unintern obj-types))

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

;;; Hosts: maintained vars are
;;;  first-name      <string>
;;;  multi-p [ T | NIL ]
;;;  system-type  <symbol>
;;;  machine-type <symbol>)
;;;  nicknames (<string> ... )
;;;  chaos@
;;;  tcp@

;;; ;;; Hosts can be single-processor (e.g. VAX) or multi-processor (e.g. lambda)

;;; ;;; Simple (single-processor) host
;;;

(defkind *simple-host* editable-thing)

(defclassvars *simple-host*
  hw-class hw-type 
  system-type
  machine-type
  (is-a "HOST")
  (multi-p nil)
  (indent-level 0))

(definstancevars *simple-host*
  first-name nicknames networks)

(defobfun (exist *simple-host*) (&rest args &key name names &allow-other-keys)
  (have 'first-name (or name 'unnamed))
  (have 'nicknames
	(typecase names
	  (null (ncons first-name))
	  (atom (ncons (string names)))
	  (cons (mapcar #'string names))))
  (apply #'shadowed-exist args)
  (infer))

(defobfun (infer *simple-host*) ()
  (have 'first-name (intern (string-upcase first-name)))
  (setq nicknames
	(remove ""
	  (remove-duplicates
	    (append
	      (sort (mapcar #'string-upcase nicknames)
		    #'(lambda(x y)
			(lessp (string-length x)
			       (string-length y))))
	      (ncons (string-upcase first-name)))
	    :test #'string-equal)
	  :test #'string-equal))
  (have 'obj-name (format nil "Host ~a" first-name)))

(defobfun (line-indent *simple-host*)(&optional (s standard-output))
  (format s "~&")
  (format s "~a" (make-string (* 2 indent-level)
			      :initial-element #\space)))

(defobfun (report *simple-host*) (&optional (s standard-output))
  (line-indent)
  (format
    s "~A ~A is a ~@[~A ~]~A machine running ~A~@[, also known as ~~{~A~@[, ~]~}~~]"
    is-a
    (or first-name obj-name)
    hw-type
    machine-type system-type
    (remove first-name nicknames :test #'string-equal)))

(defkind *multi-host* *simple-host*)

(defclassvars *multi-host*
  (multi-p t)
  (is-a "MACHINE"))

(definstancevars *multi-host*
  (hosts nil))

(defobfun (report *multi-host*) (&optional (s standard-output))
  (line-indent)
  (format
    s "~A ~A is a ~@[~A ~]~@[, also known as ~~{~A~@[, ~]~}~~]"
    is-a
    (or first-name obj-name)
    hw-type
    (remove first-name nicknames :test #'string-equal))
  (loop for host in hosts
	do (ask host (report))))


;;; ;;; Different network types

(defkind *network-host* *simple-host*)

(defclassvars *network-host*
  (indent-level 1))

(definstancevars *network-host*
  (subnets nil))

(defclassvars *network-host*
  file-system-type)

(defobfun (exist *network-host*)(&rest args)
  (apply #'shadowed-exist args)
  (if (null file-system-type)
      (have 'file-system-type system-type)))

;;; Chaos hosts

(defkind *chaos-host* *network-host*)

(defclassvars *chaos-host* (chaos t))

(definstancevars *chaos-host* chaos@)

(defobfun (exist *chaos-host*) (&rest args &key chaos &allow-other-keys)
  (if chaos (have 'chaos@ chaos))
  (apply #'shadowed-exist args))

(defobfun (report *chaos-host*) (&optional (s standard-output))
  (funcall #'shadowed-report s)
  (when chaos@
    (line-indent s)
    (format s "Its CHAOS address is #o~o." chaos@)))

;;; TCP hosts

(defkind *tcp-host* *network-host*)

(defclassvars *tcp-host* (tcp t))
(definstancevars *tcp-host* tcp@)

(defobfun (exist *tcp-host*) (&rest args &key tcp &allow-other-keys)
  (have 'tcp@ tcp)
  (apply #'shadowed-exist args))

(defobfun (report *tcp-host*) (&optional (s standard-output))
  (funcall #'shadowed-report s)
  (when tcp@
    (line-indent s)
    (format s "Its INTERNET address is ~s." tcp@)))

(defkind *lambda-tcp-host* *tcp-host* *chaos-host*)

(definstancevars *lambda-tcp-host*
  (surrogate nil))


;;; ;;; Standard known host types

;;; Unix hosts

(defkind *unix-host* *simple-host*)

(defclassvars *unix-host*
  (machine-type 'unix)
  (system-type 'unix))

(defkind *unix-chaos-host* *unix-host* *chaos-host*)

(defkind *unix-tcp-host* *unix-host* *tcp-host*)

(defkind *unix-numachine* *unix-chaos-host*)

(defclassvars *unix-numachine*
  (machine-type 'nu))

;;; VAX hosts

(defkind *vax*)

(defclassvars *vax*
  (hw-type 'vax))

(defkind *vax-vms* *vax*)

(defclassvars *vax*
  (system-type 'vms))

(defkind *vax-unix* *vax* *unix-host*)

;;; LISP machine hosts

(defkind *lispm-host* *chaos-host*)

(defclassvars *lispm-host*
  (system-type 'lispm)
  (machine-type 'lispm))

;;; Symbolics

(defkind *symbolics-host* *lispm-host*)

(defclassvars *symbolics-host*
  (file-system-type 'lmfs))

;;; Lambda hosts

(defkind *lambda* *multi-host* *lispm-host*)

(defclassvars *lambda*
  (hw-type 'lambda))

(defkind *lam1* *lambda*)

(defclassvars *lam1*
  (hw-type 'lambda))

(definstancevars *lam1*
  (slot0 (oneof *lispm-host*)))

(defkind *lam1p* *lam1*)

(defclassvars *lam1p*
  (hw-type 'lambda-plus))

(definstancevars *lam1p*
  (unix (oneof *unix-numachine*)))

(defkind *lam2* *lam1*)

(defclassvars *lam2*
  (hw-type 'lambda-2x2))

(definstancevars *lam2*
  (slot4 (oneof *lispm-host*)))

(defkind *lam2p* *lam2* *lam1p*)

(defclassvars *lam2p*
  (hw-type 'lambda-2x2-plus))

(defkind *lam3* *lam2*)

(defclassvars *lam3*
  (hw-type 'lambda-3x3))

(definstancevars *lam3*
  (slot8 (oneof *lispm-host*)))

;;; Lambda EXIST functions

(defobfun (exist *lam1*) (&rest args &key tcp slot0args &allow-other-keys)
  (apply #'shadowed-exist args)
  (have 'slot0 (apply #'oneof *lispm-host* slot0args))
  (when tcp
    (setq slot0
	  (remake-obj
	    slot0
	    *lispm-host*
	    (apply #'oneof *lambda-tcp-host* :tcp tcp slot0args))))
  (setq hosts (list slot0))
  )

(defobfun (exist *lam1p*) (&rest args)
  (apply #'shadowed-exist args)
  (let((unix-args (getf args :unix)))
    (have 'unix (apply #'oneof *unix-numachine* unix-args)))
  (setq hosts (list slot0 unix)))

(defobfun (exist *lam2*) (&rest args &key tcp slot4args &allow-other-keys)
  (apply #'shadowed-exist args)
  (have 'slot4 (apply #'oneof *lispm-host* slot4args))
  (when tcp
    (setq slot4
	  (remake-obj
	    slot4
	    *lispm-host*
	    (apply #'oneof *lambda-tcp-host* :tcp tcp :surrogate t slot4args))))
  (setq hosts (list slot0 slot4)))

(defobfun (exist *lam2p*) (&rest args)
  (apply #'shadowed-exist args)
  (setq hosts (list slot0 slot4 unix)))

(defobfun (exist *lam3*) (&rest args &key tcp slot8args &allow-other-keys)
  (apply #'shadowed-exist args)
  (have 'slot8 (apply #'oneof *lispm-host* slot8args))
  (when tcp
    (setq slot8
	  (remake-obj
	    slot8
	    *lispm-host*
	    (apply #'oneof *lambda-tcp-host* :tcp tcp :surrogate t slot8args))))
  (setq hosts (list slot0 slot8)))


(defvar cs1)
(defvar it)
(defvar thing)
(defvar lurch)
(defvar cs2)
(defvar tish)
(defvar gomez)
(defvar fester)
(defvar cs3)

(defun test()
  (setq cs1 (oneof *lam2p*
		   :name 'lmi-cs1 :names 'cs1
		   :slot0args '(:name lmi-it
				      :names ("cousin it" "lmi-it" "IT" "LMI-IT")
				      :chaos #o3741 )
		   :slot4args '(:name lmi-thing
				      :names ("thing")
				      :chaos #o3742)
		   :unix  '(:name lmi-lurch :names "lurch"
				  :chaos #o3743)))
  (setq it (ask cs1 slot0))
  (setq thing (ask cs1 slot4))
  (ask cs1 (show-own-vals))
  (setq cs2 (oneof *lam2p*
		   :name 'lmi-cs2 :names 'cs2
		   :tcp "101.0.0.51"
		   :slot0args '(:name lmi-morticia
				      :names ("tish" "morticia")
				      :chaos #o3722 )
		   :slot4args '(:name lmi-gomez
				      :names ("gomez")
				      :chaos #o3723)
		   :unix  '(:name lmi-fester :names "fester"
				  :chaos #o3724)))
  (setq tish (ask cs1 slot0))
  (setq gomez (ask cs1 slot4))
  (setq lurch (ask cs1 unix))
  (ask cs2 (show-own-vals))
  )