;;;
;;; Photon widget functions and methods for common tasks.
;;;

;;;
;;; Convenience functions for creating areas and points given arguments.
;;;

(defmethod PtWidget SetArea (x y w h)
  (let ((a {PhArea})
	(pos {PhPoint (x . 0) (y . 0)})
	(size {PhDim (w . 0) (h . 0)}))
    (-> pos x (if x x (@ @pos x)))
    (-> pos y (if y y (@ @pos y)))
    (-> size w (if w w (@ @dim w)))
    (-> size h (if h h (@ @dim h)))
    (-> a pos pos)
    (-> a size size)
    (-> self area a)
    )
  )

(defun pos (x y)
  (let ((p (new PhPoint)))
    (-> p x x)
    (-> p y y)
    p)
  )
  
(defmethod PtWidget SetPos (x y)
  (let ((pos {PhPoint}))
    (-> pos x x)
    (-> pos y y)
    (-> self pos pos)))

(defmethod PtWidget SetDim (w h)
  (let ((dim {PhDim}))
    (-> dim w (if (= (floor w) 0) 1 (floor w)))
    (-> dim h (if (= (floor h) 0) 1 (floor h)))
    (-> self dim dim)))

;;;
;;; Convenience methods for setting and testing bits in flag resources
;;;

(defmethod PtWidget SetBit (resname flag)
  (:-> self resname flag))

(defmethod PtWidget ClearBit (resname flag)
  (:-> self resname (cons flag nil)))

(defmethod PtWidget TestBit (resname flag)
  (if (> (band (:@ self resname) flag) 0) t nil))

;;;
;;; Copy function for any widget type
;;;
(setq _uncopied_resources_
      '(name _callbacks		; not actual widget resources
	     window_icon 	; causes crash
	     handles selected	; not actual resources
	     area		; duplicated with pos, dim
	     trans_pattern	; causes crash
	     help_topic		; causes crash
	     accel_key		; causes crash
	     fill_pattern	; causes crash
	     label_balloon	; returns bad non_zero value if absent
	     ))

(defun PtContainingParent (widget)
  (let ((p (PtGetParentMember (PtWidgetParent widget) PtContainer)))
    (if p p widget)))

(defmethod PtWidget Copy ()
  (let ((ivars (instance_vars self))
	(newparent (PtContainingParent self))
	(oldparent (PtSetParentWidget newparent))
	(wnew (new (class_of self))))
    (-> wnew dim @dim)
    (for ivar in ivars do
	 (if (not (find (car ivar) _uncopied_resources_))
	     (:-> wnew (car ivar) (cdr ivar))
	   )
	 )
    (PtSetParentWidget oldparent)
    wnew
    )
  )
