;;; -*- Mode:LISP; Package:USER; Readtable:CL; Base:10; Fonts:(MEDFNT MEDFNB) -*-1    *

;1;; HOSTLISTS.LISP*

;1;; Host Entries*

;1;; host-entry-name*	1== <an uppercase string>
;;; host-nicknames*	1== ( {host-entry-name} truename )*
;1;; machine-type*	1== <a keyword>*
;1;; system-type*	1== <a keyword>*
;1;; server-or-user*	1== [:USER | :SERVER]*
;1;; chaos-address*	1== [<a fixnum> | NIL]*
;1;; internet-address*	1== [<a string> | NIL]*
;1;; plist*		1== ( { (keyword value) } )
;;; host-entry	*	1== (host-entry-name host-nicknames
;;;*				1machine-type system-type
;;;			       server-or-user*
;1;;*				1chaos-address internet-address*
;1;;*				1plist)*

(defun host-nicknames(truename nicknames)
  (remove ""
	  (remove-duplicates
	    (append
	      (sort (mapcar #'string-upcase nicknames)
		    #'(lambda(x y)
			(lessp (string-length x)
			       (string-length y))))
	      (ncons (string-upcase truename)))
	    :test #'string-equal)
	  :test #'string-equal))

(defstruct (host-entry
	     (:type list)
	     (:constructor create-host-entry
			   (name
			     nicknames
			     &key
			     machine-type
			     system-type
			     server-or-user
			     chaos-address
			     internet-address
			     &aux
			     (name (string-upcase name))
			     (nicknames (host-nicknames name nicknames))
			     (machine-type (intern (string-upcase machine-type) 'keyword))
			     (system-type (intern (string-upcase system-type) 'keyword))
			     (server-or-user (intern (string-upcase server-or-user) 'keyword))
			     (plist (let(plist)
				      (setf(getf plist :chaos) chaos-address)
				      (setf(getf plist :internet) internet-address)
				      plist))
			     1;;Because CommonLISP doesn't have to enforce :type slot declarations:*
			     (oktag (progn
				      (check-type name string)
				      (check-type nicknames list)
				      (check-type machine-type keyword)
				      (check-type system-type keyword)
				      (check-type server-or-user (member :user :server))
				      (check-type chaos-address (or null fixnum))
				      (check-type internet-address (or null string))
				      t)))))
  (name "<unnamed>" :type string)
  (nicknames (list name) :type list)
  (machine-type :LISPM :type symbol)
  (system-type :LISPM :type symbol)
  (server-or-user :USER :type symbol)
  (chaos-address nil :type (or null fixnum))
  (internet-address nil :type (or null string))
  (plist nil :type list)
  (oktag nil))

;1;; Host Lists*

;1;; tag*		1== <symbol>*		1"Tag for keeping/excluding hosts"*
;1;; tagdata*	1== <string>*		1"Additional data for identifying list"*
;1;; tagstring*	1== <string>*		1"Label for printing/displaying list"*
;1;; hosts*	1== ( {host-entry} )*	1"List of host-entry objects"*
;1;; keep-p*	1== <function>*		1"Function for keeping/excluding hosts;*
;1;;*					1 takes one arg, a host entry, and returns NIL*
;1;;*					1 to exclude host."*
;1;; compact-p*	1== [T | NIL]*		1"If excluding a host entry, T means keep a place*
;1;;*					1 for NIL values (excluded hosts) returned by KEEP-P;*
;1;;*					1 else, compact the list."*

(defstruct (host-list
	     (:type list)
	     (:constructor create-host-list
			   (tag tagdata
				&key tagstring keep-p compact-p
				&aux
				(tag (intern (string-upcase tag) 'keyword))
				(tagdata (string tagdata))
				(tagstring (or tagstring (format nil "~:(~a~) <~a>" tag tagdata)))
			   )))
  (tag 'Unnamed :type keyword)
  (tagdata "blank" :type string)
  tagstring
  (hosts nil :type list)
  (keep-p #'(lambda(host-entry)
	      (and host-entry
		   (getf (host-entry-plist host-entry) tag)
		   host-entry)))
  (compact-p nil))

(defun keep-host-entries(host-list)
  (setf (host-list-hosts host-list)
	(mapcar (host-list-keep-p host-list) (host-list-hosts host-list)))
  (if (host-list-compact-p host-list)
      (setf (host-list-hosts host-list)
	    (remove nil (host-list-hosts host-list)))))

(defun add-host (host-entry host-list)
  (setf (host-list-hosts host-list)
	(reverse(cons host-entry (reverse (host-list-hosts host-list)))))
  (keep-host-entries host-list))

(defun make-edit-host(host-entry)
  (if (stringp host-entry)
      (setq host-entry (create-host-entry host-entry nil)))
  (setq host-entry (copy-host-entry host-entry))
  (tv:choose-variable-values
    `((,(locf (host-entry-name host-entry)) "Name" :string)
      (,(locf (host-entry-nicknames host-entry)) "Nicknames" :string-list)))
  host-entry)

;1;; Tests*

(defun standard-host-lists()
  (let((main-list (create-host-list :hosts "" :tagstring "Hosts"
				   :keep-p #'identity))
       (chaos-list (create-host-list :chaos "hosts"))
       (internet-list (create-host-list :internet "hosts")))
    (values main-list chaos-list internet-list)))

(defvar hosts-l)
(defvar chaos-l)
(defvar internet-l)

(defvar foo1)
(defvar foo2)
(defvar foo3)
(defvar foo4)

(defun test()
  (print 'host-lists)
  (multiple-value-setq (hosts-l chaos-l internet-l)
    (standard-host-lists))
  (print 'hosts)
  (setq foo1 (create-host-entry "it" '("cousin-it" "lmi-cousin-it")
				:chaos-address #o3741
				:internet-address "100.0.0.50"))
  (setq foo2 (create-host-entry "thing" '("lmi-thing")
				:chaos-address #o3742
				:internet-address "100.0.0.50"))
  (setq foo3 (create-host-entry "opus" '("lmi-opus")
				:chaos-address #o3750))
  (setq foo4 (create-host-entry "lmi-vax" '("myvax")
				:internet-address "100.0.0.50"))
  (let((fools (list foo1 foo2 foo3 foo4))
       (lists (list hosts-l chaos-l internet-l)))
    (dolist(l lists)
      (dolist(foo fools)
	(add-host foo l)))))