[pal-cvs] CVS pal-gui

[tneste]

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)