[pal-cvs] CVS pal-gui
tneste
tneste at common-lisp.net
Mon Oct 22 19:25:24 UTC 2007
Update of /project/pal/cvsroot/pal-gui
In directory clnet:/tmp/cvs-serv7862
Modified Files:
gob.lisp gui.lisp widgets.lisp
Log Message:
--- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/22 15:56:40 1.8
+++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/22 19:25:24 1.9
@@ -17,16 +17,17 @@
(activep :accessor activep :initform t :initarg :activep)
(width :accessor width-of :initarg :width :initform 0)
(height :accessor height-of :initarg :height :initform 0)
- (min-width :accessor min-width-of :initarg :min-width)
- (min-height :accessor min-height-of :initarg :min-height)
+ (min-width :reader min-width-of :initarg :min-width)
+ (min-height :reader min-height-of :initarg :min-height)
(childs :reader childs-of :initform nil)))
-(defmethod initialize-instance :after ((g gob) &key (min-height) (min-width) (parent *root*) &allow-other-keys)
+(defmethod initialize-instance :after ((g gob) &key (min-height) (min-width) (parent *root*) (childs nil) &allow-other-keys)
(unless min-width
- (setf (min-width-of g) (width-of g)))
+ (setf (slot-value g 'min-width) (width-of g)))
(unless min-height
- (setf (min-height-of g) (height-of g)))
- (setf (parent-of g) parent))
+ (setf (slot-value g 'min-height) (height-of g)))
+ (setf (parent-of g) parent)
+ (setf (childs-of g) childs))
(defgeneric repaint (gob))
(defmethod repaint :around ((g gob))
@@ -115,6 +116,17 @@
(setf (slot-value parent 'childs) (remove child (slot-value parent 'childs))
(slot-value child 'parent) nil))
+(defgeneric abandon-all (parent))
+(defmethod abandon-all ((parent gob))
+ (dolist (c (childs-of parent))
+ (abandon parent c)))
+
+(defgeneric (setf childs-of) (childs parent))
+(defmethod (setf childs-of) (childs (parent gob))
+ (dolist (c childs)
+ (adopt parent c)))
+
+
(defgeneric (setf parent-of) (parent child))
(defmethod (setf parent-of) (parent (child gob))
(when (parent-of child)
@@ -140,8 +152,8 @@
(defclass v-packing (gob)
- ((xpad :accessor xpad-of :initarg :xpad :initform 0)
- (ypad :accessor ypad-of :initarg :ypad :initform 0)
+ ((x-pad :accessor x-pad-of :initarg :x-pad :initform 0)
+ (y-pad :accessor y-pad-of :initarg :y-pad :initform 0)
(gap :accessor gap-of :initarg :gap :initform 0)))
(defmethod adopt ((parent v-packing) (child gob))
@@ -155,26 +167,25 @@
(defmethod min-width-of ((g v-packing))
(+ (loop for c in (childs-of g) maximizing (min-width-of c))
(gap-of g)
- (* 2 (xpad-of g))))
+ (* 2 (x-pad-of g))))
(defmethod min-height-of ((g v-packing))
(+ (* (1- (length (childs-of g))) (gap-of g))
- (* 2 (ypad-of g))
+ (* 2 (y-pad-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
+ (parent parent-of) (childs childs-of) (y-pad y-pad-of) (x-pad x-pad-of)) g
(let* ((exp-count (count-if #'y-expand-p childs))
- (exp-size (- height (+ (* (1- (length (childs-of g))) (gap-of g)) (* 2 (ypad-of g))
- (loop for c in (childs-of g) summing (if (y-expand-p c) 0 (min-height-of c)))))))
+ (exp-size (- height (+ (* (1- (length (childs-of g))) (gap-of g)) (* 2 (y-pad-of g))
+ (loop for c in (remove-if 'y-expand-p (childs-of g)) summing (min-height-of c))))))
(dolist (c childs)
(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) (max 1 (- width (* 2 xpad)))))))
- (let ((cpos (v xpad ypad)))
+ (setf (width-of c) (max 1 (- width (* 2 x-pad)))))))
+ (let ((cpos (v x-pad y-pad)))
(dolist (c (reverse childs))
(setf (pos-of c) cpos)
(setf cpos (v+ cpos (v 0 (+ gap (height-of c)))))))
@@ -189,25 +200,25 @@
(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))))
+ (* 2 (y-pad-of g))))
(defmethod min-width-of ((g h-packing))
(+ (* (1- (length (childs-of g))) (gap-of g))
- (* 2 (xpad-of g))
+ (* 2 (x-pad-of g))
(loop for c in (childs-of g) summing (min-width-of c))))
(defmethod pack ((g h-packing))
(with-accessors ((gap gap-of) (height height-of) (min-width min-width-of) (width width-of) (pos pos-of)
- (parent parent-of) (childs childs-of) (ypad ypad-of) (xpad xpad-of)) g
+ (parent parent-of) (childs childs-of) (y-pad y-pad-of) (x-pad x-pad-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-width-of c)))))))
+ (exp-size (- width (+ (* (1- (length (childs-of g))) (gap-of g)) (* 2 (x-pad-of g))
+ (loop for c in (remove-if 'x-expand-p (childs-of g)) summing (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) (max 1 (- height (* 2 ypad)))))))
- (let ((cpos (v xpad ypad)))
+ (setf (height-of c) (max 1 (- height (* 2 y-pad)))))))
+ (let ((cpos (v x-pad y-pad)))
(dolist (c (reverse childs))
(setf (pos-of c) cpos)
(setf cpos (v+ cpos (v (+ gap (width-of c)) 0)))))
--- /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/22 12:03:35 1.4
+++ /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/22 19:25:24 1.5
@@ -32,11 +32,11 @@
(pal::do-event ,event key-up key-down ,mouse-motion-fn ,quit-fn)
, at redraw
(let ((g (first (last (active-gobs-at-point (get-mouse-pos) *root*)))))
- (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)))))
@@ -57,7 +57,7 @@
(defun active-gobs-at-point (point parent)
(let ((c (find-if (lambda (c)
(point-inside-p c point))
- (childs-of parent))))
+ (reverse (childs-of parent)))))
(if c
(if (activep c)
(cons c (active-gobs-at-point point c))
--- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/22 15:56:41 1.8
+++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/22 19:25:24 1.9
@@ -52,8 +52,8 @@
(defclass widget (gob)
((on-drag :accessor on-drag-of :initarg :on-drag :initform (lambda (widget pos d) (declare (ignore widget pos d)) nil))
(on-select :accessor on-select-of :initarg :on-select :initform (lambda (widget pos) (declare (ignore widget pos)) nil))
- (on-button-down :accessor on-button-down-of :initarg :on-button-down-select :initform (lambda (widget pos) (declare (ignore widget pos)) nil))
- (on-button-up :accessor on-button-up-of :initarg :on-button-up-select :initform (lambda (widget pos) (declare (ignore widget pos)) nil))
+ (on-button-down :accessor on-button-down-of :initarg :on-button-down :initform (lambda (widget pos) (declare (ignore widget pos)) nil))
+ (on-button-up :accessor on-button-up-of :initarg :on-button-up :initform (lambda (widget pos) (declare (ignore widget pos)) nil))
(on-enter :accessor on-enter-of :initarg :on-enter :initform (lambda (widget) (declare (ignore widget)) nil))
(on-leave :accessor on-leave-of :initarg :on-leave :initform (lambda (widget) (declare (ignore widget)) nil)))
(:default-initargs :width (get-m) :height (get-m)))
@@ -94,8 +94,8 @@
(defmethod initialize-instance :after ((g box) &key label)
(when label
- (setf (ypad-of g) (truncate (get-m) 2)
- (xpad-of g) (truncate (get-m) 2))))
+ (setf (y-pad-of g) (truncate (get-m) 2)
+ (x-pad-of g) (truncate (get-m) 2))))
(defmethod repaint ((g box))
(when (label-of g)
@@ -107,13 +107,13 @@
(defclass v-box (box v-packing)
()
- (:default-initargs :xpad 0 :ypad 0 :gap (truncate (get-m) 3)))
+ (:default-initargs :x-pad 0 :y-pad 0 :gap (truncate (get-m) 3)))
(defclass h-box (box h-packing)
()
- (:default-initargs :xpad 0 :ypad 0 :gap (truncate (get-m) 2)))
+ (:default-initargs :x-pad 0 :y-pad 0 :gap (truncate (get-m) 2)))
@@ -132,7 +132,7 @@
(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)))
+ (:default-initargs :activep t :width 100 :height 100 :x-pad (truncate (get-m) 2) :y-pad (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)))
@@ -148,7 +148,6 @@
(defmethod repaint ((g window))
(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 128)
(draw-line (v 0 (get-m)) (v width (get-m)) 0 0 0 160)
@@ -183,10 +182,11 @@
(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))
+ (min-value :reader min-value-of :initarg :min-value :initform 0)
+ (max-value :reader max-value-of :initarg :max-value :initform 100))
(:default-initargs :x-expand-p t))
+(defgeneric (setf value-of) (value g))
(defmethod (setf value-of) (value (g h-gauge))
(setf (slot-value g 'value) (clamp (min-value-of g) value (max-value-of g))))
@@ -216,15 +216,14 @@
(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))
+ (page-size :reader page-size-of :initarg :page-size :initform 1)
+ (min-value :reader min-value-of :initarg :min-value :initform 0)
+ (max-value :reader max-value-of :initarg :max-value :initform 100))
(: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))))))
-
(defmethod on-drag ((g v-slider) start-pos delta)
(let ((y (vy (v- start-pos delta))))
(setf (value-of g) (+ (truncate y (/ (height-of g) (abs (- (min-value-of g) (max-value-of g))))) (min-value-of g)))))
@@ -253,8 +252,8 @@
(defclass h-meter (widget)
((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))
+ (min-value :reader min-value-of :initarg :min-value :initform 0)
+ (max-value :reader max-value-of :initarg :max-value :initform 100))
(:default-initargs :activep nil :x-expand-p t))
(defmethod (setf value-of) (value (g h-meter))
@@ -275,24 +274,31 @@
(defclass list-view (widget)
- ((items :accessor items-of :initarg :items :initform '())
- (item-height :accessor item-height-of :initarg :item-height :initform (get-m))
- (scroll :accessor scroll-of :initform 0))
+ ((items :reader items-of :initarg :items :initform '())
+ (item-height :reader item-height-of :initarg :item-height :initform (get-m))
+ (scroll :reader scroll-of :initform 0))
(:default-initargs :x-expand-p t :y-expand-p t))
+(defgeneric (setf scroll-of) (value list-view))
+(defmethod (setf scroll-of) (value (g list-view))
+ (setf (slot-value g 'scroll)
+ (clamp 0 value (- (* (length (items-of g)) (item-height-of g)) (height-of g)))))
+
(defmethod repaint ((g list-view))
- (with-accessors ((width width-of) (height height-of) (ap absolute-pos-of) (item-height item-height-of)) g
+ (with-accessors ((width width-of) (height height-of) (scroll scroll-of) (ap absolute-pos-of) (item-height item-height-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*)
- (with-transformation (:pos (v 0 (scroll-of g)))
+ (with-transformation (:pos (v 0 (- (mod scroll item-height))))
(let ((y 0))
(dolist (i (items-of g))
- (when (oddp y)
- (draw-rectangle (v 0 0) width item-height 0 0 0 32))
- (present i g width item-height)
- (translate (v 0 item-height))
+ (when (and (> (* (1+ y) item-height) scroll)
+ (< (* y item-height) (+ scroll height)))
+ (when (oddp y)
+ (draw-rectangle (v 0 0) width item-height 0 0 0 32))
+ (present i g width item-height)
+ (translate (v 0 item-height)))
(incf y))))))))
@@ -306,7 +312,6 @@
(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
@@ -315,9 +320,28 @@
:on-drag (lambda (g pos d)
(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 :width w))
- )))
+ nil))))
+ (flet ((scroll-fn (d) (lambda (&rest rest)
+ (declare (ignore rest))
+ (incf (scroll-of list-view) (* d item-height))
+ (setf (value-of slider) (scroll-of list-view))
+ nil)))
+ (make-instance 'button
+ :parent slider-box
+ :x-expand-p nil
+ :y-expand-p nil
+ :width w
+ :height w
+ :on-button-down (scroll-fn -1)
+ :on-drag (scroll-fn -0.3))
+ (make-instance 'button
+ :parent slider-box
+ :x-expand-p nil
+ :y-expand-p nil
+ :width w
+ :height w
+ :on-button-down (scroll-fn 1)
+ :on-drag (scroll-fn 0.3)))))
More information about the Pal-cvs
mailing list