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

;;; NET-OBJS

;;; Object defs for handling system / host type objects

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

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

(import '(user:editable-thing))

(eval-when (eval compile load)
  (defconstant obj-types
	       '(*reportable-thing*
		  *host* *system* *single-host-system*  *multi-host-system*
		  *network-host*  *chaos-host* *tcp-host*
		  *unix-host* *unix-numachine* *unix-machine*
		  *apollo*
		  *vax* *vax-vms* *vax-unix*
		  *imagen*
		  *lispm-host* *symbolics-host* *lambda*
		  *lam1* *lam1p* *lam2* *lam2p* *lam3*))
  (mapcar #'unintern obj-types))

(defkind *reportable-thing*)

(defclassvars *reportable-thing*
  (indent-level 0))

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

(defobfun (exist *reportable-thing*) (&rest args)
  (apply #'shadowed-exist args))

;;; Systems: maintained class vars are
;;;  multi-p [ T | NIL ]
;;;  hw-type <string>
;;;  is-a    <string>
;;;  indent-level <integer>
;;; Systems: maintained instance vars are
;;;  system-name

(defkind *system* editable-thing *reportable-thing*)

(defclassvars *system*
  hw-type 
  multi-p
  (is-a "SYSTEM"))

(definstancevars *system*
  system-name)

(defobfun (exist *system*) (&rest args &key name &allow-other-keys)
  (apply #'shadowed-exist args)
  (have 'system-name (or system-name name '<unnamed>)))

;;; Hosts: maintained class vars are
;;;  host-software  <symbol>
;;;  host-hardware <symbol>)
;;; Hosts: maintaned instance vars are
;;;  first-name      <string>
;;;  nicknames (<string> ... )

(defkind *host* editable-thing *reportable-thing*)

(defclassvars *host*
  host-software
  host-hardware
  (is-a "HOST"))

(definstancevars *host*
  first-name nicknames)

(defobfun (exist *host*) (&rest args &key name names &allow-other-keys)
  (apply #'shadowed-exist args)
  (have 'is-a "HOST")
  (have 'first-name (or first-name name '<unnamed>))
  (have 'nicknames
	(typecase names
	  (null nil)
	  (atom (ncons (string names)))
	  (cons (mapcar #'string-upcase names))))
  (infer))

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

(defobfun (report *host*) (&optional (s standard-output))
  (line-indent)
  (format
    s "~A ~A is a~@[n~*~] ~@[~A~] machine running ~A~@[, also known as ~~{~A~@[, ~]~}~~]"
    is-a
    (or first-name obj-name)
    (and host-hardware
	 (position (char (string host-hardware) 0) "AEIOUYaeiouy"))
    host-hardware host-software
    nicknames))

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

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

(defkind *single-host-system* *system* *host*)

(defobfun(exist *single-host-system*) (&rest args)
  (apply #'shadowed-exist args)
  (have 'multi-p nil)
  (have 'is-a "HOST/SYSTEM"))

(defobfun(infer *single-host-system*) ()
  (have 'obj-name (format nil "Host/system ~a ~a" first-name class-name))
  (have 'hw-type (or hw-type host-hardware))
  (have 'host-hardware (or host-hardware hw-type)))

(defobfun(report *single-host-system*) (&optional (s standard-output))
  (shadowed-report s))

(defkind *multi-host-system* *system*)

(defobfun(exist *multi-host-system*) (&rest args)
  (apply #'shadowed-exist args)
  (have 'multi-p t)
  (have 'is-a "MULTI-HOST SYSTEM")
  (infer))

(defobfun(infer *multi-host-system*) ()
  (have 'obj-name
	(format nil "System ~a~@[, including ~{~a~}~] ~a"
		system-name
		(mapcar #'(lambda(host) (ask host first-name)) hosts)
		class-name))
  (loop for host in hosts
	(ask host (have 'indent-level 1))))

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

(defobfun (report *multi-host-system*) (&optional (s standard-output))
  (line-indent)
  (format
    s "~A ~A is a ~A"
    is-a
    (or system-name obj-name)
    hw-type)
  (loop for host in hosts
	do (ask host (report))))


;;; ;;; Different network types

;;; Chaos hosts

(defkind *chaos-host* *host*)

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

(definstancevars *chaos-host* chaos@)

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

(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* *host*)

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

(definstancevars *tcp-host* tcp@)

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

(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@)))

;;; A network host can accomodate all the available network type(s)

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

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

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

(defobfun (exist *network-host*)(&rest args)
  (apply #'shadowed-exist args)
  (have 'networks
	(cond
	  ((null(or chaos@ tcp@)) nil)
	  ((and chaos@ tcp@) 'both)
	  (tcp@ 'tcp)
	  (chaos@ 'chaos))))

;;; ;;; Standard known host types

;;; Unix hosts

(defkind *unix-host* *network-host*)

(defclassvars *unix-host*
  (host-hardware 'unix)
  (host-software 'unix))

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

(defclassvars *unix-numachine*
  (host-hardware 'nu))

(defobfun (exist *unix-numachine*) (&rest args)
  (apply #'shadowed-exist args))

(defkind *unix-machine* *unix-host* *single-host-system*)

(defobfun (exist *unix-machine*) (&rest args)
  (apply #'shadowed-exist args))

(defkind *apollo* *unix-machine*)

;;; VAX hosts

(defkind *vax* *network-host* *single-host-system*)

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

(defobfun (exist *vax*) (&rest args)
  (apply #'shadowed-exist args))

(defkind *vax-vms* *vax*)

(defclassvars *vax-vms*
  (host-software 'vms))

(defobfun (exist *vax-vms*) (&rest args)
  (apply #'shadowed-exist args))

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

(defobfun (exist *vax-unix*) (&rest args)
  (apply #'shadowed-exist args))

;;; LISP machine hosts

(defkind *lispm-host* *network-host*)

(defclassvars *lispm-host*
  (hw-type 'lambda)
  (host-software 'lispm)
  (host-hardware 'lispm))

(defobfun (exist *lispm-host*) (&rest args)
  (apply #'shadowed-exist args))

;;; Symbolics

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

(defclassvars *symbolics-host*
  (hw-type 'symbolics)
  (file-system-type 'lmfs))

(defobfun (exist *symbolics-host*) (&rest args)
  (apply #'shadowed-exist args))

;;; Imagen

(defkind *imagen* *tcp-host* *single-host-system*)

(defclassvars *imagen*
  (hw-type 'imagen)
  (host-software 'imagen)
  (host-hardware 'imagen))


;;; Lambda hosts

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

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

(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 *lambda*) (&rest args)
  (apply #'shadowed-exist args))

(defobfun (exist *lam1*) (&rest args &key tcp slot0args &allow-other-keys)
  (apply #'shadowed-exist args)
  ;;Carry TCP surrogate address down?
  (when tcp
    (setq slot0args
	  (append (list :tcp tcp) (copy-list slot0args))))
  (have 'slot0 (apply #'oneof *lispm-host* 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)
  ;;Carry TCP surrogate address down?
  (when tcp
    (setq slot4args
	  (append (list :tcp tcp) (copy-list slot4args))))
  (have 'slot4 (apply #'oneof *lispm-host* 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)
  ;;Carry TCP surrogate address down?
  (when tcp
    (setq slot8args
	  (append (list :tcp tcp) (copy-list slot8args))))
  (have 'slot8 (apply #'oneof *lispm-host* slot8args))
  (setq hosts (list slot0 slot4 slot8)))


(defvar cs1)
(defvar it)
(defvar thing)
(defvar lurch)
(defvar cs2)
(defvar tish)
(defvar gomez)
(defvar fester)
(defvar cs3)
(defvar lmivax)
(defvar imagen)
(defvar angel)
(defvar myapollo)

(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))
  (setq lurch (ask cs1 unix))
  (ask cs1 (report))
  (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 cs2 slot0))
  (setq gomez (ask cs2 slot4))
  (setq fester (ask cs2 unix))
  (ask cs2 (report))
  ;;
  (setq lmivax (oneof *vax-vms*
                      :name 'lmi-vax :names 'csvax
                      :tcp "101.0.0.52"))
  (ask lmivax (report))
  ;;
  (setq imagen (oneof *imagen*
		      :name "IMA"  :names '("GIGAMOS-IMAGEN")
		      :tcp "101.0.0.57"))
  (ask imagen (report))
  ;;
  (setq angel (oneof *vax-unix*
		     :name 'angel :names '(lmi-angel)
		     :tcp "101.0.0.53"
		     :chaos #o3730))
  (ask angel (report))
  ;;
  (setq myapollo (oneof *apollo*
			:name 'bronwin :names '("bron" "lmi-apollo")
			:tcp "101.0.0.60"))
  (ask myapollo (report))
  )