Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv7580
Modified Files: gob.lisp gui.lisp package.lisp present.lisp widgets.lisp Log Message: Fixed some widget rendering problems. Updated the examples.
--- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/30 20:44:46 1.14 +++ /project/pal/cvsroot/pal-gui/gob.lisp 2008/01/03 21:42:48 1.15 @@ -24,13 +24,12 @@ (min-height :reader min-height-of :initarg :min-height) (childs :reader childs-of :initform nil)))
-(defmethod initialize-instance :after ((g gob) &key (min-height) (min-width) (parent *root*) (childs nil) &allow-other-keys) +(defmethod initialize-instance :after ((g gob) &key (min-height) (min-width) (parent *root*) &allow-other-keys) (unless min-width (setf (slot-value g 'min-width) (width-of g))) (unless min-height (setf (slot-value g 'min-height) (height-of g))) - (setf (parent-of g) parent) - (setf (childs-of g) childs)) + (setf (parent-of g) parent))
(defgeneric repaint (gob)) (defmethod repaint :around ((g gob)) @@ -127,6 +126,8 @@
(defgeneric adopt (parent child)) (defmethod adopt ((parent gob) (child gob)) + (when (parent-of child) + (abandon (parent-of child) child)) (setf (slot-value child 'parent) parent) (push child (slot-value parent 'childs)))
--- /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/30 20:44:46 1.10 +++ /project/pal/cvsroot/pal-gui/gui.lisp 2008/01/03 21:42:48 1.11 @@ -2,6 +2,9 @@
(declaim (optimize (speed 3)))
+(defvar *update-screen-fn* (symbol-function 'pal:update-screen)) +(defvar *open-pal-fn* (symbol-function 'pal:open-pal)) +
(defun config-gui (&key (font *gui-font*) (window-color *window-color*) (widget-color *widget-color*) @@ -16,13 +19,13 @@ *text-offset* (let ((fh (get-font-height *gui-font*))) (v (truncate fh 2) (truncate fh 4)))))
-(defun update-gui () +(defun pal:update-screen () "Like PAL:UPDATE but also updates the GUI" (pal::close-quads) (reset-blend) (pal-ffi:gl-load-identity) (repaint *root*) - (update-screen)) + (funcall *update-screen-fn*))
(defun active-gobs-at-point (point parent) @@ -44,15 +47,15 @@ *pointed-gob* nil *armed-gob* nil) (config-gui :font (tag 'pal::default-font) - :window-color (color 140 140 140 160) - :widget-color (color 180 180 180 128) + :window-color (color 128 128 128 220) + :widget-color (color 160 160 160 220) :text-color (color 0 0 0 255) :paper-color (color 255 255 200 255) :tooltip-delay 1))
-(defmacro gui-loop ((&key key-up-fn key-down-fn mouse-motion-fn quit-fn) &body redraw) +(defmacro pal:event-loop ((&key key-up-fn key-down-fn mouse-motion-fn quit-fn) &body redraw) "Same as PAL:EVENT-LOOP but with added GUI event handling" (let ((event (gensym))) `(block event-loop @@ -99,14 +102,8 @@ (when (and *pointed-gob* (not (eq *pointed-gob* g))) (on-leave *pointed-gob*)) (setf *pointed-gob* 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)))) \ No newline at end of file +(defun pal:open-pal (&rest args) + (apply *open-pal-fn* args) + (init-gui)) --- /project/pal/cvsroot/pal-gui/package.lisp 2007/10/30 20:44:46 1.5 +++ /project/pal/cvsroot/pal-gui/package.lisp 2008/01/03 21:42:48 1.6 @@ -1,6 +1,6 @@ (defpackage #:pal-gui (:use :common-lisp :pal) - (:export #:with-gui #:init-gui #:update-gui #:gui-loop #:config-gui + (:export #:config-gui
#:present
--- /project/pal/cvsroot/pal-gui/present.lisp 2007/10/30 20:44:46 1.3 +++ /project/pal/cvsroot/pal-gui/present.lisp 2008/01/03 21:42:48 1.4 @@ -4,7 +4,8 @@ (defmethod present (object (g widget) width height) (with-blend (:color *text-color*) (draw-text (format nil "~a" object) (v (vx *text-offset*) - (- (truncate height 2) (truncate (get-font-height *gui-font*) 2) 1))))) + (- (truncate height 2) (truncate (get-font-height *gui-font*) 2) 1)) + *gui-font*)))
--- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/30 20:44:46 1.14 +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2008/01/03 21:42:48 1.15 @@ -3,14 +3,14 @@ ;; (declaim (optimize (speed 3)))
-(defparameter *window-color* nil) -(defparameter *widget-color* nil) -(defparameter *text-color* nil) -(defparameter *paper-color* nil) -(defparameter *tooltip-delay* nil) -(defparameter *widget-enter-time* nil) -(defparameter *m* nil) -(defparameter *text-offset* nil) +(defvar *window-color* nil) +(defvar *widget-color* nil) +(defvar *text-color* nil) +(defvar *paper-color* nil) +(defvar *tooltip-delay* nil) +(defvar *widget-enter-time* nil) +(defvar *m* nil) +(defvar *text-offset* nil) (defvar *gui-font* nil)
@@ -30,21 +30,22 @@ (g (color-g color)) (b (color-b color)) (a (color-a color))) - (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)) + (when (> border 0) + (draw-rectangle (v- pos (v border border)) (+ width (* 2 border)) (+ height (* 2 border)) 0 0 0 a :fill nil)) (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)) + (draw-line pos (v+ pos (v width 0)) 255 255 255 128) + (draw-line pos (v+ pos (v 0 height)) 255 255 255 128) + (draw-line (v+ pos (v width height)) (v+ pos (v width 0)) 0 0 0 128) + (draw-line (v+ pos (v width height)) (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))))) + (draw-line pos (v+ pos (v width 0)) 0 0 0 128) + (draw-line pos (v+ pos (v 0 height)) 0 0 0 128) + (draw-line (v+ pos (v width height)) (v+ pos (v width 0)) 255 255 255 128) + (draw-line (v+ pos (v width height)) (v+ pos (v 0 height)) 255 255 255 128))))) +
@@ -381,8 +382,10 @@ (with-accessors ((width width-of) (height height-of) (scroll scroll-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-transformation (:pos (v 0 (- (mod scroll item-height)))) - (let ((y 0)) + (with-transformation (:pos (v 1 (- (mod scroll item-height)))) + (let ((y 0) + (width (- width 1)) + (height (- height 1))) (dolist (i (items-of g)) (when (and (> (* (1+ y) item-height) scroll) (< (* y item-height) (+ scroll height))) @@ -390,7 +393,7 @@ (draw-rectangle (v 0 0) width item-height 0 0 0 32)) (present i g width item-height) (when (find y (selected-of g) :test '=) - (draw-rectangle (v 1 0) width item-height 0 0 0 128)) + (draw-rectangle (v 0 0) width item-height 0 0 0 128)) (translate (v 0 item-height))) (incf y)))))))
@@ -411,7 +414,7 @@ :parent g :on-select (lambda (g) (on-select (parent-of g))))) - (slider-box (make-instance 'v-box :parent g :gap 0 :x-expand-p nil :width w)) + (slider-box (make-instance 'v-box :parent g :gap 2 :x-expand-p nil :width w)) (slider (make-instance 'v-slider :width w :parent slider-box @@ -552,7 +555,7 @@
(defmethod repaint ((g text-widget)) (with-accessors ((width width-of) (height height-of) (text text-of) (point point-of)) g - (draw-frame (v 0 0) width height *widget-color* :fill nil :style :raised) + (draw-frame (v 0 0) width height *widget-color* :fill nil :style :sunken) (draw-rectangle (v 1 1) (1- width) (1- height) (color-r *paper-color*) (color-g *paper-color*) (color-b *paper-color*) (color-a *paper-color*)) (let ( (point-x (+ (vx *text-offset*) (get-text-size (subseq text 0 point))))) (with-blend (:color *text-color*)