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