;;;
;;; Parse and construct a window from a .wgtw file.
;;;

;;;
;;; This requires some other files
;;;

(require "PhotonWidgets")

;;;
;;; Add the 'name' instance variable to PtWidget if it is not there.
;;;

(if (not (has_ivar PtWidget 'name))
    (class_add_ivar PtWidget 'name nil))

;;;
;;; The complete widget class hierarchy has been mapped to a simple
;;; single_inheritance object oriented extension of LISP.  This allows
;;; us to subclass the widgets to add new instance variables, and to
;;; write methods which are inherited by all subclasses of the class.
;;;
;;; Add an extra variable to the PtWidget class: a name.  This
;;; method sets the name of the widget, and binds that widget to a symbol
;;; of its name in that symbol's current scope.  You should do this when
;;; the scope of the symbol is global.
;;;

(defmethod PtWidget rename (myname &optional prefix)
  (if (and (not (undefined_p prefix)) prefix)
      (setq myname (string prefix myname)))
  (if (not (string_p myname))
      (setq myname (string myname)))
  (-> self name myname)
  (set (symbol myname) self))

(defmethod PtWidget name (myname &optional prefix)
  (if (and (not (undefined_p prefix)) prefix)
      (setq myname (string prefix myname)))
  (if (not (string_p myname))
      (setq myname (string myname)))
  (if (not (or (undefined_p (eval (symbol myname)))
	       (destroyed_p (eval (symbol myname)))))
      (error (string "Widget name " myname " is already in use")))
  (-> self name myname)
  (set (symbol myname) self))

(setq widget_levels nil)

(setq datatypes '((dim . read_point)
		  (cindex . read_int)
		  (short . read_int)
		  (crgb . read_int)
		  (string . read_string)
		  (flag . read_flag)
		  (pos . read_point)
		  (list . read_list)
		  (data . read_dummy)
		  (font . read_string)
		  (bitmap . read_bitmap)
		  (pixmap . read_image)
		  (multi . read_multi)
		  (points . read_points)
		  (pnt . read_point)
		  ))

(defun read_points (file widget)
  (let ((npts (number (read_line file))) x y result)
    (setq result (make_array npts))
    (do ((i 0 (++ i)))
	((>= i npts) result)
	(setq x (read_short file))
	(setq y (read_short file))
	(aset result i (pos x y))
	)
    )
  )

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

(defun read_list (file widget)
  (do ((x (read_whole_line file) (read_whole_line file))
       alllines)
      ((equal x "") (reverse alllines))
      (setq alllines (cons x alllines))))

(defun read_bitmap (file widget)
  (let ((ncolors (number (read_whole_line file)))
	(colormap (make_array ncolors))
	(bitmap (make_array ncolors))
	nbytes)
    (do ((i 0 (+ i 1)))
	((>= i ncolors))
	(aset colormap i (read_one_sexp file)))
    (setq nbytes (read_one_sexp file))
    (do ((i 0 (+ i 1)))
	((>= i ncolors))
	(aset bitmap i (read_n_chars file nbytes)))
    (-> widget bitmap_colors colormap)
    (-> widget bitmap_data bitmap)
    t
    )
  )

(defun read_multi (file widget)
  (let ((nchars (read_int file widget)) value)
    (if (> nchars 0)
	(buffer_to_string (read_n_chars file nchars))
      "")))

(defun read_dummy (file widget)
  (read_int file widget)
  )

(defun read_int (file widget)
  (number (read_whole_line file)))

(defun read_string (file widget)
  (read_whole_line file))

(defun read_flag (file widget)
  (let ((sline (string_split (read_whole_line file) "," 0))
	value)
    (setq value (number (car sline)))
;    (princ "Flags: " sline "\n")
;    (if (cdr sline)
;	(setq value (bor (* 256 value) (number (cadr sline)))))
    ;; Return a list of flag and mask to exactly set the flags instead
    ;; of applying them additively.
    (cons value 0xffffffff)
    )
  )
  
(defun read_point (file widget)
  (let ((sline (string_split (read_whole_line file) "," 0))
	(point (new PhPoint)))
    (-> point x (number (car sline)))
    (-> point y (number (cadr sline)))
    point
    )
  )

(defun read_image (file widget)
  (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)			; spare2
    (read_long file)			; spare2
    (read_long file)			; unknown1
    (read_long file)			; unknown2
    (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)
    image
    )
  )

(defun read_from_string (s)
  (let ((sf (open_string s)) retval)
    (setq retval (read sf))
    (close sf)
    retval)
  )

(defun read_one_sexp (file)
  (let (retval)
    (setq retval (read_whole_line file))
    (if (not (eq retval _eof_))
	(read_from_string retval)
      nil)
    )
  )

(defun read_widget_level (file widget)
  (let (n)
    (if (setq n (read_one_sexp file))
	(progn
	  (if (> n 1)
	      (PtSetParentWidget (aref widget_levels (- n 1))))
	  )
      )
    (if (eq n _eof_) nil n)
    )
  )

(defun read_widget_name (file widget)
  (let (name)
    (if (setq name (read_one_sexp file))
	(progn
	  ;; (-> widget name name)
	  (if (or (undefined_p (eval name))
		  (destroyed_p (eval name)))
	      (widget name name)
	    )
	  )
      )
    (if (eq name _eof_) nil name)
    )
  )

(defun read_one_resource (file widget)
  (let ((resnum (read_one_sexp file))
	restype resline resfunc resname resval)
    (if (and resnum (!= resnum 0)
	     (setq restype (read_one_sexp file))
	     (setq resfunc (cdar (assoc restype datatypes)))
	     (setq resval ((eval resfunc) file widget)))
	(progn
	  (if (instance_p widget)
	      (progn
		(setq resname (PtResourceName widget resnum))
		;;(princ "Type: " restype ", func: " resfunc ", name: " resname
		;;", value: " resval "\n")
		(if resname
		    (if (and (eq resname 'arm_data)
			     (instance_p resval))
			(cons 'arm_image resval)
		      (cons resname resval))
		  (progn
		    (if (not (eq resfunc 'read_dummy))
			;;(princ "Type: " restype ", func: " resfunc
			;;", number: " resnum
			;;", name: " resname ", value: " resval "\n"
			;;"Resource: " restype " unknown in class "
			;;(class_name (class_of widget)) "\n")
			nil
		      )
		    (cons resname t))
		  )
		)
	    (cons resname t)
	    )
	  )
      (progn
	;;(princ "Could not read a resource: " resnum ", " restype ", " resfunc
	;;", " resval "\n")
	nil)
      )
    )
  )

(defun read_one_widget (file)
  (let (typename widget resource level)
    (if (setq typename (read_one_sexp file))
	(progn
	  (setq level (read_widget_level file widget))
	  (if (or (undefined_p (eval typename))
		  (not (class_p (eval typename)))
		  (destroyed_p (eval typename)))
	      (setq widget t)
	    (progn
	      (setq widget (new (eval typename)))
	      (aset widget_levels level widget))
	    )
	  (read_widget_name file widget)
	  (while (setq resource (read_one_resource file widget))
	    (if (not (true_p (cdr resource)))
		(progn
		  (:-> widget (car resource) (cdr resource))
		  )
	      )
	    )
	  (if (not (instance_p widget))
	      (princ "Widget not created: " typename "\n"))
	  )
      )
    widget
    )
  )

(defun build_window (file)
  (let (win widgets)
    (setq widget_levels (make_array 0))
    (let (widget abversion)
      (setq abversion (read_one_sexp file))
      ;; (princ "PhAB version: " abversion "\n")
      (while (setq widget (read_one_widget file))
	(if (not (true_p widget))
	    (progn
	      (setq widgets (cons widget widgets))
	      ;; (PtRealizeWidget widget)
	      )
	  )
	)
      )
    (reverse widgets)
    )
  )

(defun wload (filename)
  (let (file widgets)
    (if (setq file (open filename "r"))
	(unwind_protect
	    (if (setq widgets (build_window file))
		(PtRealizeWidget (car widgets))
	      (princ "Could not load widget file: " filename "\n")
	      )
	  (close file)
	  )
      )
    widgets
    )
  )

(defun wload_internal (identifier)
  (let (file widgets)
    (if (setq file (internal identifier))
	(unwind_protect
	    (if (setq widgets (build_window file))
		(PtRealizeWidget (car widgets))
	      (princ "Could not load internal widget: " filename "\n")
	      )
	  (close file)
	  )
      )
    widgets
    )
  )
