;;; -*- Mode:LISP; Fonts:(MEDFNT); Readtable:CL; Base:10 -*-

(defkind box)

(defclassvars box down-pointer right-pointer)

(definstancevars box tag text
  (box-left-side #\|)
  (box-right-side #\|)
  (box-top  #\_)
  (box-bottom #\_))

(defkind standalone-box box)

(defkind down-box box)

(defclassvars down-box (down-pointer t))

(definstancevars down-box (down-line #\|))

(defkind right-box)

(defclassvars right-box (right-pointer t))

(definstancevars right-box (right-line #\-))

(defkind down-right-box down-box right-box)

(defclassvars down-right-box
  (down-pointer t)
  (right-pointer t))

(defconst test
	  '((chaos (label down
			  :tag "Chaos"
			  :network-id 7)
		   (it down
		       :tag "It"
		       :network-id 3741)
		   (thing down
			  :tag "Thing"
			  :network-id 3742)
		   (tish down-right
			 :tag "Morticia"
			 :network-id 3722))
	    (net1 (label down
			 :tag "Internet 101.0.0.0")
		  (tish standalone
			:network-id "101.0.0.1"))))

(defkind network-box box)

(definstancevars network-box (network-id))

(defobfun (deduce-text network-box) (&optional text-input)
  (cond
    (text-input (have 'text text-input))
    ((integerp network-id) (have 'text (format nil "#o~o" network-id)))
    ((stringp network-id) (have 'text text))
    (text t)
    (t  (have 'text ""))))

(defun make-box (kind &key tag network-id &allow-other-keys &aux this-box)
  (setq this-box (oneof network-box))
  (case kind
    (standalone (setq this-box (make-obj this-box standalone-box)))
    (down (setq this-box (make-obj this-box down-box)))
    (right (setq this-box (make-obj  this-box right-box)))
    (down-right (setq this-box (make-obj  this-box down-right-box)))
    (t (ferror nil "~s is not a box" kind)))
  (when tag (print 'got-tag) (ask this-box (have 'tag tag)))
  (when network-id (ask this-box (have 'network-id network-id)))
  (ask this-box (deduce-text))
  this-box)