From tneste at common-lisp.net Wed Jan 2 19:58:34 2008 From: tneste at common-lisp.net (tneste) Date: Wed, 2 Jan 2008 14:58:34 -0500 (EST) Subject: [pal-cvs] CVS pal Message-ID: <20080102195834.6B3B61207A@common-lisp.net> Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv29264 Modified Files: ffi.lisp Log Message: Fixed the glyph array declaration in ffi.lisp --- /project/pal/cvsroot/pal/ffi.lisp 2007/12/29 14:45:53 1.24 +++ /project/pal/cvsroot/pal/ffi.lisp 2008/01/02 19:58:34 1.25 @@ -447,7 +447,7 @@ (defstruct font (file nil) (image nil :type (or boolean image)) - (glyphs nil :type (or boolean (simple-vector 255))) + (glyphs nil :type (or boolean (simple-vector 256))) (height 0 :type u11)) (defstruct music From tneste at common-lisp.net Thu Jan 3 21:42:48 2008 From: tneste at common-lisp.net (tneste) Date: Thu, 3 Jan 2008 16:42:48 -0500 (EST) Subject: [pal-cvs] CVS pal-gui/examples Message-ID: <20080103214248.685E925113@common-lisp.net> Update of /project/pal/cvsroot/pal-gui/examples In directory clnet:/tmp/cvs-serv7580/examples Modified Files: colors.lisp files.lisp packing.lisp test.lisp Log Message: Fixed some widget rendering problems. Updated the examples. --- /project/pal/cvsroot/pal-gui/examples/colors.lisp 2007/10/30 20:44:45 1.2 +++ /project/pal/cvsroot/pal-gui/examples/colors.lisp 2008/01/03 21:42:48 1.3 @@ -1,7 +1,7 @@ (in-package :pal-gui) -(defparameter *bg* (color 0 0 0 255)) +(defparameter *bg* (color 0 0 0)) (defmethod present ((c color) w width height) (with-blend (:color c) @@ -12,7 +12,7 @@ (defun test () - (with-gui (:paths (merge-pathnames "examples/" pal::*pal-directory*)) + (with-pal (:paths (merge-pathnames "examples/" pal::*pal-directory*)) (let* ((window (make-instance 'window :pos (v 200 200) :width 200 :height 230 :label "Select color")) (button (make-instance 'button :value "" :parent window)) @@ -24,7 +24,7 @@ (setf (on-select-of button) (lambda (g) (setf *bg* (selected-of list)))) - (gui-loop () - (clear-screen (color-r *bg*) (color-g *bg*) (color-b *bg*)))))) + (event-loop () + (clear-screen *bg*))))) ;; (test) \ No newline at end of file --- /project/pal/cvsroot/pal-gui/examples/files.lisp 2007/10/31 12:50:42 1.3 +++ /project/pal/cvsroot/pal-gui/examples/files.lisp 2008/01/03 21:42:48 1.4 @@ -20,19 +20,19 @@ (defmethod update-view ((g file-widget)) (setf (items-of (list-widget-of g)) (mapcar (lambda (f) - (if (pathname-name f) - (pathname-name f) - (concatenate 'string (first (last (pathname-directory f))) "/"))) - (directory "*")))) + (if (pathname-name f) + (pathname-name f) + (concatenate 'string (first (last (pathname-directory f))) "/"))) + (directory "*")))) (defun test () - (with-gui () + (with-pal () (let* ((window (make-instance 'window :pos (v 200 200) :width 300 :height 200)) (hbox (make-instance 'file-widget :parent window :label "Choose"))) - (gui-loop () - (clear-screen 150 150 150))))) + (event-loop () + (clear-screen (color 150 150 150)))))) ;; (test) \ No newline at end of file --- /project/pal/cvsroot/pal-gui/examples/packing.lisp 2007/10/31 12:50:42 1.4 +++ /project/pal/cvsroot/pal-gui/examples/packing.lisp 2008/01/03 21:42:48 1.5 @@ -4,7 +4,7 @@ (defun test () - (with-gui () + (with-pal () (let* ((window (make-instance 'window :pos (v 200 200) :width 300 :height 240)) (hbox (make-instance 'h-box :parent window)) @@ -19,29 +19,29 @@ (e (make-instance 'button :value "Button" :parent bottom-box)) (f (make-instance 'button :value "a Button" :parent left-box))) - (gui-loop () - (clear-screen 50 50 255)))))) + (event-loop () + (clear-screen (color 50 50 255))))))) ;; (test) (defun test () - (with-gui () + (with-pal () (let* ((window (make-instance 'window :pos (v 200 200) :width 300 :height 200))) (let ((a (make-instance 'button :value "Button" :parent window :y-expand-p t)) (b (make-instance 'button :value "Button" :parent window)) (c (make-instance 'button :value "Foo" :parent window :y-expand-p t))) - (gui-loop () - (clear-screen 50 50 255)))))) + (event-loop () + (clear-screen (color 50 50 255))))))) ;; (test) (defun test () - (with-gui () + (with-pal () (let* ((window (make-instance 'window :pos (v 200 200) :width 300 :height 200))) (let* ((hbox (make-instance 'h-box :parent window)) (box (make-instance 'box :label "Box" :parent window)) @@ -54,7 +54,7 @@ (loop repeat 10 do (make-instance 'pin :value "Foo" :b 0 :pos (v (random 800) (random 600)))) - (gui-loop () - (clear-screen 50 50 255)))))) + (event-loop () + (clear-screen (color 50 50 255))))))) ;; (test) \ No newline at end of file --- /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/31 12:50:42 1.14 +++ /project/pal/cvsroot/pal-gui/examples/test.lisp 2008/01/03 21:42:48 1.15 @@ -11,7 +11,7 @@ (defun test () - (with-gui (:paths (merge-pathnames "examples/" pal::*pal-directory*)) + (with-pal (:paths (list "C:/Documents and Settings/tomppa/Omat tiedostot/" (merge-pathnames "examples/" pal::*pal-directory*))) (let* ((plane (load-image "lego-plane.png")) (tile (load-image "ground.png")) @@ -47,11 +47,11 @@ (pin (make-instance 'pin :value "Plane" :pos (v 400 300))) (text (make-instance 'text-widget :text "Text" :parent bottom-box))) - (gui-loop () - (draw-image* tile (v 0 0) (v 0 0) 800 600) - (with-blend (:color (color 0 0 0 64)) - (draw-image plane (pos-of pin))) - (with-blend (:color (color (value-of rg) (value-of gg) (value-of bg) (value-of ag))) - (draw-image plane (v- (pos-of pin) (v 10 10)))))))) + (event-loop () + (draw-image* tile (v 0 0) (v 0 0) 800 600) + (with-blend (:color (color 0 0 0 64)) + (draw-image plane (pos-of pin))) + (with-blend (:color (color (value-of rg) (value-of gg) (value-of bg) (value-of ag))) + (draw-image plane (v- (pos-of pin) (v 10 10)))))))) ;; (test) \ No newline at end of file From tneste at common-lisp.net Thu Jan 3 21:42:48 2008 From: tneste at common-lisp.net (tneste) Date: Thu, 3 Jan 2008 16:42:48 -0500 (EST) Subject: [pal-cvs] CVS pal-gui Message-ID: <20080103214248.C940B28267@common-lisp.net> 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 , at args)) - (init-gui) - (unwind-protect - (progn , at 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*)