[pal-cvs] CVS pal-gui
tneste
tneste at common-lisp.net
Thu Jan 3 21:42:48 UTC 2008
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*)
More information about the Pal-cvs
mailing list