pal-cvs

pal-cvs@common-lisp.net

127 discussions

[pal-cvs] CVS pal-gui
by tneste 16 Oct '07

16 Oct '07

Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv9325 Modified Files: gob.lisp gui.lisp widgets.lisp Log Message: Several fixes, mostly in widget packing. --- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/16 00:16:41 1.4 +++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/16 21:46:09 1.5 @@ -25,6 +25,19 @@ (push g *gobs*)) (defgeneric repaint (gob)) +(defmethod repaint :around ((g gob)) + (with-transformation (:pos (pos-of g)) + (call-next-method))) + +(defgeneric lower (gob)) +(defmethod lower ((g gob)) + (setf (slot-value (parent-of g) 'childs) + (cons g (remove g (childs-of (parent-of g)))))) + +(defgeneric raise (gob)) +(defmethod raise ((g gob)) + (setf (slot-value (parent-of g) 'childs) + (append (remove g (childs-of (parent-of g))) (list g)))) (defgeneric absolute-pos-of (gob)) (defmethod absolute-pos-of ((g gob)) @@ -87,11 +100,15 @@ (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)) - (with-transformation (:pos (pos-of g)) - (dolist (c (childs-of g)) - (repaint c)))) + (dolist (c (childs-of g)) + (repaint c))) (defgeneric adopt (parent child)) (defmethod adopt ((parent containing) (child gob)) @@ -109,6 +126,21 @@ (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)))))) + + + (defclass v-packing (containing) ((xpad :accessor xpad-of :initarg :xpad :initform 0) @@ -123,17 +155,18 @@ (call-next-method) (pack parent)) -(defgeneric pack (container)) (defmethod pack ((g v-packing)) (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))))) + (solids-need (min-height-of g)) + (exp-size (- height solids-need (* 2 ypad)))) (dolist (c childs) (when (y-expand-p c) - (setf (height-of c) (truncate exp-size exp-count))) + (setf (height-of c) (max 10 (truncate exp-size exp-count)))) (when (x-expand-p c) - (setf (width-of c) (- width (* 2 xpad)))))) + (setf (width-of c) (- width (* 2 xpad)))) + (when (typep c 'containing) + (pack c)))) (let ((cpos (v xpad ypad))) (dolist (c (reverse childs)) (setf (pos-of c) cpos) @@ -150,13 +183,15 @@ (defmethod pack ((g h-packing)) (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))))) + (solids-need (min-width-of g)) + (exp-size (- width solids-need (* 2 xpad)))) (dolist (c childs) (when (x-expand-p c) - (setf (width-of c) (truncate exp-size exp-count))) + (setf (width-of c) (max 10 (truncate exp-size exp-count)))) (when (y-expand-p c) - (setf (height-of c) (- height (* 2 ypad)))))) + (setf (height-of c) (- height (* 2 ypad)))) + (when (typep c 'containing) + (pack c)))) (let ((cpos (v xpad ypad))) (dolist (c (reverse childs)) (setf (pos-of c) cpos) @@ -188,7 +223,7 @@ (defmethod repaint-childs :around ((g clipping)) (let ((ap (absolute-pos-of g))) - (with-clipping ((vx ap) (vy ap) (width-of g) (height-of g)) + (with-clipping ((1+ (vx ap)) (1+ (vy ap)) (- (width-of g) 2) (- (height-of g) 2)) (call-next-method)))) --- /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/15 21:55:55 1.2 +++ /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/16 21:46:09 1.3 @@ -33,11 +33,11 @@ (pal::do-event ,event key-up key-down ,mouse-motion-fn ,quit-fn) ,@redraw (let ((g (gob-at-point (get-mouse-pos)))) - (setf *pointed-gob* g) (cond (*armed-gob* (on-drag *armed-gob* *relative-drag-start-pos* (v- *drag-start-pos* (get-mouse-pos)))) - (t (when (and g (not (activep g))) + (t (setf *pointed-gob* g) + (when (and g (not (activep g))) (when *pointed-gob* (on-leave *pointed-gob*)) (on-enter g))))) --- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/16 00:16:41 1.4 +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/16 21:46:09 1.5 @@ -1,7 +1,7 @@ (in-package :pal-gui) -(defparameter *window-color* '(160 160 160 160)) +(defparameter *window-color* '(160 160 160 128)) (defparameter *widget-color* '(180 180 180 255)) (defparameter *text-color* '(0 0 0 255)) (defparameter *paper-color* '(255 255 200 255)) @@ -19,7 +19,7 @@ (let ((fh (get-font-height font))) (v (truncate fh 2) (truncate fh 4)))) -(defun draw-frame (pos width height color &key style (border 1)) +(defun draw-frame (pos width height color &key style (border 1) (fill t)) (let ((pos (v-floor pos)) (width (truncate width)) (height (truncate height)) @@ -27,8 +27,10 @@ (g (second color)) (b (third color)) (a (fourth color))) - (draw-rectangle (v- pos (v border border)) (+ width (* 2 border) ) (+ height (* 2 border)) 0 0 0 a) - (draw-rectangle pos width height r g b a) + (when (> border 0) + (draw-rectangle (v- pos (v border border)) (+ width (* 2 border) ) (+ height (* 2 border)) 0 0 0 a)) + (when fill + (draw-rectangle pos width height r g b a)) (case style (:raised (draw-line (v+ pos (v 1 1)) (v+ pos (v width 0)) 255 255 255 128) @@ -62,31 +64,66 @@ +(defclass box (widget containing) + () + (:default-initargs :activep nil :x-expand-p t :y-expand-p t)) + +(defmethod repaint ((g box)) + (declare (ignore g)) + ;; (draw-rectangle (pos-of g) (width-of g) (height-of g) 0 0 0 64 :fill nil) + ) -(defclass v-container (widget v-packing) +(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-container)) - (draw-rectangle (pos-of g) (width-of g) (height-of g) 0 0 0 64 :fill nil) +(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-container (widget h-packing) +(defclass h-box (widget h-packing) () - (:default-initargs :activep nil :x-expand-p t :y-expand-p t :xpad 0 :ypad 0 :gap (truncate (get-m) 3))) + (:default-initargs :activep nil :x-expand-p t :y-expand-p t :xpad 0 :ypad 0 :gap (truncate (get-m) 1))) -(defmethod repaint ((g h-container)) - (draw-rectangle (pos-of g) (width-of g) (height-of g) 0 0 0 64 :fill nil) +(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 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))) + + +(defclass filler (widget) + () + (:default-initargs :activep nil)) + +(defmethod repaint ((g filler)) + (declare (ignore g)) + nil) + + + +(defclass window (v-box sliding clipping) + ((filler :accessor filler-of) + (label :accessor label-of :initarg :label :initform "Untitled")) + (:default-initargs :activep t :width 100 :height 100 :xpad (truncate (get-m) 2) :ypad (truncate (get-m) 3) :gap (truncate (get-m) 3) :pos (v 10 10))) + +(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-button-down ((g window) pos) + (declare (ignore pos)) + (raise g)) (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)) + (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)))) @@ -98,28 +135,23 @@ (value :accessor value-of :initform "" :initarg :value)) (:default-initargs :x-expand-p t)) -(defmethod initialize-instance :after ((g button) &key &allow-other-keys) - (multiple-value-bind (w h) (get-text-bounds (value-of g)) - (declare (ignore w)) - (setf (height-of g) h))) - (defmethod repaint ((g button)) (let ((color (color-of g)) - (value (funcall (display-fn-of g) (value-of g))) - (fpos (v+ (pos-of g) (get-text-offset)))) + (value (display-value g)) + (fpos (get-text-offset))) (cond ((armedp g) - (draw-frame (pos-of g) (width-of g) (height-of g) color :style :sunken :border 2) + (draw-frame (v 0 0) (width-of g) (height-of g) color :style :sunken :border 2) (with-blend (:color *text-color*) (draw-text value (v+ fpos (v 1 1))) )) ((pointedp g) - (draw-frame (pos-of g) (width-of g) (height-of g) color :border 2 :style :raised) + (draw-frame (v 0 0) (width-of g) (height-of g) color :border 2 :style :raised) (with-blend (:color *text-color*) (draw-text value fpos) )) (t - (draw-frame (pos-of g) (width-of g) (height-of g) color :style :raised) + (draw-frame (v 0 0) (width-of g) (height-of g) color :style :raised) (with-blend (:color *text-color*) (draw-text value fpos)))))) @@ -143,20 +175,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 (funcall (display-fn-of g) (value-of g))) + (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+ (pos-of g) (v (- k (truncate sw 2)) 0)))) - (draw-frame (v+ (pos-of g) (v 0 (truncate m 3))) (width-of g) (truncate (height-of g) 2) *window-color* :style :sunken) + (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-line (v+ kpos (v (truncate sw 2) 0)) - (v+ kpos (v (truncate sw 2) (/ m 8))) - 255 255 255 128) - (draw-line (v+ kpos (v (truncate sw 2) (- m (/ m 8)))) - (v+ kpos (v (truncate sw 2) m)) - 0 0 0 128 :size 2) + (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)))))) @@ -173,7 +203,7 @@ (: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))))) + (setf (slot-value g 'value) (clamp (min-value-of g) value (- (max-value-of g) (funcall (page-size-of g)))))) (defmethod on-drag ((g v-slider) start-pos delta) @@ -182,14 +212,18 @@ (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+ (pos-of g) (v 0 k)))) - (draw-frame (pos-of g) (width-of g) (height-of g) *window-color* :style :sunken) + (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 (page-size-of g)) usize))) - *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1)))) + (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))) @@ -209,13 +243,15 @@ (setf (slot-value g 'value) (clamp (min-value-of g) value (max-value-of g)))) (defmethod repaint ((g h-meter)) - (let* ((m (get-m)) - (k (truncate (* (/ (width-of g) (abs (- (min-value-of g) (max-value-of g)))) (- (value-of g) (min-value-of g))))) ) - (draw-frame (pos-of g) (width-of g) (height-of g) *window-color* :style :sunken) - (loop for x from 0 to k by 2 do - (draw-line (v+ (pos-of g) (v x 1)) (v+ (pos-of g) (v x (1- m))) 148 148 148 255)) - (with-blend (:color *text-color*) - (draw-text (funcall (display-fn-of g) (value-of g)) (v+ (pos-of g) (get-text-offset)))))) + (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 + (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)))) + (with-blend (:color *text-color*) + (draw-text (display-value g) (get-text-offset)))))) @@ -224,19 +260,19 @@ ((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 :x-expand-p t)) + (:default-initargs :x-expand-p t :y-expand-p t)) (defmethod repaint ((g list-view)) - (with-accessors ((width width-of) (height height-of) (pos pos-of) (ap absolute-pos-of)) g - (draw-frame pos width height *paper-color* :style :sunken) + (with-accessors ((width width-of) (height height-of) (ap absolute-pos-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+ 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))))) + (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))))))) @@ -247,11 +283,10 @@ (: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)))) + (let* ((lv (make-instance 'list-view :items items :parent g))) (make-instance 'v-slider :parent g :max-value (* (get-m) (length items)) - :height (height-of g) - :page-size (height-of lv) + :page-size (lambda () (height-of lv)) :on-drag (lambda (g pos d) (declare (ignore pos d)) (setf (scroll-of lv) (value-of g))

1 0

[pal-cvs] CVS pal-gui/examples
by tneste 16 Oct '07

16 Oct '07

Update of /project/pal/cvsroot/pal-gui/examples In directory clnet:/tmp/cvs-serv9325/examples Modified Files: test.lisp Log Message: Several fixes, mostly in widget packing. --- /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/16 00:16:41 1.4 +++ /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/16 21:46:09 1.5 @@ -5,22 +5,35 @@ (defun test () (with-gui (:paths (merge-pathnames "examples/" pal::*pal-directory*)) - (let* ((window (make-instance 'window :pos (v 200 200) :width 300 :height 200)) + (let* ((window (make-instance 'window :pos (v 200 200) :width 300 :height 230)) (window-2 (make-instance 'window :width 200 :height 300)) - (cont (make-instance 'h-container :parent window)) - (cont-2 (make-instance 'v-container :parent cont)) - (meter (make-instance 'h-meter :parent cont :max-value 80 :display-fn (lambda (v) (format nil "FPS: ~a" v)))) - (gauge (make-instance 'h-gauge :parent cont-2 - :min-value 0 :max-value 255 :value 0 :display-fn (lambda (v) (format nil "R: ~a" v)))) - (button (make-instance 'button :value "FooBar!" :parent cont-2 :on-select (lambda (g pos) (message 'foo) t))) - (button (make-instance 'button :value "List" :parent window-2 :on-select (lambda (g pos) (message 'foo) t))) - (list (make-instance 'list-box :parent window-2 :items (loop for i from 0 to 100 collect (format nil "FooBar ~a" i))))) + + (box (make-instance 'h-box :parent window)) + (right-box (make-instance 'v-box :parent box)) + (left-box (make-instance 'v-box :parent box)) + (bottom-box (make-instance 'v-box :parent window)) + + (meter (make-instance 'h-meter :parent right-box :max-value 80 :display-fn (lambda (v) (format nil "FPS: ~a" v)))) + (rg (make-instance 'h-gauge :parent left-box + :min-value 0 :max-value 255 :value 0 :display-fn (lambda (v) (format nil "R: ~a" v)))) + (gg (make-instance 'h-gauge :parent left-box + :min-value 0 :max-value 255 :value 0 :display-fn (lambda (v) (format nil "G: ~a" v)))) + (bg (make-instance 'h-gauge :parent left-box + :min-value 0 :max-value 255 :value 0 :display-fn (lambda (v) (format nil "B: ~a" v)))) + (ag (make-instance 'h-gauge :parent left-box + :min-value 0 :max-value 255 :value 0 :display-fn (lambda (v) (format nil "A: ~a" v)))) + (list (make-instance 'list-box :parent window-2 :items (loop for i from 0 to 100 collect (format nil "FooBar ~a" i)))) + (button (make-instance 'button :value "FooBar!" :parent window-2 :on-select (lambda (g pos) (message 'foo) t))) + ) + + (make-instance 'button :value "Button" :parent bottom-box) (gui-loop () (setf (value-of meter) (get-fps)) (draw-image* (tag 'tile) (v 0 0) (v 0 0) 800 600) - (with-blend (:color (list (value-of gauge) 0 0 64)) + (with-blend (:color '(0 0 0 64)) (draw-image (tag 'plane) (v 320 220))) - (draw-image (tag 'plane) (v 300 200)))))) + (with-blend (:color (list (value-of rg) (value-of gg) (value-of bg) (value-of ag))) + (draw-image (tag 'plane) (v 300 200))))))) ;; (test) \ No newline at end of file

1 0

[pal-cvs] CVS pal-gui/examples
by tneste 16 Oct '07

16 Oct '07

Update of /project/pal/cvsroot/pal-gui/examples In directory clnet:/tmp/cvs-serv12729/examples Modified Files: test.lisp Log Message: Improved packing. --- /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/15 22:53:15 1.3 +++ /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/16 00:16:41 1.4 @@ -7,12 +7,14 @@ (with-gui (:paths (merge-pathnames "examples/" pal::*pal-directory*)) (let* ((window (make-instance 'window :pos (v 200 200) :width 300 :height 200)) (window-2 (make-instance 'window :width 200 :height 300)) - (meter (make-instance 'h-meter :width 150 :parent window-2 :max-value 80 :display-fn (lambda (v) (format nil "FPS: ~a" v)))) - (gauge (make-instance 'h-gauge :width 150 - :parent window + (cont (make-instance 'h-container :parent window)) + (cont-2 (make-instance 'v-container :parent cont)) + (meter (make-instance 'h-meter :parent cont :max-value 80 :display-fn (lambda (v) (format nil "FPS: ~a" v)))) + (gauge (make-instance 'h-gauge :parent cont-2 :min-value 0 :max-value 255 :value 0 :display-fn (lambda (v) (format nil "R: ~a" v)))) - (button (make-instance 'button :value "FooBar!" :parent window :width 100 :on-select (lambda (g pos) (message 'foo) t))) - (list (make-instance 'list-box :parent window-2 :items (loop for i from 0 to 10 collect (format nil "FooBar ~a" i))))) + (button (make-instance 'button :value "FooBar!" :parent cont-2 :on-select (lambda (g pos) (message 'foo) t))) + (button (make-instance 'button :value "List" :parent window-2 :on-select (lambda (g pos) (message 'foo) t))) + (list (make-instance 'list-box :parent window-2 :items (loop for i from 0 to 100 collect (format nil "FooBar ~a" i))))) (gui-loop () (setf (value-of meter) (get-fps))

1 0

[pal-cvs] CVS pal-gui
by tneste 16 Oct '07

16 Oct '07

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))

1 0

[pal-cvs] CVS pal-gui
by tneste 15 Oct '07

15 Oct '07

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)

1 0

[pal-cvs] CVS pal-gui/examples
by tneste 15 Oct '07

15 Oct '07

Update of /project/pal/cvsroot/pal-gui/examples In directory clnet:/tmp/cvs-serv30295/examples Modified Files: test.lisp Log Message: Primitive widget packing. --- /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/15 21:55:54 1.2 +++ /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/15 22:53:15 1.3 @@ -6,15 +6,13 @@ (defun test () (with-gui (:paths (merge-pathnames "examples/" pal::*pal-directory*)) (let* ((window (make-instance 'window :pos (v 200 200) :width 300 :height 200)) - (meter (make-instance 'h-meter :pos (v 30 50) :width 150 :parent window :max-value 80 :display-fn (lambda (v) (format nil "FPS: ~a" v)))) - (gauge (make-instance 'h-gauge :pos (v 30 20) - :width 150 + (window-2 (make-instance 'window :width 200 :height 300)) + (meter (make-instance 'h-meter :width 150 :parent window-2 :max-value 80 :display-fn (lambda (v) (format nil "FPS: ~a" v)))) + (gauge (make-instance 'h-gauge :width 150 :parent window :min-value 0 :max-value 255 :value 0 :display-fn (lambda (v) (format nil "R: ~a" v)))) - (button (make-instance 'button :pos (v 100 100) :value "FooBar!" :parent window :width 100 :on-select (lambda (g pos) (message 'foo) t))) - - (window-2 (make-instance 'window :pos (v 20 20) :width 200 :height 300)) - (list (make-instance 'list-box :pos (v 10 10) :parent window-2 :items (loop for i from 0 to 10 collect (format nil "FooBar ~a" i))))) + (button (make-instance 'button :value "FooBar!" :parent window :width 100 :on-select (lambda (g pos) (message 'foo) t))) + (list (make-instance 'list-box :parent window-2 :items (loop for i from 0 to 10 collect (format nil "FooBar ~a" i))))) (gui-loop () (setf (value-of meter) (get-fps))

1 0

[pal-cvs] CVS pal-gui
by tneste 15 Oct '07

15 Oct '07

Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv18131 Modified Files: gob.lisp gui.lisp widgets.lisp Log Message: Getting off the ground. --- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/15 19:14:36 1.1 +++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/15 21:55:55 1.2 @@ -21,24 +21,28 @@ (setf (parent-of g) parent) (push g *gobs*)) -(defmethod draw ((g gob)) - (declare (ignore g)) - nil) +(defgeneric repaint (gob)) +(defgeneric absolute-pos-of (gob)) (defmethod absolute-pos-of ((g gob)) (if (parent-of g) (v+ (pos-of g) (absolute-pos-of (parent-of g))) (pos-of g))) +(defgeneric (setf absolute-pos-of) (pos gob)) (defmethod (setf absolute-pos-of) (pos (g gob)) (setf (pos-of g) (v+ (v- pos (absolute-pos-of g)) (pos-of g)))) +(defgeneric point-inside-p (gob point)) (defmethod point-inside-p ((g gob) point) (point-inside-rectangle-p (absolute-pos-of g) (width-of g) (height-of g) point)) + +(defgeneric on-enter (gob)) (defmethod on-enter ((gob gob)) nil) +(defgeneric on-leave (gob)) (defmethod on-leave ((gob gob)) nil) @@ -76,14 +80,15 @@ (:default-initargs :activep nil)) -(defmethod draw :around ((g containing)) +(defmethod repaint :around ((g containing)) (call-next-method) - (draw-childs g)) + (repaint-childs g)) -(defmethod draw-childs ((g containing)) +(defgeneric repaint-childs (container)) +(defmethod repaint-childs ((g containing)) (with-transformation (:pos (pos-of g)) (dolist (c (childs-of g)) - (draw c)))) + (repaint c)))) (defgeneric adopt (parent child)) (defmethod adopt ((parent containing) (child gob)) @@ -96,11 +101,19 @@ (setf (slot-value (parent-of child) 'childs) (remove child (slot-value (parent-of child) 'childs)) (parent-of child) nil))) +(defgeneric (setf parent-of) (parent child)) (defmethod (setf parent-of) ((parent containing) (child gob)) (abandon child) (adopt parent child)) +(defclass v-packing (containing) + ()) + + + + + @@ -128,6 +141,9 @@ () (:default-initargs :width (get-screen-width) :height (get-screen-height) :pos (v 0 0) :parent nil)) +(defmethod repaint ((g root)) + (declare (ignore g)) + nil) (defmethod (setf parent-of) (parent (root root)) (declare (ignore parent)) --- /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/15 19:14:36 1.1 +++ /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/15 21:55:55 1.2 @@ -8,13 +8,13 @@ (let ((key-up (lambda (key) (case key - (:key-mouse-1 (setf *armed-gob* nil) - (cond + (:key-mouse-1 (cond (*pointed-gob* (when (eq *armed-gob* *pointed-gob*) (on-select *armed-gob* (v- (get-mouse-pos) (absolute-pos-of *armed-gob*)))) (on-button-up *pointed-gob* (v- (get-mouse-pos) (absolute-pos-of *pointed-gob*)))) - (t (pal::funcall? ,key-up-fn key)))) + (t (pal::funcall? ,key-up-fn key))) + (setf *armed-gob* nil)) (otherwise (pal::funcall? ,key-up-fn key))))) (key-down (lambda (key) (case key @@ -60,7 +60,7 @@ *root* (make-instance 'root))) (defun update-gui () - (draw *root*)) + (repaint *root*)) (defun gob-at-point (point) (find-if (lambda (g) (and (activep g) (point-inside-p g point))) *gobs*)) --- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/15 19:14:36 1.1 +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/15 21:55:55 1.2 @@ -4,6 +4,7 @@ (defparameter *window-color* '(160 160 160 160)) (defparameter *widget-color* '(180 180 180 255)) (defparameter *text-color* '(0 0 0 255)) +(defparameter *paper-color* '(255 255 200 255)) (defun get-text-bounds (string &optional font) @@ -19,7 +20,10 @@ (truncate (* (get-font-height font) 1.5))) (defun draw-frame (pos width height color &key style (border 1)) - (let ((r (first color)) + (let ((pos (v-floor pos)) + (width (truncate width)) + (height (truncate height)) + (r (first color)) (g (second color)) (b (third color)) (a (fourth color))) @@ -37,16 +41,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)))) +(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))) + (:default-initargs :width (get-m) :height (get-m))) +(defmethod on-drag :around ((g widget) pos d) + (unless (funcall (on-drag-of g) g pos d) + (call-next-method))) -(defclass window (gob containing sliding) +(defmethod on-select :around ((g widget) pos) + (unless (funcall (on-select-of g) g pos) + (call-next-method))) + + + + + +(defclass window (widget containing sliding) ((color :accessor color-of :initform *window-color* :initarg :color)) (:default-initargs :activep t)) -(defmethod draw ((g window)) +(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)) @@ -58,9 +79,9 @@ -(defclass button (gob) +(defclass button (widget) ((color :accessor color-of :initform *widget-color* :initarg :color) - (display-fn :accessor display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v))) + (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v))) (value :accessor value-of :initform "" :initarg :value))) (defmethod initialize-instance :after ((g button) &key width &allow-other-keys) @@ -69,7 +90,7 @@ (setf (width-of g) w)) (setf (height-of g) h))) -(defmethod draw ((g button)) +(defmethod repaint ((g button)) (let ((color (color-of g)) (value (funcall (display-fn-of g) (value-of g))) (fpos (v+ (pos-of g) (get-text-offset)))) @@ -93,11 +114,11 @@ -(defclass h-gauge (gob) +(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 :accessor display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) + (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) (:default-initargs :height (get-m))) (defmethod (setf value-of) (value (g h-gauge)) @@ -108,7 +129,7 @@ (let ((x (vx (v- start-pos delta)))) (setf (value-of g) (+ (truncate x (/ (width-of g) (abs (- (min-value-of g) (max-value-of g))))) (min-value-of g))))) -(defmethod draw ((g h-gauge)) +(defmethod repaint ((g h-gauge)) (let* ((vt (funcall (display-fn-of g) (value-of g))) (sw (get-text-bounds vt)) (m (get-m)) @@ -131,7 +152,7 @@ -(defclass v-slider (gob) +(defclass v-slider (widget) ((value :reader value-of :initarg :value :initform 0) (page-size :accessor page-size-of :initarg :page-size :initform 1) (min-value :accessor min-value-of :initarg :min-value :initform 0) @@ -146,13 +167,16 @@ (let ((y (vy (v- start-pos delta)))) (setf (value-of g) (+ (truncate y (/ (height-of g) (abs (- (min-value-of g) (max-value-of g))))) (min-value-of g))))) -(defmethod draw ((g v-slider)) +(defmethod repaint ((g v-slider)) (let* ((units (abs (- (min-value-of g) (max-value-of g)))) (usize (/ (height-of g) units)) (k (truncate (* usize (- (value-of g) (min-value-of g))))) (kpos (v+ (pos-of g) (v 0 k)))) (draw-frame (pos-of g) (width-of g) (height-of g) *window-color* :style :sunken) - (draw-frame kpos (width-of g) (* (- units (page-size-of g)) usize) *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1)))) + (draw-frame kpos + (width-of g) + (min (height-of g) (- (height-of g) (* (- units (page-size-of g)) usize))) + *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1)))) @@ -161,17 +185,17 @@ -(defclass h-meter (gob) +(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 :accessor display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) + (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) (:default-initargs :activep nil :height (get-m))) (defmethod (setf value-of) (value (g h-meter)) (setf (slot-value g 'value) (clamp (min-value-of g) value (max-value-of g)))) -(defmethod draw ((g h-meter)) +(defmethod repaint ((g h-meter)) (let* ((m (get-m)) (k (truncate (* (/ (width-of g) (abs (- (min-value-of g) (max-value-of g)))) (- (value-of g) (min-value-of g))))) ) (draw-frame (pos-of g) (width-of g) (height-of g) *window-color* :style :sunken) @@ -183,12 +207,45 @@ -(defclass v-list (gob) +(defclass list-view (widget) ((items :accessor items-of :initarg :items :initform '()) (scroll :accessor scroll-of :initform 0) - (display-fn :accessor display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) - (:default-initargs :width (* 10 (get-m)) :height (* 5 (get-m)))) + (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)))) + + +(defmethod repaint ((g list-view)) + (with-accessors ((width width-of) (height height-of) (pos pos-of) (ap absolute-pos-of)) g + (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)) + (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))))) + (incf y))))))) + + -(defmethod draw ((g v-list)) - ()) \ No newline at end of file +(defclass list-box (widget containing) + () + (:default-initargs :height (* 6 (get-m)) :width (* 5 (get-m)))) + +(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 + :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)) + nil) \ No newline at end of file

1 0

[pal-cvs] CVS pal-gui/examples
by tneste 15 Oct '07

15 Oct '07

Update of /project/pal/cvsroot/pal-gui/examples In directory clnet:/tmp/cvs-serv18131/examples Modified Files: test.lisp Log Message: Getting off the ground. --- /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/15 19:14:35 1.1 +++ /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/15 21:55:54 1.2 @@ -6,16 +6,17 @@ (defun test () (with-gui (:paths (merge-pathnames "examples/" pal::*pal-directory*)) (let* ((window (make-instance 'window :pos (v 200 200) :width 300 :height 200)) - (slider (make-instance 'v-slider :pos (v 250 20) :height 150 :parent window :max-value 200 :page-size 100)) (meter (make-instance 'h-meter :pos (v 30 50) :width 150 :parent window :max-value 80 :display-fn (lambda (v) (format nil "FPS: ~a" v)))) (gauge (make-instance 'h-gauge :pos (v 30 20) :width 150 :parent window :min-value 0 :max-value 255 :value 0 :display-fn (lambda (v) (format nil "R: ~a" v)))) - (button (make-instance 'button :pos (v 100 100) :value "FooBar!" :parent window))) + (button (make-instance 'button :pos (v 100 100) :value "FooBar!" :parent window :width 100 :on-select (lambda (g pos) (message 'foo) t))) + + (window-2 (make-instance 'window :pos (v 20 20) :width 200 :height 300)) + (list (make-instance 'list-box :pos (v 10 10) :parent window-2 :items (loop for i from 0 to 10 collect (format nil "FooBar ~a" i))))) (gui-loop () - (setf (value-of button) (value-of slider)) (setf (value-of meter) (get-fps)) (draw-image* (tag 'tile) (v 0 0) (v 0 0) 800 600) (with-blend (:color (list (value-of gauge) 0 0 64))

1 0

[pal-cvs] CVS pal
by tneste 15 Oct '07

15 Oct '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv17532 Modified Files: pal.lisp Log Message: Fixed handling of coordinates in with-clipping. --- /project/pal/cvsroot/pal/pal.lisp 2007/10/15 19:04:55 1.32 +++ /project/pal/cvsroot/pal/pal.lisp 2007/10/15 21:48:00 1.33 @@ -297,9 +297,10 @@ (defunct push-clip (x y width height) (u16 x u16 y u16 width u16 height) (close-quads) - (pal-ffi:gl-scissor x y width height) - (pal-ffi:gl-enable pal-ffi:+gl-scissor-test+) - (push (vector x y width height) *clip-stack*)) + (let ((y (- (get-screen-height) y height))) + (pal-ffi:gl-scissor x y width height) + (pal-ffi:gl-enable pal-ffi:+gl-scissor-test+) + (push (vector x y width height) *clip-stack*))) (defun pop-clip () (close-quads)

1 0

[pal-cvs] CVS pal-gui
by tneste 15 Oct '07

15 Oct '07

Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv26366 Added Files: gob.lisp gui.lisp package.lisp pal-gui.asd widgets.lisp Log Message: Project created. --- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/15 19:14:36 NONE +++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/15 19:14:36 1.1 (in-package :pal-gui) (defvar *root* nil) (defvar *gobs* nil) (defvar *drag-start-pos* nil) (defvar *relative-drag-start-pos* nil) (defvar *focused-gob* nil) (defvar *pointed-gob* nil) (defvar *armed-gob* nil) (defclass gob () ((pos :accessor pos-of :initarg :pos :initform (v 0 0)) (parent :reader parent-of :initform nil) (activep :accessor activep :initform t :initarg :activep) (width :accessor width-of :initarg :width :initform 0) (height :accessor height-of :initarg :height :initform 0))) (defmethod initialize-instance :after ((g gob) &key (parent *root*) &allow-other-keys) (setf (parent-of g) parent) (push g *gobs*)) (defmethod draw ((g gob)) (declare (ignore g)) nil) (defmethod absolute-pos-of ((g gob)) (if (parent-of g) (v+ (pos-of g) (absolute-pos-of (parent-of g))) (pos-of g))) (defmethod (setf absolute-pos-of) (pos (g gob)) (setf (pos-of g) (v+ (v- pos (absolute-pos-of g)) (pos-of g)))) (defmethod point-inside-p ((g gob) point) (point-inside-rectangle-p (absolute-pos-of g) (width-of g) (height-of g) point)) (defmethod on-enter ((gob gob)) nil) (defmethod on-leave ((gob gob)) nil) (defgeneric on-button-down (gob pos)) (defmethod on-button-down ((gob gob) pos) nil) (defgeneric on-button-up (gob pos)) (defmethod on-button-up ((gob gob) pos) nil) (defgeneric on-select (gob pos)) (defmethod on-select ((gob gob) pos) nil) (defgeneric on-drag (gob start-pos delta-pos)) (defmethod on-drag ((gob gob) start-pos delta) (declare (ignore start-pos delta)) nil) (defgeneric pointedp (gob)) (defmethod pointedp ((gob gob)) (eq *pointed-gob* gob)) (defgeneric armedp (gob)) (defmethod armedp ((gob gob)) (eq *armed-gob* gob)) (defclass containing () ((childs :reader childs-of :initform nil)) (:default-initargs :activep nil)) (defmethod draw :around ((g containing)) (call-next-method) (draw-childs g)) (defmethod draw-childs ((g containing)) (with-transformation (:pos (pos-of g)) (dolist (c (childs-of g)) (draw c)))) (defgeneric adopt (parent child)) (defmethod adopt ((parent containing) (child gob)) (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))) (defmethod (setf parent-of) ((parent containing) (child gob)) (abandon child) (adopt parent child)) (defclass sliding () ((start-pos :accessor start-pos-of))) (defmethod on-button-down :around ((g sliding) pos) (declare (ignore pos)) (setf (start-pos-of g) (pos-of g)) (call-next-method)) (defmethod on-drag :around ((g sliding) start-pos delta) (declare (ignore start-pos)) (setf (pos-of g) (v- (start-pos-of g) delta)) (call-next-method)) (defclass root (gob containing) () (:default-initargs :width (get-screen-width) :height (get-screen-height) :pos (v 0 0) :parent nil)) (defmethod (setf parent-of) (parent (root root)) (declare (ignore parent)) nil)--- /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/15 19:14:36 NONE +++ /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/15 19:14:36 1.1 (in-package :pal-gui) (defmacro gui-loop ((&key key-up-fn key-down-fn mouse-motion-fn quit-fn) &body redraw) (let ((event (gensym))) `(block event-loop (cffi:with-foreign-object (,event :char 500) (let ((key-up (lambda (key) (case key (:key-mouse-1 (setf *armed-gob* nil) (cond (*pointed-gob* (when (eq *armed-gob* *pointed-gob*) (on-select *armed-gob* (v- (get-mouse-pos) (absolute-pos-of *armed-gob*)))) (on-button-up *pointed-gob* (v- (get-mouse-pos) (absolute-pos-of *pointed-gob*)))) (t (pal::funcall? ,key-up-fn key)))) (otherwise (pal::funcall? ,key-up-fn key))))) (key-down (lambda (key) (case key (:key-escape (unless ,key-down-fn (return-from event-loop))) (:key-mouse-1 (cond (*pointed-gob* (setf *drag-start-pos* (get-mouse-pos)) (setf *relative-drag-start-pos* (v- *drag-start-pos* (absolute-pos-of *pointed-gob*))) (setf *armed-gob* *pointed-gob*) (on-button-down *pointed-gob* (v- (get-mouse-pos) (absolute-pos-of *pointed-gob*)))) (t (pal::funcall? ,key-down-fn key)))) (otherwise (pal::funcall? ,key-down-fn key)))))) (loop (pal::do-event ,event key-up key-down ,mouse-motion-fn ,quit-fn) ,@redraw (let ((g (gob-at-point (get-mouse-pos)))) (setf *pointed-gob* g) (cond (*armed-gob* (on-drag *armed-gob* *relative-drag-start-pos* (v- *drag-start-pos* (get-mouse-pos)))) (t (when (and g (not (activep g))) (when *pointed-gob* (on-leave *pointed-gob*)) (on-enter g))))) (update-gui) (update-screen))))))) (defmacro with-gui (args &body body) "Open PAL and initialise GUI then evaluate BODY. After BODY returns call CLOSE-PAL." `(progn (apply 'open-pal (list ,@args)) (init-gui) (unwind-protect (progn ,@body) (close-pal)))) (defun init-gui () (setf *gobs* nil *root* (make-instance 'root))) (defun update-gui () (draw *root*)) (defun gob-at-point (point) (find-if (lambda (g) (and (activep g) (point-inside-p g point))) *gobs*)) --- /project/pal/cvsroot/pal-gui/package.lisp 2007/10/15 19:14:36 NONE +++ /project/pal/cvsroot/pal-gui/package.lisp 2007/10/15 19:14:36 1.1 (defpackage #:pal-gui (:use :common-lisp :pal)) --- /project/pal/cvsroot/pal-gui/pal-gui.asd 2007/10/15 19:14:36 NONE +++ /project/pal/cvsroot/pal-gui/pal-gui.asd 2007/10/15 19:14:36 1.1 (in-package #:asdf) (defsystem pal-gui :description "Pixel Art Library GUI" :author "Tomi Neste" :license "MIT" :components ((:file "gob" :depends-on ("package")) (:file "widgets" :depends-on ("gob")) (:file "gui" :depends-on ("gob" "widgets")) (:file "package")) :depends-on ("pal")) --- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/15 19:14:36 NONE +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/15 19:14:36 1.1 (in-package :pal-gui) (defparameter *window-color* '(160 160 160 160)) (defparameter *widget-color* '(180 180 180 255)) (defparameter *text-color* '(0 0 0 255)) (defun get-text-bounds (string &optional font) (let ((fh (get-font-height font))) (values (max (truncate (* 1.5 fh)) (+ (get-text-size string) fh)) (truncate (* fh 1.5))))) (defun get-text-offset (&optional font) (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 ((r (first color)) (g (second color)) (b (third color)) (a (fourth color))) (draw-rectangle (v- pos (v border border)) (+ width (* 2 border) ) (+ height (* 2 border)) 0 0 0 a) (draw-rectangle pos width height r g b a) (case style (:raised (draw-line (v+ pos (v 1 1)) (v+ pos (v width 0)) 255 255 255 128) (draw-line (v+ pos (v 1 1)) (v+ pos (v 0 height)) 255 255 255 128) (draw-line (v+ pos (v (- width 1) (- height 1))) (v+ pos (v width 0)) 0 0 0 128) (draw-line (v+ pos (v width (- height 1))) (v+ pos (v 0 height)) 0 0 0 128)) (:sunken (draw-line (v+ pos (v 0 1)) (v+ pos (v width 0)) 0 0 0 128) (draw-line (v+ pos (v 1 0)) (v+ pos (v 0 height)) 0 0 0 128) (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))))) (defclass window (gob containing sliding) ((color :accessor color-of :initform *window-color* :initarg :color)) (:default-initargs :activep t)) (defmethod draw ((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)) (defclass button (gob) ((color :accessor color-of :initform *widget-color* :initarg :color) (display-fn :accessor display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v))) (value :accessor value-of :initform "" :initarg :value))) (defmethod initialize-instance :after ((g button) &key width &allow-other-keys) (multiple-value-bind (w h) (get-text-bounds (value-of g)) (unless width (setf (width-of g) w)) (setf (height-of g) h))) (defmethod draw ((g button)) (let ((color (color-of g)) (value (funcall (display-fn-of g) (value-of g))) (fpos (v+ (pos-of g) (get-text-offset)))) (cond ((armedp g) (draw-frame (pos-of g) (width-of g) (height-of g) color :style :sunken :border 2) (with-blend (:color *text-color*) (draw-text value (v+ fpos (v 1 1))) )) ((pointedp g) (draw-frame (pos-of g) (width-of g) (height-of g) color :border 2 :style :raised) (with-blend (:color *text-color*) (draw-text value fpos) )) (t (draw-frame (pos-of g) (width-of g) (height-of g) color :style :raised) (with-blend (:color *text-color*) (draw-text value fpos)))))) (defclass h-gauge (gob) ((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 :accessor display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) (:default-initargs :height (get-m))) (defmethod (setf value-of) (value (g h-gauge)) (setf (slot-value g 'value) (clamp (min-value-of g) value (max-value-of g)))) (defmethod on-drag ((g h-gauge) start-pos delta) (let ((x (vx (v- start-pos delta)))) (setf (value-of g) (+ (truncate x (/ (width-of g) (abs (- (min-value-of g) (max-value-of g))))) (min-value-of g))))) (defmethod draw ((g h-gauge)) (let* ((vt (funcall (display-fn-of g) (value-of 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+ (pos-of g) (v (- k (truncate sw 2)) 0)))) (draw-frame (v+ (pos-of g) (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-line (v+ kpos (v (truncate sw 2) 0)) (v+ kpos (v (truncate sw 2) (/ m 8))) 255 255 255 128) (draw-line (v+ kpos (v (truncate sw 2) (- m (/ m 8)))) (v+ kpos (v (truncate sw 2) m)) 0 0 0 128 :size 2) (with-blend (:color *text-color*) (draw-text vt (v+ kpos (get-text-offset)))))) (defclass v-slider (gob) ((value :reader value-of :initarg :value :initform 0) (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))) (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))))) (defmethod on-drag ((g v-slider) start-pos delta) (let ((y (vy (v- start-pos delta)))) (setf (value-of g) (+ (truncate y (/ (height-of g) (abs (- (min-value-of g) (max-value-of g))))) (min-value-of g))))) (defmethod draw ((g v-slider)) (let* ((units (abs (- (min-value-of g) (max-value-of g)))) (usize (/ (height-of g) units)) (k (truncate (* usize (- (value-of g) (min-value-of g))))) (kpos (v+ (pos-of g) (v 0 k)))) (draw-frame (pos-of g) (width-of g) (height-of g) *window-color* :style :sunken) (draw-frame kpos (width-of g) (* (- units (page-size-of g)) usize) *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1)))) (defclass h-meter (gob) ((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 :accessor display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) (:default-initargs :activep nil :height (get-m))) (defmethod (setf value-of) (value (g h-meter)) (setf (slot-value g 'value) (clamp (min-value-of g) value (max-value-of g)))) (defmethod draw ((g h-meter)) (let* ((m (get-m)) (k (truncate (* (/ (width-of g) (abs (- (min-value-of g) (max-value-of g)))) (- (value-of g) (min-value-of g))))) ) (draw-frame (pos-of g) (width-of g) (height-of g) *window-color* :style :sunken) (loop for x from 0 to k by 2 do (draw-line (v+ (pos-of g) (v x 1)) (v+ (pos-of g) (v x (1- m))) 148 148 148 255)) (with-blend (:color *text-color*) [14 lines skipped]

1 0

← Newer
1
2
3
4
5
6
7
8
9
...
13
Older →

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

pal-cvs