Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv30295

Modified Files: gob.lisp widgets.lisp Log Message: Primitive widget packing.

--- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/15 21:55:55 1.2 +++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/15 22:53:16 1.3 @@ -9,6 +9,7 @@ (defvar *armed-gob* nil)

+ (defclass gob () ((pos :accessor pos-of :initarg :pos :initform (v 0 0)) (parent :reader parent-of :initform nil) @@ -95,25 +96,55 @@ (setf (slot-value child 'parent) parent) (push child (slot-value parent 'childs)))

-(defgeneric abandon (child)) -(defmethod abandon ((child gob)) - (when (parent-of child) - (setf (slot-value (parent-of child) 'childs) (remove child (slot-value (parent-of child) 'childs)) - (parent-of child) nil))) +(defgeneric abandon (parent child)) +(defmethod abandon ((parent containing) (child gob)) + (setf (slot-value parent 'childs) (remove child (slot-value parent 'childs)) + (parent-of child) nil))

(defgeneric (setf parent-of) (parent child)) (defmethod (setf parent-of) ((parent containing) (child gob)) - (abandon child) + (when (parent-of child) + (abandon (parent-of child) child)) (adopt parent child))

(defclass v-packing (containing) - ()) + ((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 adopt ((parent v-packing) (child gob)) + (call-next-method) + (pack parent)) + +(defmethod abandon ((parent v-packing) (child gob)) + (call-next-method) + (pack parent))

+(defgeneric pack (container)) +(defmethod pack ((g v-packing)) + (let ((pos (v (xpad-of g) (ypad-of g)))) + (dolist (c (reverse (childs-of g))) + (setf (pos-of c) pos) + (setf pos (v+ pos (v 0 (+ (gap-of g) (height-of c))))))))

+(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))) + +(defgeneric pack (container)) +(defmethod pack ((g h-packing)) + (let ((pos (v (xpad-of g) (ypad-of g)))) + (dolist (c (reverse (childs-of g))) + (setf (pos-of c) pos) + (setf pos (v+ pos (v (+ (gap-of g) (width-of c)) 0)))))) + + +

@@ -133,6 +164,14 @@

+(defclass clipping () + ()) + +(defmethod repaint-childs :around ((g clipping)) + (let ((ap (absolute-pos-of g))) + (with-clipping ((vx ap) (vy ap) (width-of g) (height-of g)) + (call-next-method)))) +

--- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/15 21:55:55 1.2 +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/15 22:53:16 1.3 @@ -7,6 +7,9 @@ (defparameter *paper-color* '(255 255 200 255))

+(defun get-m (&optional font) + (truncate (* (get-font-height font) 1.5))) + (defun get-text-bounds (string &optional font) (let ((fh (get-font-height font))) (values (max (truncate (* 1.5 fh)) (+ (get-text-size string) fh)) @@ -16,9 +19,6 @@ (let ((fh (get-font-height font))) (v (truncate fh 2) (truncate fh 4))))

-(defun get-m (&optional font) - (truncate (* (get-font-height font) 1.5))) - (defun draw-frame (pos width height color &key style (border 1)) (let ((pos (v-floor pos)) (width (truncate width)) @@ -63,9 +63,9 @@

-(defclass window (widget containing sliding) +(defclass window (widget v-packing sliding clipping) ((color :accessor color-of :initform *window-color* :initarg :color)) - (:default-initargs :activep t)) + (:default-initargs :activep t :xpad (truncate (get-m) 2) :ypad (truncate (get-m) 2) :gap (truncate (get-m) 3) :pos (v 10 10)))

(defmethod repaint ((g window)) (draw-rectangle (v+ (v 6 6) (pos-of g)) (width-of g) (height-of g) 0 0 0 64) @@ -219,25 +219,23 @@ (draw-frame pos width height *paper-color* :style :sunken) (with-clipping ((vx ap) (vy ap) width height) (with-blend (:color *text-color*) - (let ((pos (v+ pos (get-text-offset))) - (y 0)) + (let ((y 0)) (dolist (i (items-of g)) (when (oddp y) - (draw-rectangle (v- (v+ pos (v 0 (- (* y (get-m)) (scroll-of g)))) (get-text-offset)) width (get-m) 0 0 0 32)) - (draw-text (display-value g i) (v+ pos (v 0 (- (* y (get-m)) (scroll-of g))))) + (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))))) (incf y)))))))

-(defclass list-box (widget containing) +(defclass list-box (widget h-packing) () - (:default-initargs :height (* 6 (get-m)) :width (* 5 (get-m)))) + (:default-initargs :height (* 6 (get-m)) :width (* 5 (get-m)) :gap 3 :xpad 0 :ypad 0))

-(defmethod initialize-instance :after ((g list-box) &key pos items &allow-other-keys) - (let* ((lv (make-instance 'list-view :items items :pos pos :parent g :height (height-of g) :width (width-of g))) - (sl (make-instance 'v-slider :pos (v+ pos (v (+ (width-of lv) 3) 0)) - :parent g +(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))) + (sl (make-instance 'v-slider :parent g :max-value (* (get-m) (length items)) :height (height-of g) :page-size (height-of lv)