[pal-cvs] CVS pal-gui
tneste
tneste at common-lisp.net
Wed Oct 17 17:02:52 UTC 2007
Update of /project/pal/cvsroot/pal-gui
In directory clnet:/tmp/cvs-serv31543
Modified Files:
gob.lisp widgets.lisp
Log Message:
--- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/16 21:46:09 1.5
+++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/17 17:02:52 1.6
@@ -17,7 +17,8 @@
(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)))
+ (height :accessor height-of :initarg :height :initform 0)
+ (childs :reader childs-of :initform nil)))
(defmethod initialize-instance :after ((g gob) &key (parent *root*) &allow-other-keys)
@@ -27,7 +28,8 @@
(defgeneric repaint (gob))
(defmethod repaint :around ((g gob))
(with-transformation (:pos (pos-of g))
- (call-next-method)))
+ (call-next-method)
+ (repaint-childs g)))
(defgeneric lower (gob))
(defmethod lower ((g gob))
@@ -74,6 +76,10 @@
(defmethod on-select ((gob gob) pos)
nil)
+(defgeneric on-destroy (gob))
+(defmethod on-destroy ((gob gob))
+ nil)
+
(defgeneric on-drag (gob start-pos delta-pos))
(defmethod on-drag ((gob gob) start-pos delta)
(declare (ignore start-pos delta))
@@ -90,59 +96,53 @@
+(defgeneric pack (gob))
+(defmethod pack ((g gob))
+ (declare (ignore g))
+ nil)
-(defclass containing ()
- ((childs :reader childs-of :initform nil))
- (:default-initargs :activep nil))
-
-
-(defmethod repaint :around ((g containing))
- (call-next-method)
- (repaint-childs g))
-
-(defgeneric pack (containing))
-(defmethod pack ((g containing))
- (when (parent-of g)
- (pack (parent-of g))))
-
-(defgeneric repaint-childs (container))
-(defmethod repaint-childs ((g containing))
+(defgeneric repaint-childs (gob))
+(defmethod repaint-childs ((g gob))
(dolist (c (childs-of g))
(repaint c)))
(defgeneric adopt (parent child))
-(defmethod adopt ((parent containing) (child gob))
+(defmethod adopt ((parent gob) (child gob))
(setf (slot-value child 'parent) parent)
(push child (slot-value parent 'childs)))
(defgeneric abandon (parent child))
-(defmethod abandon ((parent containing) (child gob))
+(defmethod abandon ((parent gob) (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))
+(defmethod (setf parent-of) ((parent gob) (child gob))
(when (parent-of child)
(abandon (parent-of child) child))
(adopt parent child))
-(defgeneric min-height-of (containing))
-(defmethod min-height-of ((g containing))
- (+ (* (length (childs-of g)) (gap-of g))
- (loop for c in (childs-of g) summing (if (y-expand-p c) 0 (if (typep c 'containing)
- (min-height-of c)
- (height-of c))))))
-(defgeneric min-width-of (containing))
-(defmethod min-width-of ((g containing))
- (+ (* (length (childs-of g)) (gap-of g))
- (loop for c in (childs-of g) summing (if (x-expand-p c) 0 (if (typep c 'containing)
- (min-width-of c)
- (width-of c))))))
+(defgeneric min-height-of (gob))
+(defmethod min-height-of ((g gob))
+ (if (childs-of g)
+ (+ (* (length (childs-of g)) (gap-of g))
+ (loop for c in (childs-of g) summing (if (y-expand-p c) 0 (min-height-of c))))
+ (height-of g)))
+
+(defgeneric min-width-of (gob))
+(defmethod min-width-of ((g gob))
+ (if (childs-of g)
+ (+ (* (length (childs-of g)) (gap-of g))
+ (loop for c in (childs-of g) summing (if (x-expand-p c) 0 (min-width-of c))))
+ (width-of g)))
+
+
+
-(defclass v-packing (containing)
+(defclass v-packing (gob)
((xpad :accessor xpad-of :initarg :xpad :initform 0)
(ypad :accessor ypad-of :initarg :ypad :initform 0)
(gap :accessor gap-of :initarg :gap :initform 0)))
@@ -165,8 +165,7 @@
(setf (height-of c) (max 10 (truncate exp-size exp-count))))
(when (x-expand-p c)
(setf (width-of c) (- width (* 2 xpad))))
- (when (typep c 'containing)
- (pack c))))
+ (pack c)))
(let ((cpos (v xpad ypad)))
(dolist (c (reverse childs))
(setf (pos-of c) cpos)
@@ -190,8 +189,7 @@
(setf (width-of c) (max 10 (truncate exp-size exp-count))))
(when (y-expand-p c)
(setf (height-of c) (- height (* 2 ypad))))
- (when (typep c 'containing)
- (pack c))))
+ (pack c)))
(let ((cpos (v xpad ypad)))
(dolist (c (reverse childs))
(setf (pos-of c) cpos)
@@ -230,7 +228,7 @@
-(defclass root (gob containing)
+(defclass root (gob)
()
(:default-initargs :width (get-screen-width) :height (get-screen-height) :pos (v 0 0) :parent nil))
--- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/16 21:46:09 1.5
+++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/17 17:02:52 1.6
@@ -43,14 +43,33 @@
(draw-line (v+ pos (v (- width 1) (- height 1))) (v+ pos (v width 0)) 255 255 255 128)
(draw-line (v+ pos (v width (- height 1))) (v+ pos (v 0 height)) 255 255 255 128)))))
-(defun display-value (widget &optional value)
- (funcall (display-fn-of widget) (or value (value-of widget))))
+
+
+
+(defgeneric present (object gob width height))
+
+(defmethod present :around (object (g gob) width height)
+ (let ((ap (absolute-pos-of g)))
+ (with-clipping ((1+ (vx ap)) (1+ (vy ap)) (- (width-of g) 2) (- (height-of g) 2))
+ (call-next-method))))
+
+(defmethod present (object (g gob) width height)
+ (with-blend (:color *text-color*)
+ (draw-text (format nil "~a" object) (get-text-offset))))
+
+
(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-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-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))
+ (on-destroy :accessor on-destroy-of :initarg :on-destroy :initform (lambda (widget) (declare (ignore widget)) nil)))
+
(:default-initargs :width (get-m) :height (get-m)))
(defmethod on-drag :around ((g widget) pos d)
@@ -61,35 +80,55 @@
(unless (funcall (on-select-of g) g pos)
(call-next-method)))
+(defmethod on-button-down :around ((g widget) pos)
+ (unless (funcall (on-button-down-of g) g pos)
+ (call-next-method)))
+(defmethod on-button-up :around ((g widget) pos)
+ (unless (funcall (on-button-up-of g) g pos)
+ (call-next-method)))
+(defmethod on-enter :around ((g widget))
+ (unless (funcall (on-enter-of g) g)
+ (call-next-method)))
-(defclass box (widget containing)
- ()
+(defmethod on-leave :around ((g widget))
+ (unless (funcall (on-leave-of g) g)
+ (call-next-method)))
+
+(defmethod on-destroy :around ((g widget))
+ (unless (funcall (on-destroy-of g))
+ (call-next-method)))
+
+
+
+
+(defclass box (widget)
+ ((label :accessor label-of :initform nil :initarg :label))
(:default-initargs :activep nil :x-expand-p t :y-expand-p t))
+(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))))
+
(defmethod repaint ((g box))
- (declare (ignore g))
- ;; (draw-rectangle (pos-of g) (width-of g) (height-of g) 0 0 0 64 :fill nil)
- )
+ (when (label-of g)
+ (draw-rectangle (v 0 0) (width-of g) (height-of g) 0 0 0 128 :fill nil)
+ (with-blend (:color *text-color*)
+ (draw-text (label-of g) (v- (get-text-offset) (v 0 (truncate (get-m) 2)))))))
-(defclass v-box (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 v-box))
- (declare (ignore g))
- ;; (draw-rectangle (pos-of g) (width-of g) (height-of g) 0 0 0 64 :fill nil)
- )
-(defclass h-box (widget h-packing)
+(defclass v-box (box v-packing)
()
- (:default-initargs :activep nil :x-expand-p t :y-expand-p t :xpad 0 :ypad 0 :gap (truncate (get-m) 1)))
+ (:default-initargs :xpad 0 :ypad 0 :gap (truncate (get-m) 3)))
-(defmethod repaint ((g h-box))
- (declare (ignore g))
- ;; (draw-rectangle (pos-of g) (width-of g) (height-of g) 0 0 0 64 :fill nil)
- )
+
+
+(defclass h-box (box h-packing)
+ ()
+ (:default-initargs :xpad 0 :ypad 0 :gap (truncate (get-m) 2)))
@@ -112,48 +151,48 @@
(defmethod initialize-instance :after ((g window) &key &allow-other-keys)
(setf (filler-of g) (make-instance 'filler :parent g :x-expand-p t)))
+(defmethod on-drag :around ((g window) start d)
+ (declare (ignore d))
+ (when (< (vy start) (get-m))
+ (call-next-method)))
+
(defmethod on-button-down ((g window) pos)
- (declare (ignore pos))
- (raise g))
+ (when (< (vy pos) (get-m))
+ (raise g)))
(defmethod repaint ((g window))
- (let ((th 6))
- (draw-rectangle (v 6 6) (width-of g) (height-of g) 0 0 0 64)
- (draw-frame (v 0 0) (width-of g) (height-of g) *window-color* :style :raised)
- (draw-rectangle (v 0 0) (width-of g) (get-m) 0 0 0 64)
- (draw-line (v 0 (get-m)) (v (width-of g) (get-m)) 0 0 0 160)
- (draw-line (v 0 (1+ (get-m))) (v (width-of g) (1+ (get-m))) 0 0 0 64)
- (draw-text (label-of g) (get-text-offset))))
+ (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 64)
+ (draw-line (v 0 (get-m)) (v width (get-m)) 0 0 0 160)
+ (draw-line (v 0 (1+ (get-m))) (v width (1+ (get-m))) 0 0 0 64)
+ (with-blend (:color '(255 255 255 255))
+ (draw-text label (get-text-offset)))))
(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 repaint ((g button))
- (let ((color (color-of g))
- (value (display-value g))
- (fpos (get-text-offset)))
+ (with-accessors ((width width-of) (height height-of) (value value-of)) g
(cond
((armedp g)
- (draw-frame (v 0 0) (width-of g) (height-of g) color :style :sunken :border 2)
+ (draw-frame (v 0 0) width height *widget-color* :style :sunken :border 2)
(with-blend (:color *text-color*)
- (draw-text value (v+ fpos (v 1 1)))
- ))
+ (present value g width height)))
((pointedp g)
- (draw-frame (v 0 0) (width-of g) (height-of g) color :border 2 :style :raised)
+ (draw-frame (v 0 0) width height *widget-color* :border 2 :style :raised)
(with-blend (:color *text-color*)
- (draw-text value fpos)
- ))
+ (present value g width height)))
(t
- (draw-frame (v 0 0) (width-of g) (height-of g) color :style :raised)
+ (draw-frame (v 0 0) width height *widget-color* :style :raised)
(with-blend (:color *text-color*)
- (draw-text value fpos))))))
+ (present value g width height))))))
@@ -162,8 +201,7 @@
(defclass h-gauge (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)
- (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v))))
+ (max-value :accessor max-value-of :initarg :max-value :initform 100))
(:default-initargs :x-expand-p t))
(defmethod (setf value-of) (value (g h-gauge))
@@ -175,20 +213,18 @@
(setf (value-of g) (+ (truncate x (/ (width-of g) (abs (- (min-value-of g) (max-value-of g))))) (min-value-of g)))))
(defmethod repaint ((g h-gauge))
- (let* ((vt (display-value g))
- (sw (get-text-bounds vt))
- (m (get-m))
- (k (truncate (* (/ (width-of g) (abs (- (min-value-of g) (max-value-of g)))) (- (value-of g) (min-value-of g)))))
- (kpos (v (- k (truncate sw 2)) 0)))
- (draw-frame (v 0 (truncate m 3)) (width-of g) (truncate (height-of g) 2) *window-color* :style :sunken)
-
- (draw-frame kpos sw m *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1))
- (draw-frame (v+ kpos (v (truncate sw 2) 0)) 3 m '(0 0 0 0) :style :sunken :fill nil)
-
- (with-blend (:color *widget-color*)
- (draw-text vt (v+ (v+ kpos (get-text-offset)) (v 1 1))))
- (with-blend (:color *text-color*)
- (draw-text vt (v+ kpos (get-text-offset))))))
+ (with-accessors ((width width-of) (height height-of) (value value-of) (min-value min-value-of) (max-value max-value-of)) g
+ (let* ((vt (princ-to-string value))
+ (sw (get-text-bounds vt))
+ (m (get-m))
+ (k (truncate (* (/ (width-of g) (abs (- min-value max-value))) (- value min-value))))
+ (kpos (v (- k (truncate sw 2)) 0)))
+ (draw-frame (v 0 (truncate m 3)) width (truncate height 2) *window-color* :style :sunken)
+ (draw-frame kpos sw m *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1))
+ (draw-frame (v+ kpos (v (truncate sw 2) 0)) 3 (/ m 4) '(0 0 0 0) :style :sunken :fill nil)
+ (draw-frame (v+ kpos (v (truncate sw 2) m)) 3 (- (/ m 4)) '(0 0 0 0) :style :sunken :fill nil)
+ (with-blend (:color *text-color*)
+ (draw-text vt (v+ kpos (get-text-offset)))))))
@@ -211,19 +247,19 @@
(setf (value-of g) (+ (truncate y (/ (height-of g) (abs (- (min-value-of g) (max-value-of g))))) (min-value-of g)))))
(defmethod repaint ((g v-slider))
- (let* ((units (abs (- (min-value-of g) (max-value-of g))))
- (ps (funcall (page-size-of g)))
- (usize (/ (height-of g) units))
- (k (truncate (* usize (- (value-of g) (min-value-of g)))))
- (kpos (v 0 k)))
- (draw-frame (v 0 0) (width-of g) (height-of g) *window-color* :style :sunken)
- (draw-frame kpos
- (width-of g)
- (min (height-of g) (- (height-of g) (* (- units ps) usize)))
- *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1))
- (draw-frame (v+ kpos (v 1 (1- (truncate (min (height-of g) (- (height-of g) (* (- units ps) usize))) 2))))
- (- (width-of g) 2)
- 3 '(255 255 255 0) :style :sunken)))
+ (with-accessors ((height height-of) (width width-of) (page-size page-size-of) (value value-of) (min-value min-value-of) (max-value max-value-of)) g
+ (let* ((units (abs (- min-value max-value)))
+ (ps (funcall page-size))
+ (usize (/ height units))
+ (k (truncate (* usize (- value min-value))))
+ (kpos (v 0 k)))
+ (draw-frame (v 0 0) width height *window-color* :style :sunken)
+ (draw-frame kpos width
+ (min height (- height (* (- units ps) usize)))
+ *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1))
+ (draw-frame (v+ kpos (v 1 (1- (truncate (min height (- height (* (- units ps) usize))) 2))))
+ (- width 2)
+ 3 '(255 255 255 0) :style :sunken))))
@@ -235,8 +271,7 @@
(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)
- (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v))))
+ (max-value :accessor max-value-of :initarg :max-value :initform 100))
(:default-initargs :activep nil :x-expand-p t))
(defmethod (setf value-of) (value (g h-meter))
@@ -246,52 +281,50 @@
(with-accessors ((width width-of) (height height-of) (min-value min-value-of) (max-value max-value-of) (value value-of)) g
(let* ( (k (truncate (* (/ width (abs (- min-value max-value))) (- value min-value)))) )
(draw-frame (v 0 0) width height *window-color* :style :sunken)
- (loop for x from 1 to k by 2 do
+ (loop for x from 1 to (- k 3) by 2 do
(draw-line (v x 1) (v x (1- height)) 148 148 148 255))
(with-blend (:color *widget-color*)
- (draw-text (display-value g) (v+ (v 1 1) (get-text-offset))))
+ (draw-text (princ-to-string value) (v+ (v 1 1) (get-text-offset))))
(with-blend (:color *text-color*)
- (draw-text (display-value g) (get-text-offset))))))
+ (draw-text (princ-to-string value) (get-text-offset))))))
(defclass list-view (widget)
((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))))
+ (item-height :accessor item-height-of :initarg :item-height :initform (get-m))
+ (scroll :accessor scroll-of :initform 0))
(:default-initargs :x-expand-p t :y-expand-p t))
(defmethod repaint ((g list-view))
- (with-accessors ((width width-of) (height height-of) (ap absolute-pos-of)) g
+ (with-accessors ((width width-of) (height height-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*)
- (let ((y 0))
- (dolist (i (items-of g))
- (when (oddp y)
- (draw-rectangle (v 0 (- (* y (get-m)) (scroll-of g))) width (get-m) 0 0 0 32))
- (draw-text (display-value g i) (v+ (get-text-offset) (v 0 (- (* y (get-m)) (scroll-of g)))))
- (incf y)))))))
+ (with-transformation (:pos (v 0 (scroll-of g)))
+ (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))
+ (incf y))))))))
-(defclass list-box (widget h-packing)
+(defclass list-box (h-box)
()
(: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)))
+(defmethod initialize-instance :after ((g list-box) &key items (item-height (get-m)) &allow-other-keys)
+ (let* ((lv (make-instance 'list-view :items items :item-height item-height :parent g)))
(make-instance 'v-slider :parent g
- :max-value (* (get-m) (length items))
+ :max-value (* item-height (length items))
:page-size (lambda () (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))
- nil)
\ No newline at end of file
+ nil))))
\ No newline at end of file
More information about the Pal-cvs
mailing list