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) ,@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)))))