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

;;(require "PhotonWindow")

;;;
;;; Widget file reader which returns a list of widget resources without
;;; actually creating and realizing the widgets.
;;;

(defun photon_read_widget_name (file)
  (let (name)
    (if (eq (setq name (photon_read_one_sexp file)) _eof_)
	nil name)
    )
  )

(defun photon_read_widget_level (file)
  (let (n)
    (if (eq (setq n (photon_read_one_sexp file)) _eof_)
	nil
      (number n))
    )
  )

;;;
;;; Tries to read the minimum number of resources, which may be greater
;;; than one under rare circumstances.  Returns a list of lists, each
;;; one being (n value), where n is either a resource number or a
;;; resource name.
;;;

(defun photon_read_next_resources (file)
  (let ((resnum (photon_read_one_sexp file))
	restype resline resfunc resval)
    (if (and resnum (!= resnum 0)
	     (setq restype (photon_read_one_sexp file))
	     (setq resfunc (cdar (assoc restype datatypes)))
	     (setq resval ((eval resfunc) file resnum)))
	resval
      nil)
    )
  )

;;;
;;; Read one widget definition from a file, and store in a list as
;;;        (level class_name name ((n . value) ...))
;;; where n is either a number or a resource name.
;;;

(defun photon_read_one_widget (file)
  (let (typename widget resource level resources name)
    (if (setq typename (photon_read_one_sexp file))
	(progn
	  (setq level (photon_read_widget_level file))
	  (setq name (photon_read_widget_name file))
	  (while (setq resource (photon_read_next_resources file))
	    ;;(princ "Resource: " resource "\n")
	    (if (not (true_p (cdar resource)))
		(setq resources (nappend resources resource))
	      )
	    )
	  (setq widget (list level typename name resources))
	  )
      )
    widget
    )
  )

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

(defun photon_read_widgets (file)
  (let (widgets widget abversion)
    (setq abversion (photon_read_one_sexp file))
    ;; (princ "AB Version: " abversion "\n")
    (while (setq widget (photon_read_one_widget file))
      (setq widgets (cons widget widgets))
      ;;(princ "Loaded widget: " widget "\n")
      )
    ;; was a reverse here and in photon_create_levels.  We remove both.
    ;; (reverse 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 photon_load_widgets (filename)
  (let (file widgets)
    (if (or (setq file (internal filename))
	    (setq file (open 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)
    )
  )

;;;
;;; This function takes the hierarchical widget lists generated by
;;; photon_create_levels, and creates a widget hierarchy.  The return
;;; value is a widget hierarcy where each widget is stored as
;;;    (widget (children...))
;;; so a 3-deep hierarchy might look like this
;;;    ((widget1.1 ((widget1.2 (widget1.3)) (widget1.2.1)))
;;;     (widget2.1 ((widget2.2))))
;;;
;;; Essentially, this storage method combines widgets as a hierarchy
;;; where there may be more than one top_level widget.  Each top_level
;;; widget forms the root of a family.  The first widget in the family
;;; is always the top level for that family.  The children of the top
;;; level form their own sub_families from that point forth.  You may
;;; think of a widget hierarchy as a children set of the nil widget.
;;; 
;;; This is very confusing.  Try to avoid manipulating this hierarchy.
;;; If you must, use the functions:
;;;     photon_wgtw_children  - get the children in a widget family
;;;     photon_wgtw_root      - get the first widget in a (sub)family
;;;

(defun photon_make_widget (wdef parent name_prefix)
  (let (wlevel wtype wname resources widget)
    (setq wlevel (car wdef))
    (setq wtype (cadr wdef))
    (setq wname (caddr wdef))
    (setq resources (car (cdddr wdef)))
    (if (and (not (undefined_p (setq wtype (eval wtype))))
	     (class_p wtype))
	(progn
	  (if parent (PtSetParentWidget parent))
	  (setq widget (new wtype))
	  (if name_prefix
	      (setq wname (symbol (string name_prefix wname))))
	  (-> widget name wname)
	  (for j in resources do
	       (if (number_p (car j))
		   (setq rname (PtResourceName widget (car j)))
		 (setq rname (car j)))
	       (if rname (:-> widget rname (cdr j))))
	  widget)
      nil)
    )
  )

(defun photon_create_widgets (wdefs parent name_prefix)
  (let (widget_def children_defs widget children result)
    (if (not (has_ivar PtWidget 'name))
	(class_add_ivar PtWidget 'name))
    (if (not parent)
	(progn
	  (setq parent (PtSetParentWidget nil))
	  (PtSetParentWidget parent)))
    (for i in wdefs collect
	 (setq widget_def (car i))
	 (setq children_defs (cdr i))
	 (setq widget (photon_make_widget widget_def parent name_prefix))
	 (setq children (photon_create_widgets children_defs widget
					       name_prefix))
	 (cons widget children)
	 )
    )
  )

(defun photon_name_hierarchy (widgets)
  (let (widget)
    (for i in widgets do
	 (setq widget (photon_wgtw_root i))
	 ;;(princ "Considering widget: " (class_name (class_of widget)) "\n")
	 (if (undefined_p (eval (@ widget name)))
	     (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))
	 )
    )
  )

(defun photon_lookup_name (widgets name prefix)
  (if prefix (setq name (symbol (string prefix name))))
  (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 (photon_create_widgets widgets nil nil))
	  (photon_name_hierarchy hierarchy)
	  (if realize
	      (PtRealizeWidget (photon_wgtw_root (car hierarchy))))
	  )
      )
    (car hierarchy)
    )
  )

(setq photon_wgtw_children cdr)
(setq photon_wgtw_root car)

;;;
;;; Realize all widgets in a widget list.
;;;

(defun photon_realize_widgets (widgets)
  (for i in widgets do
       (PtRealizeWidget i)))

;;;
;;; Read one s_exp from a file
;;;

(defun photon_read_one_sexp (file)
  (let (retval)
    (setq retval (photon_read_whole_line file))
    (if (not (eq retval _eof_))
	(photon_read_from_string retval)
      nil)
    )
  )

;;;
;;; Read a single s_exp from a string
;;;

(setq photon_read_from_string parse_string)

;;;
;;; Read functions for the various photon data types
;;;

(setq datatypes '((dim . photon_read_point)
		  (cindex . photon_read_int)
		  (short . photon_read_int)
		  (crgb . photon_read_int)
		  (string . photon_read_string)
		  (flag . photon_read_flag)
		  (pos . photon_read_point)
		  (list . photon_read_list)
		  (data . photon_read_dummy)
		  (font . photon_read_string)
		  (bitmap . photon_read_bitmap)
		  (pixmap . photon_read_image)
		  (multi . photon_read_multi)
		  (points . photon_read_points)
		  (pnt . photon_read_point)
		  ))

(defun photon_read_points (file resnum)
  (let ((npts (number (read_line file))) x y result)
    (setq result (make_array npts))
    (do ((i 0 (++ i)))
	((>= i npts) (list (cons resnum result)))
	(setq x (read_short file))
	(setq y (read_short file))
	(aset result i (pos x y))
	)
    )
  )

(defun photon_read_whole_line (file)
  (let ((x (read_line file)))
    ;;(princ "Read: " x "\n")
    x)
  )

(defun photon_read_list (file resnum)
  (do ((x (photon_read_whole_line file) (photon_read_whole_line file))
       alllines)
      ((equal x "") (list (cons resnum (reverse alllines))))
      (setq alllines (cons x alllines))))

(defun photon_read_bitmap (file resnum)
  (let ((ncolors (number (photon_read_whole_line file)))
	(colormap (make_array ncolors))
	(bitmap (make_array ncolors))
	nbytes)
    (do ((i 0 (+ i 1)))
	((>= i ncolors))
	(aset colormap i (photon_read_one_sexp file)))
    (setq nbytes (photon_read_one_sexp file))
    (do ((i 0 (+ i 1)))
	((>= i ncolors))
	(aset bitmap i (read_n_chars file nbytes)))
    (list (cons 'bitmap_colors colormap)
	  (cons 'bitmap_data bitmap))
    )
  )

(defun photon_read_multi (file resnum)
  (let ((nchars (cdar (photon_read_int file nil))) value)
    (list (cons resnum (if (> nchars 0)
			   (buffer_to_string (read_n_chars file nchars))
			 "")))
    )
  )

(defun photon_read_dummy (file resnum)
  (photon_read_int file resnum)
  )

(defun photon_read_int (file resnum)
  (list (cons resnum (number (photon_read_whole_line file)))))

(defun photon_read_string (file resnum)
  (list (cons resnum (photon_read_whole_line file))))

(defun photon_read_flag (file resnum)
  (let ((sline (string_split (photon_read_whole_line file) "," 0))
	value)
    (setq value (number (car sline)))
    ;; This is not a mask.  What is it?
    ;; (setq mask (cadr sline))
    (setq mask -1)
    ;; Return a list of flag and mask to exactly set the flags instead
    ;; of applying them additively.
    (list (cons resnum (cons value mask)))
    )
  )
  
(defun photon_read_point (file resnum)
  (let ((sline (string_split (photon_read_whole_line file) "," 0))
	(point (new PhPoint)))
    (-> point x (number (car sline)))
    (-> point y (number (cadr sline)))
    (list (cons resnum point))
    )
  )

(defun photon_read_image (file resnum)
  (let ((image (new PhImage)) i palette)
    (-> image type (read_long file))
    ;; (princ "Image type " (@ image type) "\n")
    (-> image image_tag (read_long file))
    (-> image bpl (read_long file))
    (-> image size (new PhDim))
    (-> (@ image size) w (read_short file))
    (-> (@ image size) h (read_short file))
    (-> image palette_tag (read_long file))
    (-> image colors (read_long file))
    (-> image xscale (read_long file))
    (-> image yscale (read_long file))
    (-> image format (read_char file))
    (-> image flags (read_char file))
    (read_char file)			; spare1
    (read_char file)			; spare1
    (read_long file)			; spare2
    (read_long file)			; mask_bpl
    (read_long file)			; mask_bm
    (read_long file)			; palette_
    (read_long file)			; image_
    (setq palette (make_array (@ image colors)))
    (do ((i 0 (+ i 1)))
	((>= i (@ image colors)))
	(aset palette i (read_long file)))
    (-> image palette palette)
    ;; (princ "Image palette " (@ image palette) "\n")
    (-> image image (read_n_chars file (* (@ image bpl) (@ (@ image size) h))))

    (-> image image_tag 0)
    (list (cons resnum image))
    )
  )
