Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv6092
Modified Files: gob.lisp widgets.lisp Log Message: Fixed packing again...
--- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/22 12:03:35 1.7 +++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/22 15:56:40 1.8 @@ -153,13 +153,17 @@ (pack parent))
(defmethod min-width-of ((g v-packing)) - (+ (loop for c in (childs-of g) maximizing (min-width-of c)) (* 2 (xpad-of g)))) + (+ (loop for c in (childs-of g) maximizing (min-width-of c)) + (gap-of g) + (* 2 (xpad-of g))))
(defmethod min-height-of ((g v-packing)) - (+ (* (1- (length (childs-of g))) (gap-of g)) (* 2 (ypad-of g)) + (+ (* (1- (length (childs-of g))) (gap-of g)) + (* 2 (ypad-of g)) (loop for c in (childs-of g) summing (min-height-of c))))
(defmethod pack ((g v-packing)) + (with-accessors ((gap gap-of) (width width-of) (min-height min-height-of) (height height-of) (pos pos-of) (parent parent-of) (childs childs-of) (ypad ypad-of) (xpad xpad-of)) g (let* ((exp-count (count-if #'y-expand-p childs)) @@ -169,7 +173,7 @@ (when (y-expand-p c) (setf (height-of c) (max (min-height-of c) (truncate exp-size exp-count)))) (when (x-expand-p c) - (setf (width-of c) (- width (* 2 xpad)))))) + (setf (width-of c) (max 1 (- width (* 2 xpad))))))) (let ((cpos (v xpad ypad))) (dolist (c (reverse childs)) (setf (pos-of c) cpos) @@ -180,15 +184,16 @@
(defclass h-packing (v-packing) - ((xpad :accessor xpad-of :initarg :xpad :initform 0) - (ypad :accessor ypad-of :initarg :ypad :initform 0) - (gap :accessor gap-of :initarg :gap :initform 0))) + ())
(defmethod min-height-of ((g h-packing)) - (+ (loop for c in (childs-of g) maximizing (min-height-of c)) (gap-of g) (* 2 (ypad-of g)))) + (+ (loop for c in (childs-of g) maximizing (min-height-of c)) + (gap-of g) + (* 2 (ypad-of g))))
(defmethod min-width-of ((g h-packing)) - (+ (* (1- (length (childs-of g))) (gap-of g) (* 2 (xpad-of g))) + (+ (* (1- (length (childs-of g))) (gap-of g)) + (* 2 (xpad-of g)) (loop for c in (childs-of g) summing (min-width-of c))))
(defmethod pack ((g h-packing)) @@ -196,12 +201,12 @@ (parent parent-of) (childs childs-of) (ypad ypad-of) (xpad xpad-of)) g (let* ((exp-count (count-if #'x-expand-p childs)) (exp-size (- width (+ (* (1- (length (childs-of g))) (gap-of g)) (* 2 (xpad-of g)) - (loop for c in (childs-of g) summing (if (x-expand-p c) 0 (min-height-of c))))))) + (loop for c in (childs-of g) summing (if (x-expand-p c) 0 (min-width-of c))))))) (dolist (c childs) (when (x-expand-p c) (setf (width-of c) (max (min-width-of c) (truncate exp-size exp-count)))) (when (y-expand-p c) - (setf (height-of c) (- height (* 2 ypad)))))) + (setf (height-of c) (max 1 (- height (* 2 ypad))))))) (let ((cpos (v xpad ypad))) (dolist (c (reverse childs)) (setf (pos-of c) cpos) @@ -240,6 +245,17 @@
+(defclass highlighted () + ()) + +(defgeneric highlight (g)) + +(defmethod repaint :after ((g highlighted)) + (when (or (armedp g) (and (activep g) (pointedp g))) + (highlight g))) + + +
(defclass root (gob) () --- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/22 12:03:35 1.7 +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/22 15:56:41 1.8 @@ -1,8 +1,8 @@ (in-package :pal-gui)
-(defparameter *window-color* '(200 200 200 255)) -(defparameter *widget-color* '(210 210 210 255)) +(defparameter *window-color* '(140 140 140 160)) +(defparameter *widget-color* '(180 180 180 128)) (defparameter *text-color* '(0 0 0 255)) (defparameter *paper-color* '(255 255 200 255)) (defvar *gui-font* nil) @@ -82,7 +82,8 @@ (unless (funcall (on-leave-of g) g) (call-next-method)))
- +(defmethod highlight ((g widget)) + (draw-rectangle (v 0 0) (width-of g) (height-of g) 255 255 255 32))
@@ -117,6 +118,7 @@
+ (defclass filler (widget) () (:default-initargs :activep nil)) @@ -148,7 +150,7 @@ (with-accessors ((width width-of) (height height-of) (label label-of)) g (draw-rectangle (v 6 6) width height 0 0 0 64) (draw-frame (v 0 0) width height *window-color* :style :raised) - (draw-rectangle (v 0 0) width (get-m) 0 0 0 64) + (draw-rectangle (v 0 0) width (get-m) 0 0 0 128) (draw-line (v 0 (get-m)) (v width (get-m)) 0 0 0 160) (draw-line (v 0 (1+ (get-m))) (v width (1+ (get-m))) 0 0 0 64) (draw-line (v 0 (+ (get-m) 2)) (v width (+ (get-m) 2)) 0 0 0 32) @@ -158,7 +160,7 @@
-(defclass button (widget) +(defclass button (widget highlighted) ((value :accessor value-of :initform "" :initarg :value)) (:default-initargs :x-expand-p t))
@@ -166,14 +168,10 @@ (with-accessors ((width width-of) (height height-of) (value value-of)) g (cond ((armedp g) - (draw-frame (v 0 0) width height *widget-color* :style :sunken :border 2) + (draw-frame (v 0 0) width height *widget-color* :style :sunken) (with-transformation (:pos (v 1 1)) (with-blend (:color *text-color*) (present value g width height)))) - ((pointedp g) - (draw-frame (v 0 0) width height *widget-color* :border 2 :style :raised) - (with-blend (:color *text-color*) - (present value g width height))) (t (draw-frame (v 0 0) width height *widget-color* :style :raised) (with-blend (:color *text-color*) @@ -183,7 +181,7 @@
-(defclass h-gauge (widget) +(defclass h-gauge (widget highlighted) ((value :reader value-of :initarg :value :initform 0) (min-value :accessor min-value-of :initarg :min-value :initform 0) (max-value :accessor max-value-of :initarg :max-value :initform 100)) @@ -205,7 +203,7 @@ (k (truncate (* (/ (width-of g) (abs (- min-value max-value))) (- value min-value)))) (kpos (v (- k (truncate sw 2)) 0))) (draw-frame (v 0 (truncate m 3)) width (truncate height 2) *window-color* :style :sunken) - (draw-frame kpos sw m *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1)) + (draw-frame kpos sw m *widget-color* :style :raised) (draw-frame (v+ kpos (v (truncate sw 2) 0)) 3 (/ m 4) '(0 0 0 0) :style :sunken :fill nil) (draw-frame (v+ kpos (v (truncate sw 2) m)) 3 (- (/ m 4)) '(0 0 0 0) :style :sunken :fill nil) (with-blend (:color *text-color*) @@ -216,12 +214,12 @@
-(defclass v-slider (widget) +(defclass v-slider (widget highlighted) ((value :reader value-of :initarg :value :initform 0) (page-size :accessor page-size-of :initarg :page-size :initform 1) (min-value :accessor min-value-of :initarg :min-value :initform 0) (max-value :accessor max-value-of :initarg :max-value :initform 100)) - (:default-initargs :width (truncate (get-m) 2) :y-expand-p t)) + (:default-initargs :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) (funcall (page-size-of g)))))) @@ -241,7 +239,7 @@ (draw-frame (v 0 0) width height *window-color* :style :sunken) (draw-frame kpos width (min height (- height (* (- units ps) usize))) - *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1)) + *widget-color* :style :raised) (draw-frame (v+ kpos (v 1 (1- (truncate (min height (- height (* (- units ps) usize))) 2)))) (- width 2) 3 '(255 255 255 0) :style :sunken)))) @@ -305,10 +303,12 @@ (:default-initargs :gap 3 :y-expand-p t :x-expand-p t))
(defmethod initialize-instance :after ((g list-box) &key items (item-height (get-m)) &allow-other-keys) - (let* ((list-view (make-instance 'list-view :items items :item-height item-height :parent g)) - (slider-box (make-instance 'v-box :parent g :gap 0 :x-expand-p nil)) - (up-button (make-instance 'button :parent slider-box :x-expand-p nil :y-expand-p nil)) + (let* ((w (truncate (get-m) 1.5)) + (list-view (make-instance 'list-view :items items :item-height item-height :parent g)) + (slider-box (make-instance 'v-box :parent g :gap 0 :x-expand-p nil :width w)) + (up-button (make-instance 'button :parent slider-box :x-expand-p nil :y-expand-p nil :width w)) (slider (make-instance 'v-slider + :width w :parent slider-box :max-value (* item-height (length items)) :page-size (lambda () (height-of list-view)) @@ -316,7 +316,7 @@ (declare (ignore pos d)) (setf (scroll-of list-view) (value-of g)) nil))) - (down-button (make-instance 'button :parent slider-box :x-expand-p nil :y-expand-p nil)) + (down-button (make-instance 'button :parent slider-box :x-expand-p nil :y-expand-p nil :width w)) )))