[pal-cvs] CVS pal-gui
tneste
tneste at common-lisp.net
Mon Oct 22 15:56:41 UTC 2007
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))
)))
More information about the Pal-cvs
mailing list