[pal-cvs] CVS pal-gui
tneste
tneste at common-lisp.net
Tue Oct 16 21:46:10 UTC 2007
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)
, at 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))
More information about the Pal-cvs
mailing list