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