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