;;;
;;; Create templates from Photon Application Builder window (.wgtw) files
;;; using built_in functions
;;;

(if (undefined_p PhabReadWidget)
    (require "PhotonTemplate"))

;;;
;;; Read all widget definitions from a previously opened file.
;;;

(defun photon_read_widgets (file)
  (let (widgets widget abversion)
    (setq abversion (read_line file))
    (if (!= (strncmp abversion "PhAB" 4) 0)
	(error (string "Widget file " file " has incorrect PhAB version: "
		       abversion))
      (progn
	(while (setq widget (PhabReadWidget file))
	  (setq widgets (cons widget widgets))
	  )
	(photon_create_levels widgets)
	)
      )
    )
  )

;;;
;;; Load all widget definitions from a file, returning an in_order list
;;; of all widget definitions, for use in the photon_create_widgets function
;;;

(defun open_path (filename mode)
  (if (not (equal (substr filename 0 1) "/"))
      (let (fptr (tpath (cons "." _require_path_)))
	(while (and (not fptr) tpath)
	  (setq fptr (open (string (car tpath) "/" filename) mode))
	  ;; (princ (string (car tpath) "/" filename) " --> " fptr "\n")
	  (setq tpath (cdr tpath))
	  )
	fptr
	)
    (open filename mode)
    )
  )

(defun photon_load_widgets (filename)
  (let (file widgets)
    (if (or (and (not (undefined_p internal)) (setq file (internal filename)))
	    (setq file (open_path filename "r")))
	(unwind_protect
	    (setq widgets (photon_read_widgets file))
	  (close file)
	  )
      )
    widgets
    )
  )
;;;
;;; Creates a set of widgets whose names have been created using the base
;;; name in the widget file with a prefix added.  Creates but does not
;;; realize the widgets.
;;;

(defun photon_create_levels (widgets)
  (let ((levels (make_array 0)) level (firstlevel 100000))
    (for i in widgets do
	 (setq level (car i))
	 (setq newentry (cons i (aref levels (+ level 1))))
	 (aset levels level (cons newentry (aref levels level)))
	 (aset levels (+ level 1) nil)
	 (if (> firstlevel level)
	     (setq firstlevel level))
	 )
    (aref levels firstlevel)
    )
  )

;;;
;;; Walk a widget hierarchy and set all of the named widgets to be
;;; global variables of that name.
;;;

(defun photon_name_hierarchy (widgets)
  (let (widget temp)
    (for i in widgets do
	 (setq widget (photon_wgtw_root i))
	 ;;(princ "Considering widget: " (class_name (class_of widget)) "\n")
	 (if (or (undefined_p (setq temp (eval (@ widget name))))
		 (nil_p temp)
		 (destroyed_p temp))
	     (progn
	       ;;(princ "Create type " (class_name (class_of widget)) "\n")
	       (set (@ widget name) widget)
	       ;;(princ "Create " (@ widget name) "\n")
	       )
	   ;;(princ "Un-named widget: " (class_name (class_of widget)) "\n")
	   )
	 (photon_name_hierarchy (photon_wgtw_children i))
	 )
    )
  )

;;;
;;; Search a widget hierarchy for a particular widget name.
;;;

(defun photon_lookup_name (widgets name prefix)
  (if prefix (setq name (symbol (string prefix name))))
  (if (not (list_p (car widgets)))
      (error "photon-lookup-name: widgets not in hierarchy format.\nTry passing (list widgets)"))
  (do ((x widgets (cdr x))
       (family (car x) (car x))
       result)
      ((or (not x) result) result)
      (if (eq name (@ (photon_wgtw_root family) name))
	  (setq result (photon_wgtw_root family))
	(setq result (photon_lookup_name (photon_wgtw_children family)
					 name nil))
	)
      )
  )

;;;
;;; wload function - loads a .wgtw file as a visible window
;;; Returns the family tree of the first widget in the tree, which
;;; is always the window.  The CAR of the return value is the
;;; actual PtWindow.
;;;

(defun wload (filename &optional (realize t))
  (let (hierarchy widgets)
    (if (setq widgets (photon_load_widgets filename))
	(progn
	  (setq hierarchy (PhabCreateWidgets widgets nil nil))
	  (photon_name_hierarchy hierarchy)
	  (if realize
	      (PtRealizeWidget (photon_wgtw_root (car hierarchy))))
	  )
      )
    (car hierarchy)
    )
  )

;;;
;;; Walk a widget hierarchy and set all of the named widgets to be
;;; global variables of that name.
;;;

(defun photon_add_template_to_class (myclass widgets)
  (let (widget temp name)
    (for i in widgets do
	 (setq widget (photon_wgtw_root i))
	 ;; (error "Stop here and look at widget")
	 (setq name (caddr widget))
	 (if (or (undefined_p (setq temp (eval name)))
		 (not (class_p temp))
		 (not (is_class_member temp PtWidget)))
	     (class_add_ivar myclass name nil))
	 (photon_add_template_to_class myclass (photon_wgtw_children i))
	 )
    )
  )

(defun PhabAttachWidgets (class filename)
  (if (class_p class)
      (let ()
	(if (not (has_cvar class '_phab_template_file))
	    (class_add_cvar class '_phab_template_file filename))
	(if (not (has_cvar class '_phab_template))
	    (class_add_cvar class '_phab_template nil))
	(if (not (@ class _phab_template))
	    (-> class _phab_template (photon_load_widgets
				      (@ class _phab_template_file))))
	(photon_add_template_to_class class
				      (@ class _phab_template))
	(defmethod class PhabInstantiate (&optional (use_root nil))
	  (PhabInstantiateTemplate self use_root))
	)
    (error "PhabAttachWidgets: expecting Class")
    )
  )

(defun phab_assign_template_ivars (inst widgets)
  (let (widget temp name)
    (for i in widgets do
	 (setq widget (photon_wgtw_root i))
	 (setq name (@ widget name))
	 (if (has_ivar inst name)
	     (:-> inst name widget))
	 (phab_assign_template_ivars inst (photon_wgtw_children i))
	 )
    )
  )

(defun PhabInstantiateTemplate (inst use_root)
  (let ((template (@ (class_of inst) _phab_template)) hierarchy)
    (if (not use_root)
	(setq template (PhabChildren (car template))))
    (setq hierarchy (PhabCreateWidgets template nil nil))
    (phab_assign_template_ivars inst hierarchy)
    (car hierarchy)
    )
  )

;;;
;;; Create some convenience functions for dealing with hierarchies
;;;

(setq photon_wgtw_children cdr)
(setq PhabChildren cdr)
(setq photon_wgtw_root car)
(setq PhabRoot car)

(setq PhabLoad wload)
(setq PhabLookupWidget photon_lookup_name)
(setq PhabNameWidgets photon_name_hierarchy)
(setq PhabReadWidgetFile photon_load_widgets)
(setq PhabReadWidgets photon_read_widgets)
