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

Modified Files: gob.lisp widgets.lisp Log Message: Improved packing.

--- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/15 22:53:16 1.3 +++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/16 00:16:41 1.4 @@ -13,6 +13,8 @@ (defclass gob () ((pos :accessor pos-of :initarg :pos :initform (v 0 0)) (parent :reader parent-of :initform nil) + (x-expand-p :accessor x-expand-p :initform nil :initarg :x-expand-p) + (y-expand-p :accessor y-expand-p :initform nil :initarg :y-expand-p) (activep :accessor activep :initform t :initarg :activep) (width :accessor width-of :initarg :width :initform 0) (height :accessor height-of :initarg :height :initform 0))) @@ -123,10 +125,19 @@

(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)))))))) + (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))))) + (dolist (c childs) + (when (y-expand-p c) + (setf (height-of c) (truncate exp-size exp-count))) + (when (x-expand-p c) + (setf (width-of c) (- width (* 2 xpad)))))) + (let ((cpos (v xpad ypad))) + (dolist (c (reverse childs)) + (setf (pos-of c) cpos) + (setf cpos (v+ cpos (v 0 (+ gap (height-of c)))))))))

@@ -136,12 +147,20 @@ (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)))))) + (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))))) + (dolist (c childs) + (when (x-expand-p c) + (setf (width-of c) (truncate exp-size exp-count))) + (when (y-expand-p c) + (setf (height-of c) (- height (* 2 ypad)))))) + (let ((cpos (v xpad ypad))) + (dolist (c (reverse childs)) + (setf (pos-of c) cpos) + (setf cpos (v+ cpos (v (+ gap (width-of c)) 0)))))))

--- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/15 22:53:16 1.3 +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/16 00:16:41 1.4 @@ -63,17 +63,30 @@

-(defclass window (widget v-packing sliding clipping) - ((color :accessor color-of :initform *window-color* :initarg :color)) - (:default-initargs :activep t :xpad (truncate (get-m) 2) :ypad (truncate (get-m) 2) :gap (truncate (get-m) 3) :pos (v 10 10))) +(defclass v-container (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 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)) +(defmethod repaint ((g v-container)) + (draw-rectangle (pos-of g) (width-of g) (height-of g) 0 0 0 64 :fill nil) + )

+(defclass h-container (widget h-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 h-container)) + (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))) + +(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))

@@ -82,12 +95,12 @@ (defclass button (widget) ((color :accessor color-of :initform *widget-color* :initarg :color) (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v))) - (value :accessor value-of :initform "" :initarg :value))) + (value :accessor value-of :initform "" :initarg :value)) + (:default-initargs :x-expand-p t))

-(defmethod initialize-instance :after ((g button) &key width &allow-other-keys) +(defmethod initialize-instance :after ((g button) &key &allow-other-keys) (multiple-value-bind (w h) (get-text-bounds (value-of g)) - (unless width - (setf (width-of g) w)) + (declare (ignore w)) (setf (height-of g) h)))

(defmethod repaint ((g button)) @@ -119,7 +132,7 @@ (min-value :accessor min-value-of :initarg :min-value :initform 0) (max-value :accessor max-value-of :initarg :max-value :initform 100) (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) - (:default-initargs :height (get-m))) + (:default-initargs :x-expand-p t))

(defmethod (setf value-of) (value (g h-gauge)) (setf (slot-value g 'value) (clamp (min-value-of g) value (max-value-of g)))) @@ -157,7 +170,7 @@ (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))) + (: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))))) @@ -190,7 +203,7 @@ (min-value :accessor min-value-of :initarg :min-value :initform 0) (max-value :accessor max-value-of :initarg :max-value :initform 100) (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) - (:default-initargs :activep nil :height (get-m))) + (:default-initargs :activep nil :x-expand-p t))

(defmethod (setf value-of) (value (g h-meter)) (setf (slot-value g 'value) (clamp (min-value-of g) value (max-value-of g)))) @@ -211,7 +224,7 @@ ((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 :width (* 6 (get-m)) :height (* 5 (get-m)))) + (:default-initargs :x-expand-p t))

(defmethod repaint ((g list-view)) @@ -231,18 +244,18 @@

(defclass list-box (widget h-packing) () - (:default-initargs :height (* 6 (get-m)) :width (* 5 (get-m)) :gap 3 :xpad 0 :ypad 0)) + (: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))) - (sl (make-instance 'v-slider :parent g - :max-value (* (get-m) (length items)) - :height (height-of g) - :page-size (height-of lv) - :on-drag (lambda (g pos d) - (declare (ignore pos d)) - (setf (scroll-of lv) (value-of g)) - nil)))))) + (let* ((lv (make-instance 'list-view :items items :parent g :height (height-of g) :width (width-of g)))) + (make-instance 'v-slider :parent g + :max-value (* (get-m) (length items)) + :height (height-of g) + :page-size (height-of lv) + :on-drag (lambda (g pos d) + (declare (ignore pos d)) + (setf (scroll-of lv) (value-of g)) + nil))))

(defmethod repaint ((g list-box)) (declare (ignore g))