Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv9325

Modified Files: gob.lisp gui.lisp widgets.lisp Log Message: Several fixes, mostly in widget packing.

--- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/16 00:16:41 1.4 +++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/16 21:46:09 1.5 @@ -25,6 +25,19 @@ (push g *gobs*))

(defgeneric repaint (gob)) +(defmethod repaint :around ((g gob)) + (with-transformation (:pos (pos-of g)) + (call-next-method))) + +(defgeneric lower (gob)) +(defmethod lower ((g gob)) + (setf (slot-value (parent-of g) 'childs) + (cons g (remove g (childs-of (parent-of g)))))) + +(defgeneric raise (gob)) +(defmethod raise ((g gob)) + (setf (slot-value (parent-of g) 'childs) + (append (remove g (childs-of (parent-of g))) (list g))))

(defgeneric absolute-pos-of (gob)) (defmethod absolute-pos-of ((g gob)) @@ -87,11 +100,15 @@ (call-next-method) (repaint-childs g))

+(defgeneric pack (containing)) +(defmethod pack ((g containing)) + (when (parent-of g) + (pack (parent-of g)))) + (defgeneric repaint-childs (container)) (defmethod repaint-childs ((g containing)) - (with-transformation (:pos (pos-of g)) - (dolist (c (childs-of g)) - (repaint c)))) + (dolist (c (childs-of g)) + (repaint c)))

(defgeneric adopt (parent child)) (defmethod adopt ((parent containing) (child gob)) @@ -109,6 +126,21 @@ (abandon (parent-of child) child)) (adopt parent child))

+(defgeneric min-height-of (containing)) +(defmethod min-height-of ((g containing)) + (+ (* (length (childs-of g)) (gap-of g)) + (loop for c in (childs-of g) summing (if (y-expand-p c) 0 (if (typep c 'containing) + (min-height-of c) + (height-of c)))))) +(defgeneric min-width-of (containing)) +(defmethod min-width-of ((g containing)) + (+ (* (length (childs-of g)) (gap-of g)) + (loop for c in (childs-of g) summing (if (x-expand-p c) 0 (if (typep c 'containing) + (min-width-of c) + (width-of c)))))) + + +

(defclass v-packing (containing) ((xpad :accessor xpad-of :initarg :xpad :initform 0) @@ -123,17 +155,18 @@ (call-next-method) (pack parent))

-(defgeneric pack (container)) (defmethod pack ((g v-packing)) (with-accessors ((gap gap-of) (width width-of) (height height-of) (pos pos-of) (childs childs-of) (ypad ypad-of) (xpad xpad-of)) g (let* ((exp-count (count-if #'y-expand-p childs)) - (solids-need (loop for c in childs summing (if (y-expand-p c) 0 (+ gap (height-of c))))) - (exp-size (max 10 (- height solids-need (* 2 ypad))))) + (solids-need (min-height-of g)) + (exp-size (- height solids-need (* 2 ypad)))) (dolist (c childs) (when (y-expand-p c) - (setf (height-of c) (truncate exp-size exp-count))) + (setf (height-of c) (max 10 (truncate exp-size exp-count)))) (when (x-expand-p c) - (setf (width-of c) (- width (* 2 xpad)))))) + (setf (width-of c) (- width (* 2 xpad)))) + (when (typep c 'containing) + (pack c)))) (let ((cpos (v xpad ypad))) (dolist (c (reverse childs)) (setf (pos-of c) cpos) @@ -150,13 +183,15 @@ (defmethod pack ((g h-packing)) (with-accessors ((gap gap-of) (height height-of) (width width-of) (pos pos-of) (childs childs-of) (ypad ypad-of) (xpad xpad-of)) g (let* ((exp-count (count-if #'x-expand-p childs)) - (solids-need (loop for c in childs summing (if (x-expand-p c) 0 (+ gap (width-of c))))) - (exp-size (max 10 (- width solids-need (* 2 ypad))))) + (solids-need (min-width-of g)) + (exp-size (- width solids-need (* 2 xpad)))) (dolist (c childs) (when (x-expand-p c) - (setf (width-of c) (truncate exp-size exp-count))) + (setf (width-of c) (max 10 (truncate exp-size exp-count)))) (when (y-expand-p c) - (setf (height-of c) (- height (* 2 ypad)))))) + (setf (height-of c) (- height (* 2 ypad)))) + (when (typep c 'containing) + (pack c)))) (let ((cpos (v xpad ypad))) (dolist (c (reverse childs)) (setf (pos-of c) cpos) @@ -188,7 +223,7 @@

(defmethod repaint-childs :around ((g clipping)) (let ((ap (absolute-pos-of g))) - (with-clipping ((vx ap) (vy ap) (width-of g) (height-of g)) + (with-clipping ((1+ (vx ap)) (1+ (vy ap)) (- (width-of g) 2) (- (height-of g) 2)) (call-next-method))))

--- /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/15 21:55:55 1.2 +++ /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/16 21:46:09 1.3 @@ -33,11 +33,11 @@ (pal::do-event ,event key-up key-down ,mouse-motion-fn ,quit-fn) ,@redraw (let ((g (gob-at-point (get-mouse-pos)))) - (setf *pointed-gob* g) (cond (*armed-gob* (on-drag *armed-gob* *relative-drag-start-pos* (v- *drag-start-pos* (get-mouse-pos)))) - (t (when (and g (not (activep g))) + (t (setf *pointed-gob* g) + (when (and g (not (activep g))) (when *pointed-gob* (on-leave *pointed-gob*)) (on-enter g))))) --- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/16 00:16:41 1.4 +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/16 21:46:09 1.5 @@ -1,7 +1,7 @@ (in-package :pal-gui)

-(defparameter *window-color* '(160 160 160 160)) +(defparameter *window-color* '(160 160 160 128)) (defparameter *widget-color* '(180 180 180 255)) (defparameter *text-color* '(0 0 0 255)) (defparameter *paper-color* '(255 255 200 255)) @@ -19,7 +19,7 @@ (let ((fh (get-font-height font))) (v (truncate fh 2) (truncate fh 4))))

-(defun draw-frame (pos width height color &key style (border 1)) +(defun draw-frame (pos width height color &key style (border 1) (fill t)) (let ((pos (v-floor pos)) (width (truncate width)) (height (truncate height)) @@ -27,8 +27,10 @@ (g (second color)) (b (third color)) (a (fourth color))) - (draw-rectangle (v- pos (v border border)) (+ width (* 2 border) ) (+ height (* 2 border)) 0 0 0 a) - (draw-rectangle pos width height r g b a) + (when (> border 0) + (draw-rectangle (v- pos (v border border)) (+ width (* 2 border) ) (+ height (* 2 border)) 0 0 0 a)) + (when fill + (draw-rectangle pos width height r g b a)) (case style (:raised (draw-line (v+ pos (v 1 1)) (v+ pos (v width 0)) 255 255 255 128) @@ -62,31 +64,66 @@

+(defclass box (widget containing) + () + (:default-initargs :activep nil :x-expand-p t :y-expand-p t)) + +(defmethod repaint ((g box)) + (declare (ignore g)) + ;; (draw-rectangle (pos-of g) (width-of g) (height-of g) 0 0 0 64 :fill nil) + )

-(defclass v-container (widget v-packing) +(defclass v-box (widget v-packing) () (:default-initargs :activep nil :x-expand-p t :y-expand-p t :xpad 0 :ypad 0 :gap (truncate (get-m) 3)))

-(defmethod repaint ((g v-container)) - (draw-rectangle (pos-of g) (width-of g) (height-of g) 0 0 0 64 :fill nil) +(defmethod repaint ((g v-box)) + (declare (ignore g)) + ;; (draw-rectangle (pos-of g) (width-of g) (height-of g) 0 0 0 64 :fill nil) )

-(defclass h-container (widget h-packing) +(defclass h-box (widget h-packing) () - (:default-initargs :activep nil :x-expand-p t :y-expand-p t :xpad 0 :ypad 0 :gap (truncate (get-m) 3))) + (:default-initargs :activep nil :x-expand-p t :y-expand-p t :xpad 0 :ypad 0 :gap (truncate (get-m) 1)))

-(defmethod repaint ((g h-container)) - (draw-rectangle (pos-of g) (width-of g) (height-of g) 0 0 0 64 :fill nil) +(defmethod repaint ((g h-box)) + (declare (ignore g)) + ;; (draw-rectangle (pos-of g) (width-of g) (height-of g) 0 0 0 64 :fill nil) )

-(defclass window (v-container sliding clipping) - ((color :accessor color-of :initform *window-color* :initarg :color)) - (:default-initargs :activep t :width 100 :height 100 :xpad (truncate (get-m) 2) :ypad (truncate (get-m) 2) :gap (truncate (get-m) 3) :pos (v 10 10))) + + +(defclass filler (widget) + () + (:default-initargs :activep nil)) + +(defmethod repaint ((g filler)) + (declare (ignore g)) + nil) + + + +(defclass window (v-box sliding clipping) + ((filler :accessor filler-of) + (label :accessor label-of :initarg :label :initform "Untitled")) + (:default-initargs :activep t :width 100 :height 100 :xpad (truncate (get-m) 2) :ypad (truncate (get-m) 3) :gap (truncate (get-m) 3) :pos (v 10 10))) + +(defmethod initialize-instance :after ((g window) &key &allow-other-keys) + (setf (filler-of g) (make-instance 'filler :parent g :x-expand-p t))) + +(defmethod on-button-down ((g window) pos) + (declare (ignore pos)) + (raise g))

(defmethod repaint ((g window)) - (draw-rectangle (v+ (v 6 6) (pos-of g)) (width-of g) (height-of g) 0 0 0 64) - (draw-frame (pos-of g) (width-of g) (height-of g) (color-of g) :style :raised)) + (let ((th 6)) + (draw-rectangle (v 6 6) (width-of g) (height-of g) 0 0 0 64) + (draw-frame (v 0 0) (width-of g) (height-of g) *window-color* :style :raised) + (draw-rectangle (v 0 0) (width-of g) (get-m) 0 0 0 64) + (draw-line (v 0 (get-m)) (v (width-of g) (get-m)) 0 0 0 160) + (draw-line (v 0 (1+ (get-m))) (v (width-of g) (1+ (get-m))) 0 0 0 64) + (draw-text (label-of g) (get-text-offset))))

@@ -98,28 +135,23 @@ (value :accessor value-of :initform "" :initarg :value)) (:default-initargs :x-expand-p t))

-(defmethod initialize-instance :after ((g button) &key &allow-other-keys) - (multiple-value-bind (w h) (get-text-bounds (value-of g)) - (declare (ignore w)) - (setf (height-of g) h))) - (defmethod repaint ((g button)) (let ((color (color-of g)) - (value (funcall (display-fn-of g) (value-of g))) - (fpos (v+ (pos-of g) (get-text-offset)))) + (value (display-value g)) + (fpos (get-text-offset))) (cond ((armedp g) - (draw-frame (pos-of g) (width-of g) (height-of g) color :style :sunken :border 2) + (draw-frame (v 0 0) (width-of g) (height-of g) color :style :sunken :border 2) (with-blend (:color *text-color*) (draw-text value (v+ fpos (v 1 1))) )) ((pointedp g) - (draw-frame (pos-of g) (width-of g) (height-of g) color :border 2 :style :raised) + (draw-frame (v 0 0) (width-of g) (height-of g) color :border 2 :style :raised) (with-blend (:color *text-color*) (draw-text value fpos) )) (t - (draw-frame (pos-of g) (width-of g) (height-of g) color :style :raised) + (draw-frame (v 0 0) (width-of g) (height-of g) color :style :raised) (with-blend (:color *text-color*) (draw-text value fpos))))))

@@ -143,20 +175,18 @@ (setf (value-of g) (+ (truncate x (/ (width-of g) (abs (- (min-value-of g) (max-value-of g))))) (min-value-of g)))))

(defmethod repaint ((g h-gauge)) - (let* ((vt (funcall (display-fn-of g) (value-of g))) + (let* ((vt (display-value g)) (sw (get-text-bounds vt)) (m (get-m)) (k (truncate (* (/ (width-of g) (abs (- (min-value-of g) (max-value-of g)))) (- (value-of g) (min-value-of g))))) - (kpos (v+ (pos-of g) (v (- k (truncate sw 2)) 0)))) - (draw-frame (v+ (pos-of g) (v 0 (truncate m 3))) (width-of g) (truncate (height-of g) 2) *window-color* :style :sunken) + (kpos (v (- k (truncate sw 2)) 0))) + (draw-frame (v 0 (truncate m 3)) (width-of g) (truncate (height-of g) 2) *window-color* :style :sunken)

(draw-frame kpos sw m *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1)) - (draw-line (v+ kpos (v (truncate sw 2) 0)) - (v+ kpos (v (truncate sw 2) (/ m 8))) - 255 255 255 128) - (draw-line (v+ kpos (v (truncate sw 2) (- m (/ m 8)))) - (v+ kpos (v (truncate sw 2) m)) - 0 0 0 128 :size 2) + (draw-frame (v+ kpos (v (truncate sw 2) 0)) 3 m '(0 0 0 0) :style :sunken :fill nil) + + (with-blend (:color *widget-color*) + (draw-text vt (v+ (v+ kpos (get-text-offset)) (v 1 1)))) (with-blend (:color *text-color*) (draw-text vt (v+ kpos (get-text-offset))))))

@@ -173,7 +203,7 @@ (:default-initargs :width (truncate (get-m) 2) :y-expand-p t))

(defmethod (setf value-of) (value (g v-slider)) - (setf (slot-value g 'value) (clamp (min-value-of g) value (- (max-value-of g) (page-size-of g))))) + (setf (slot-value g 'value) (clamp (min-value-of g) value (- (max-value-of g) (funcall (page-size-of g))))))

(defmethod on-drag ((g v-slider) start-pos delta) @@ -182,14 +212,18 @@

(defmethod repaint ((g v-slider)) (let* ((units (abs (- (min-value-of g) (max-value-of g)))) + (ps (funcall (page-size-of g))) (usize (/ (height-of g) units)) (k (truncate (* usize (- (value-of g) (min-value-of g))))) - (kpos (v+ (pos-of g) (v 0 k)))) - (draw-frame (pos-of g) (width-of g) (height-of g) *window-color* :style :sunken) + (kpos (v 0 k))) + (draw-frame (v 0 0) (width-of g) (height-of g) *window-color* :style :sunken) (draw-frame kpos (width-of g) - (min (height-of g) (- (height-of g) (* (- units (page-size-of g)) usize))) - *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1)))) + (min (height-of g) (- (height-of g) (* (- units ps) usize))) + *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1)) + (draw-frame (v+ kpos (v 1 (1- (truncate (min (height-of g) (- (height-of g) (* (- units ps) usize))) 2)))) + (- (width-of g) 2) + 3 '(255 255 255 0) :style :sunken)))

@@ -209,13 +243,15 @@ (setf (slot-value g 'value) (clamp (min-value-of g) value (max-value-of g))))

(defmethod repaint ((g h-meter)) - (let* ((m (get-m)) - (k (truncate (* (/ (width-of g) (abs (- (min-value-of g) (max-value-of g)))) (- (value-of g) (min-value-of g))))) ) - (draw-frame (pos-of g) (width-of g) (height-of g) *window-color* :style :sunken) - (loop for x from 0 to k by 2 do - (draw-line (v+ (pos-of g) (v x 1)) (v+ (pos-of g) (v x (1- m))) 148 148 148 255)) - (with-blend (:color *text-color*) - (draw-text (funcall (display-fn-of g) (value-of g)) (v+ (pos-of g) (get-text-offset)))))) + (with-accessors ((width width-of) (height height-of) (min-value min-value-of) (max-value max-value-of) (value value-of)) g + (let* ( (k (truncate (* (/ width (abs (- min-value max-value))) (- value min-value)))) ) + (draw-frame (v 0 0) width height *window-color* :style :sunken) + (loop for x from 1 to k by 2 do + (draw-line (v x 1) (v x (1- height)) 148 148 148 255)) + (with-blend (:color *widget-color*) + (draw-text (display-value g) (v+ (v 1 1) (get-text-offset)))) + (with-blend (:color *text-color*) + (draw-text (display-value g) (get-text-offset))))))

@@ -224,19 +260,19 @@ ((items :accessor items-of :initarg :items :initform '()) (scroll :accessor scroll-of :initform 0) (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) - (:default-initargs :x-expand-p t)) + (:default-initargs :x-expand-p t :y-expand-p t))

(defmethod repaint ((g list-view)) - (with-accessors ((width width-of) (height height-of) (pos pos-of) (ap absolute-pos-of)) g - (draw-frame pos width height *paper-color* :style :sunken) + (with-accessors ((width width-of) (height height-of) (ap absolute-pos-of)) g + (draw-frame (v 0 0) width height *paper-color* :style :sunken) (with-clipping ((vx ap) (vy ap) width height) (with-blend (:color *text-color*) (let ((y 0)) (dolist (i (items-of g)) (when (oddp y) - (draw-rectangle (v+ pos (v 0 (- (* y (get-m)) (scroll-of g)))) width (get-m) 0 0 0 32)) - (draw-text (display-value g i) (v+ (v+ pos (get-text-offset)) (v 0 (- (* y (get-m)) (scroll-of g))))) + (draw-rectangle (v 0 (- (* y (get-m)) (scroll-of g))) width (get-m) 0 0 0 32)) + (draw-text (display-value g i) (v+ (get-text-offset) (v 0 (- (* y (get-m)) (scroll-of g))))) (incf y)))))))

@@ -247,11 +283,10 @@ (:default-initargs :gap 3 :xpad 0 :ypad 0 :y-expand-p t :x-expand-p t))

(defmethod initialize-instance :after ((g list-box) &key items &allow-other-keys) - (let* ((lv (make-instance 'list-view :items items :parent g :height (height-of g) :width (width-of g)))) + (let* ((lv (make-instance 'list-view :items items :parent g))) (make-instance 'v-slider :parent g :max-value (* (get-m) (length items)) - :height (height-of g) - :page-size (height-of lv) + :page-size (lambda () (height-of lv)) :on-drag (lambda (g pos d) (declare (ignore pos d)) (setf (scroll-of lv) (value-of g))