- pal-cvs@common-lisp.net - mailman3.common-lisp.net

[pal-cvs] CVS pal/documentation
by tneste 31 Oct '07

31 Oct '07

Update of /project/pal/cvsroot/pal/documentation In directory clnet:/tmp/cvs-serv6234/documentation Modified Files: pal-manual.lyx pal-manual.pdf Added Files: pal-manual.tex Log Message: Some polishing. Version 1.1 --- /project/pal/cvsroot/pal/documentation/pal-manual.lyx 2007/10/18 19:29:56 1.2 +++ /project/pal/cvsroot/pal/documentation/pal-manual.lyx 2007/10/31 12:51:23 1.3 @@ -269,11 +269,11 @@ \end_layout \begin_layout Subsection -Introduction +Resources \end_layout \begin_layout Subsection -Functions +Functions and macros \end_layout \begin_layout Description @@ -447,7 +447,7 @@ \end_layout \begin_layout Subsection -Introduction +Basics \end_layout \begin_layout Standard @@ -464,7 +464,7 @@ \end_layout \begin_layout Subsection -Functions +Functions and macros \end_layout \begin_layout Description @@ -676,7 +676,7 @@ \shape italic keysym \shape default -. +, or NIL if the character is out the ASCII range 1-255. \end_layout @@ -1761,11 +1761,11 @@ \end_layout \begin_layout Subsection -SET-BLEND-MODE +SET-BLEND \end_layout \begin_layout Subsection -RESET-BLEND-MODE +RESET-BLEND \end_layout \begin_layout Subsection @@ -1971,10 +1971,6 @@ \end_layout \begin_layout Subsection -DATA-PATH -\end_layout - -\begin_layout Subsection RANDOMLY \end_layout @@ -1990,9 +1986,5 @@ DO-N \end_layout -\begin_layout Subsection -CURRY -\end_layout - \end_body \end_document Binary files /project/pal/cvsroot/pal/documentation/pal-manual.pdf 2007/10/18 19:29:56 1.1 and /project/pal/cvsroot/pal/documentation/pal-manual.pdf 2007/10/31 12:51:23 1.2 differ --- /project/pal/cvsroot/pal/documentation/pal-manual.tex 2007/10/31 12:51:23 NONE +++ /project/pal/cvsroot/pal/documentation/pal-manual.tex 2007/10/31 12:51:23 1.1 %% LyX 1.4.4 created this file. For more info, see http://www.lyx.org/. %% Do not edit unless you really know what you are doing. \documentclass[english]{article} \usepackage[T1]{fontenc} \usepackage[latin1]{inputenc} \makeatletter \usepackage{babel} \makeatother \begin{document} \title{Pixel Art Library} \author{Tomi Neste tneste(a)common-lisp.net} \maketitle \newpage{} \begin{quote} Pixel Art Library is published under the MIT license Copyright (c) 2006 Tomi Neste Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the \char`\"{}Software\char`\"{}), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED \char`\"{}AS IS\char`\"{}, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. \end{quote} \newpage{} \tableofcontents{} \newpage{} \section{Introduction and installation} \subsection{What is Pixel Art Library} PAL is a Common Lisp library for developing applications with fast 2d graphics and sound. Internally it uses SDL for sound, event handling and window initialisation and OpenGL for fast hardware accelerated graphics but its API has little to do with the aforementioned libraries. PAL's design goals are ease of use, portability and reliability. It tries to provide all the \emph{common} functionality that is needed when creating 2d games and similar applications. As such it neither provides higher level specialised facilities like sprites or collision detection, or lower level OpenGL specific functionality. If the user is familiar with Common Lisp and OpenGL this kind of functionality should be easy to implement on top of PAL. \subsection{Requirements} \begin{itemize} \item Pixel Art Library requires the SDL, SDL\_image and SDL\_mixer libraries. For Windows users it's easiest to use the ones included in the PAL releases, Linux users should be able to easily install these through their distros package management. \emph{Note: These come with their own license.} \item Like most modern CL libraries PAL uses ASDF to handle compilation and loading. If you are using SBCL this is included with the default installation and can be loaded with (REQUIRE :ASDF), with other systems you may need to download it separately. \item For interfacing with the foreign libraries PAL uses the excellent CFFI library. It's available from http://common-lisp.net/project/cffi \item For creating the bitmap fonts that PAL uses you need the font creator that is included in Haaf's Game Engine. This will be fixed in the future releases. \item To get anywhere near reasonable performance you need a graphics card and driver that is capable of hardware accelerated OpenGL graphics. \end{itemize} \subsection{Installation} After installing CFFI (and possibly ASDF) and downloading and unpacking PAL you should \begin{itemize} \item Under Windows copy the .dlls to somewhere where they can be found, for example in your Lisp implementations home folder. \item Under Linux, check that the SDL, SDL\_mixer and SDL\_image packages are installed. \item Copy the PAL folder to where you usually keep your ASDF systems. If you are unsure you can check and modify this through ASDF:{*}CENTRAL-REGISTRY{*} variable \item In your Lisp prompt do (ASDF:OOS 'ASDF:LOAD-OP :PAL) and after awhile everything should be compiled and loaded in your Lisp session. In case of errors first check that everything, including the foreign libraries can be found by the system. If nothing works feel free to bug the Pal-dev mailing list. \item If everything went fine you can now try your first PAL program, enter in the following: \end{itemize} \begin{quotation} \texttt{(with-pal (:title {}``PAL test'')} \texttt{~~(clear-screen 255 255 0)} \texttt{~~(with-transformation (:pos (v 400 300) :angle 45f0 :scale 4f0)} \texttt{~~~~(draw-text {}``Hello World!'' (v 0 0))} \texttt{~~~~(wait-keypress)))} \end{quotation} \newpage{} \section{Opening and closing PAL and handling resources} \subsection{Resources} \subsection{Functions and macros} \begin{description} \item [{OPEN-PAL}] (\&key \textit{width height fps title fullscreenp paths}) \end{description} Opens and initialises PAL window. \begin{description} \item [{\textit{width},}] width of the screen. \item [{\textit{height},}] height of the screen. If width and height are 0 then the default desktop dimensions are used. \item [{\textit{fps},}] maximum number of times per second that the screen is updated. \item [{\textit{title},}] title of the screen. \item [{\textit{fullscreenp},}] open in windowed or fullscreen mode. \item [{\textit{paths},}] pathname or list of pathnames that the load-{*} functions use to find resources. Initially holds {*}default-pathname-defauls{*} and PAL installation directory. \item [{CLOSE-PAL}] () \end{description} Closes PAL screen and frees all loaded resources. \begin{description} \item [{WITH-PAL}] (\&key \textit{width height fps title fullscreenp paths} \&body \textit{body}) \end{description} Opens PAL, executes \textit{body} and finally closes PAL. Arguments are same as with OPEN-PAL. \begin{description} \item [{FREE-RESOURCE}] (\textit{resource}) \end{description} Frees the \textit{resource} (image, font, sample or music). \begin{description} \item [{FREE-ALL-RESOURCES}] () \end{description} Frees all allocated resources. \begin{description} \item [{WITH-RESOURCE}] (\textit{var init-form}) \&body \textit{body} \end{description} Binds \textit{var} to the result of \textit{init-form} and executes \textit{body}. Finally calls FREE-RESOURCE on \textit{var.} \begin{description} \item [{GET-SCREEN-WIDTH}] () => \textit{number} \item [{GET-SCREEN-HEIGHT}] () => \textit{number} \end{description} Returns the dimensions of PAL screen. \newpage{} \section{Event handling} \subsection{Basics} There are two ways to handle events in PAL; the callback based HANDLE-EVENTS or EVENT-LOOP that call given functions when an event happens, or directly polling for key and mouse state with TEST-KEYS, KEY-PRESSED-P and GET-MOUSE-POS. NOTE: Even if you don't need to use the callback approach it is still necessary to call HANDLE-EVENTS on regular intervals, especially on Windows. Running an EVENT-LOOP does this automatically for you and is the preferred way to handle events. \subsection{Functions and macros} \begin{description} \item [{HANDLE-EVENTS}] (\&key \textit{key-up-fn key-down-fn mouse-motion-fn quit-fn}) \end{description} Get next event, if any, and call appropriate handler function. \begin{description} \item [{\textit{key-up-fn},}] called with the released key-sym. For key-syms see chapter 3.3 \item [{\textit{key-down-fn},}] called with the pressed key-sym. When \textit{key-down-fn} is not defined pressing Esc-key causes a quit event. \item [{\textit{mouse-motion-fn},}] called with x and y mouse coordinates. \item [{\textit{quit-fn},}] called without any arguments when user presses the windows close button. Also called when Esc key is pressed, unless \textit{key-down-fn} is defined. \item [{UPDATE-SCREEN}] () \end{description} Updates the PAL screen. No output is visible until UPDATE-SCREEN is called. \begin{description} \item [{EVENT-LOOP}] ((\&key \textit{key-up-fn key-down-fn mouse-motion-fn quit-fn}) \&body \textit{body}) \end{description} Repeatedly calls \textit{body} between HANDLE-EVENT and UPDATE-SCREEN. Arguments are the same as with HANDLE-EVENTS. Returns when (return-from event-loop) is called, or, if quit-fn is not given when quit event is generated. \begin{description} \item [{GET-MOUSE-POS}] () => \textit{vector} \item [{GET-MOUSE-X}] () => \textit{number} \item [{GET-MOUSE-Y}] () => \textit{number} \end{description} Returns the current position of mouse pointer. \begin{description} \item [{SET-MOUSE-POS}] (\textit{vector}) \end{description} Sets the position of mouse pointer. \begin{description} \item [{KEY-PRESSED-P}] (\textit{keysym}) => \textit{bool} \end{description} Test if the key \textit{keysym} is currently pressed down. For keysyms see chapter 3.3 \begin{description} \item [{TEST-KEYS}] ((\textit{key} | (\textit{keys}) \textit{form})) \end{description} Tests if any of the given keys are currently pressed. Evaluates \textit{all} matching forms. Example: \begin{quotation} (test-keys ~~(:key-left (move-left sprite)) ~~(:key-right (move-right sprite)) ~~((:key-ctrl :key-mouse-1) (shoot sprite)) \end{quotation} \begin{description} \item [{KEYSYM-CHAR}] (\textit{keysym}) => \textit{char} \end{description} Returns the corresponding Common Lisp character for \textit{keysym}, or NIL if the character is out the ASCII range 1-255. \begin{description} \item [{WAIT-KEYPRESS}] () => \textit{key} \end{description} Waits until a key is pressed and released \subsection{Keysyms} These are the symbols used to identify keyboard events. Note that mouse button and scroll wheel events are also represented as keysyms. \begin{quotation} :key-mouse-1 :key-mouse-2 :key-mouse-3 :key-mouse-4 :key-mouse-5 :key-unknown :key-first :key-backspace :key-tab :key-clear :key-return :key-pause :key-escape :key-space :key-exclaim :key-quotedbl :key-hash :key-dollar :key-ampersand :key-quote :key-leftparen :key-rightparen :key-asterisk :key-plus :key-comma :key-minus :key-period :key-slash :key-0 :key-1 :key-2 :key-3 :key-4 :key-5 :key-6 :key-7 :key-8 :key-9 :key-colon :key-semicolon :key-less :key-equals :key-greater :key-question :key-at :key-leftbracket :key-backslash :key-rightbracket :key-caret :key-underscore :key-backquote :key-a :key-b :key-c :key-d :key-e :key-f [594 lines skipped]

1 0

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

31 Oct '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv6234 Modified Files: changes.txt color.lisp pal.asd pal.lisp readme.txt todo.txt Log Message: Some polishing. Version 1.1 --- /project/pal/cvsroot/pal/changes.txt 2007/07/28 13:13:15 1.3 +++ /project/pal/cvsroot/pal/changes.txt 2007/10/31 12:51:22 1.4 @@ -1,3 +1,32 @@ +1.1, October 31 2007 + +- Fixed handling of texture sizes. Changed the location of application data folder on windows. + +- Fixed handling of coordinates in WITH-CLIPPING. + +- MESSAGE now accepts multiple arguments. + +- KEYSYM-CHAR now returns NIL for characters out the range 1 - 255. + +- Added fading arguments to play-music/halt-music. + +- RESET-BLEND-MODE renamed to RESET-BLEND. + +- Smoothp option now mostly works with filled polygons. + +- Minor cleanups and name changes: circles-overlap => circles-overlap-p, + point-inside-rectangle => point-inside-rectangle-p, point-in-line => point-in-line-p. + +- Optimised GL state handling. Image drawing is a lot faster under certain + conditions. + +- Added color.lisp, WITH-BLEND now uses COLOR struct instead of a list of rgba + values. + +- Removed CURRY. + + + 1.0, July 28 2007 - Numerous bugfixes and little improvements. @@ -16,7 +45,8 @@ - RELT renamed to RANDOM-ELEMENT. -- Added DRAW-ARROW, DRAW-CIRCLE, LOAD-IMAGE-TO-ARRAY, SCREEN-TO-ARRAY, IMAGE-FROM-FN. +- Added DRAW-ARROW, DRAW-CIRCLE, LOAD-IMAGE-TO-ARRAY, SCREEN-TO-ARRAY, + IMAGE-FROM-FN. - Tag thunks must now return only objects of type RESOURCE. --- /project/pal/cvsroot/pal/color.lisp 2007/10/30 20:43:10 1.1 +++ /project/pal/cvsroot/pal/color.lisp 2007/10/31 12:51:22 1.2 @@ -1,15 +1,19 @@ (in-package :pal) +(declaim (optimize (speed 3) + (safety 1))) + (defstruct color - (r 0 :type pal::u8) - (g 0 :type pal::u8) - (b 0 :type pal::u8) - (a 0 :type pal::u8)) + (r 0 :type u8) + (g 0 :type u8) + (b 0 :type u8) + (a 0 :type u8)) (declaim (inline color)) -(defun color (r g b a) +(defun color (r g b &optional (a 255)) + (declare (type u8 r) (type u8 g) (type u8 b) (type u8 a)) (make-color :r r :g g :b b :a a)) --- /project/pal/cvsroot/pal/pal.asd 2007/10/30 20:43:10 1.4 +++ /project/pal/cvsroot/pal/pal.asd 2007/10/31 12:51:22 1.5 @@ -9,7 +9,7 @@ ((:file "ffi" :depends-on ("package")) (:file "color" - :depends-on ("package")) + :depends-on ("package" "ffi")) (:file "vector" :depends-on ("pal-macros")) (:file "pal-macros" --- /project/pal/cvsroot/pal/pal.lisp 2007/10/30 20:43:10 1.38 +++ /project/pal/cvsroot/pal/pal.lisp 2007/10/31 12:51:22 1.39 @@ -180,7 +180,7 @@ (defunct keysym-char (keysym) (symbol keysym) - (if (or (eq keysym :key-mouse-1) (eq keysym :key-mouse-2) (eq keysym :key-mouse-3)) + (if (or (eq keysym :key-mouse-1) (eq keysym :key-mouse-2) (eq keysym :key-mouse-3) (eq keysym :key-mouse-4) (eq keysym :key-mouse-5)) nil (let ((kv (cffi:foreign-enum-value 'pal-ffi:sdl-key keysym))) (if (and (> kv 0) (< kv 256)) --- /project/pal/cvsroot/pal/readme.txt 2007/07/19 16:37:25 1.1 +++ /project/pal/cvsroot/pal/readme.txt 2007/10/31 12:51:23 1.2 @@ -1,11 +1,13 @@ Linux gfx card problems +-------------------------------------------------------------------------------- +(Edit: Update to Ubuntu 7.10 seems to have fixed my problems with X550.) It seems that some people (yours truly included, running Ubuntu 7.04 with ATI X550 and the OSS drivers) are having problems under Linux when trying to run PAL applications several times in the same Lisp session. I did some testing and -it _looks_ like the problem is in some graphics cards drivers. Of course it is +it seems to be a problem in some graphics cards drivers. Of course it is possible that there is a bug in PAL, but so far I haven't find it. Running the following function twice after PAL is loaded should trigger the bug, @@ -52,3 +54,66 @@ don't need to open/close PAL several times should work fine. -- tomppa + + + + +About performance +-------------------------------------------------------------------------------- +Few notes about how to get the maximum graphics performance from PAL: + +First, if you don't notice any problems there is no need to worry about +performance. Using OpenGL for 2d graphics is likely to be very fast, even +when naively implemented and running on low-end hardware. + + +Functions like draw-circle, -line and -polygon are quite slow. Normally it +shouldn't be problem but if you want to do complex vector graphics it +could. This is mostly a design issuea since PAL is more oriented towards +bitmap graphics, if you need faster polygon primitives let me know the +details and I'll see what I can do. + +Internally draw-image/draw-image* works by "chaining" the draw operations +and as long as the chain is not cut performance is very good. If the chain +is repeatedly cut you will get lousy performance. + +The chain is cut when: + +- You call any graphics function except draw-image or draw-image*. +- You use any graphics state altering functions or macros (rotate, scale, +set-blend-mode, with-transformation etc.) except set-blend-color. +- You draw a different image than with the previous draw-image calls. +Internally PAL keeps count of the "current" image and whenever it changes +the chain gets cut. +- You use the :angle or :scale keywords in draw-image. That maybe fixed in +the future. (Also the alignment keywords cut the chain, due to my +laziness. I'll fix that soon.) + +It's okay to have rotations and image changes but to get maximum +performance you need to make sure they don't regularly cut the chain. +So if you are only allowed to draw the same image again and again how you +get anything interesting on the screen? By tiling your graphics in one big +image and using the draw-image* you can avoid the need to change image and +in some cases you can use set-blend-color to change the color of image. +At some point I'm going to add a mechanism for cutting images to tiles +which then can be used interchangebly with regular images, that should +make avoiding image changes much easier. + + +About the examples/ + +- teddy.lisp is an especially bad example of chaining. Since the teddies +all have the same image drawing them would be very fast if not +a) when drawing the shadows with-transformation gets repeatedly called. It +would be better to translate the shadow position manually +b) the teddies need to be rotated. + +- hares.lisp works suprisingly well altough it uses rotations and scaling. +It should be very fast if these wouldn't cut the chain :( + +Again, if you don't have any perfomance problems just ignore what I just +wrote :) + + +-- +tomppa --- /project/pal/cvsroot/pal/todo.txt 2007/10/30 20:43:10 1.20 +++ /project/pal/cvsroot/pal/todo.txt 2007/10/31 12:51:23 1.21 @@ -1,8 +1,6 @@ TODO: -For v1.1 - - Fix offsets in draw-image. - Polygon smooth hint? @@ -13,13 +11,11 @@ - Structured color values. +- Utilities for interfacing with CL-Imago. +- Better drawing primitives. Real lines, complex polygons, start/end args to draw-circle etc. -After v1.1 - -- Better drawing primitives, real lines, start/end args to draw-circle etc. - -- As always, optimise GL state handling. +- As always, optimise GL state handling. Blitting in batches, possibly VOBs. - Implement image mirroring, tiles and animation.

1 0

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

31 Oct '07

Update of /project/pal/cvsroot/pal-gui/examples In directory clnet:/tmp/cvs-serv6198 Modified Files: files.lisp packing.lisp test.lisp Log Message: Version 0.1 --- /project/pal/cvsroot/pal-gui/examples/files.lisp 2007/10/29 21:09:20 1.2 +++ /project/pal/cvsroot/pal-gui/examples/files.lisp 2007/10/31 12:50:42 1.3 @@ -1,6 +1,7 @@ (in-package :pal-gui) +;; a Toy file selector (defclass file-widget (v-box) ((list-widget :accessor list-widget-of) @@ -14,7 +15,7 @@ (selected-of lg))))) (let ((hbox (make-instance 'h-box :parent g :gap 2 :y-expand-p nil))) (setf (text-widget-of g) (make-instance 'text-widget :parent hbox)) - (setf (select-of g) (make-instance 'button :x-expand-p nil :width (get-m) :value :box :parent hbox))) + (setf (select-of g) (make-instance 'button :x-expand-p nil :width *m* :value :box :parent hbox))) (update-view g)) (defmethod update-view ((g file-widget)) --- /project/pal/cvsroot/pal-gui/examples/packing.lisp 2007/10/30 20:44:45 1.3 +++ /project/pal/cvsroot/pal-gui/examples/packing.lisp 2007/10/31 12:50:42 1.4 @@ -45,7 +45,7 @@ (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)) - (pin (make-instance 'pin :value "Foo" :g 30 :b 30 :parent box :pos (v 100 30))) + (pin (make-instance 'pin :value "Foo" :color (color 255 30 30 128) :parent box :pos (v 100 30))) (a (make-instance 'button :value "Button" :parent hbox)) (f (make-instance 'filler :parent hbox)) (b (make-instance 'button :value "Button" :parent hbox)) --- /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/30 20:44:45 1.13 +++ /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/31 12:50:42 1.14 @@ -2,8 +2,8 @@ ;; ;; window sizing, dialogs, menus, keyboard control, scrollwheel ;; debugging utils, scrolling mixin -;; scroll box, paragraph, text box, simple editor, combo box, tree view, gridbox, property list -;; File open/save, choose directory, yes/no dialogs +;; scroll box, paragraph, text box, simple editor, combo box, tree view, gridbox, property list, tabs +;; File open/save, choose directory, yes/no dialogs, color selector (defpackage :test (:use :cl :pal :pal-gui))

1 0

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

30 Oct '07

Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv32566 Modified Files: gob.lisp gui.lisp package.lisp present.lisp widgets.lisp Log Message: GET-MIN-HEIGHT/WIDTH didn't work under CLisp, fixed. Widgets now use PAL:COLOR structure where appropriate. --- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/30 00:20:41 1.13 +++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/30 20:44:46 1.14 @@ -1,5 +1,8 @@ (in-package :pal-gui) +(declaim (optimize (speed 3))) + + (defvar *root* nil) (defvar *drag-start-pos* nil) (defvar *relative-drag-start-pos* nil) @@ -181,9 +184,10 @@ (pack parent)) (defmethod min-width-of ((g v-packing)) - (+ (loop for c in (childs-of g) maximizing (min-width-of c)) - (gap-of g) - (* 2 (x-pad-of g)))) + (let ((childs-min (loop for c in (childs-of g) maximizing (min-width-of c)))) + (+ (if childs-min childs-min 0) + (gap-of g) + (* 2 (x-pad-of g))))) (defmethod min-height-of ((g v-packing)) (+ (* (1- (length (childs-of g))) (gap-of g)) @@ -218,9 +222,10 @@ ()) (defmethod min-height-of ((g h-packing)) - (+ (loop for c in (childs-of g) maximizing (min-height-of c)) - (gap-of g) - (* 2 (y-pad-of g)))) + (let ((childs-min (loop for c in (childs-of g) maximizing (min-height-of c)))) + (+ (if childs-min childs-min 0) + (gap-of g) + (* 2 (y-pad-of g))))) (defmethod min-width-of ((g h-packing)) (+ (* (1- (length (childs-of g))) (gap-of g)) --- /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/30 00:20:41 1.9 +++ /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/30 20:44:46 1.10 @@ -1,5 +1,56 @@ (in-package :pal-gui) +(declaim (optimize (speed 3))) + + + +(defun config-gui (&key (font *gui-font*) (window-color *window-color*) (widget-color *widget-color*) + (paper-color *paper-color*) (tooltip-delay *tooltip-delay*) (text-color *text-color*)) + (setf *gui-font* font + *window-color* window-color + *widget-color* widget-color + *text-color* text-color + *paper-color* paper-color + *tooltip-delay* tooltip-delay + *m* (truncate (* (get-font-height *gui-font*) 1.5)) + *text-offset* (let ((fh (get-font-height *gui-font*))) + (v (truncate fh 2) (truncate fh 4))))) + +(defun update-gui () + "Like PAL:UPDATE but also updates the GUI" + (pal::close-quads) + (reset-blend) + (pal-ffi:gl-load-identity) + (repaint *root*) + (update-screen)) + + +(defun active-gobs-at-point (point parent) + (let ((c (find-if (lambda (c) + (point-inside-p c point)) + (reverse (childs-of parent))))) + (if c + (if (activep c) + (cons c (active-gobs-at-point point c)) + (active-gobs-at-point point c)) + nil))) + +(defun init-gui () + (setf *root* (make-instance 'root :parent nil) + *gui-font* (tag 'pal::default-font) + *drag-start-pos* nil + *relative-drag-start-pos* nil + *focused-gob* nil + *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) + :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) "Same as PAL:EVENT-LOOP but with added GUI event handling" @@ -58,36 +109,4 @@ (init-gui) (unwind-protect (progn ,@body) - (close-pal)))) - - -(defun active-gobs-at-point (point parent) - (let ((c (find-if (lambda (c) - (point-inside-p c point)) - (reverse (childs-of parent))))) - (if c - (if (activep c) - (cons c (active-gobs-at-point point c)) - (active-gobs-at-point point c)) - nil))) - -(defun init-gui () - (setf *root* (make-instance 'root :parent nil) - *gui-font* (tag 'pal::default-font) - *drag-start-pos* nil - *relative-drag-start-pos* nil - *focused-gob* nil - *pointed-gob* nil - *armed-gob* nil)) - -(defun update-gui () - "Like PAL:UPDATE but also updates the GUI" - (pal::close-quads) - (reset-blend) - (pal-ffi:gl-load-identity) - (repaint *root*) - (update-screen)) - -(defun set-gui-font (font) - (assert (font-p font)) - (setf *gui-font* font)) \ No newline at end of file + (close-pal)))) \ No newline at end of file --- /project/pal/cvsroot/pal-gui/package.lisp 2007/10/30 00:20:41 1.4 +++ /project/pal/cvsroot/pal-gui/package.lisp 2007/10/30 20:44:46 1.5 @@ -1,6 +1,6 @@ (defpackage #:pal-gui (:use :common-lisp :pal) - (:export #:with-gui #:init-gui #:update-gui #:gui-loop #:set-gui-font + (:export #:with-gui #:init-gui #:update-gui #:gui-loop #:config-gui #:present --- /project/pal/cvsroot/pal-gui/present.lisp 2007/10/29 20:06:01 1.2 +++ /project/pal/cvsroot/pal-gui/present.lisp 2007/10/30 20:44:46 1.3 @@ -1,12 +1,9 @@ (in-package :pal-gui) -(defgeneric present (object gob width height)) - - (defmethod present (object (g widget) width height) (with-blend (:color *text-color*) - (draw-text (format nil "~a" object) (v (vx (get-text-offset)) + (draw-text (format nil "~a" object) (v (vx *text-offset*) (- (truncate height 2) (truncate (get-font-height *gui-font*) 2) 1))))) @@ -20,33 +17,33 @@ (draw-polygon (list (v 3 (- height 3)) (v (/ width 2) 3) (v (- width 3) (- height 3))) - (first *text-color*) (second *text-color*) (third *text-color*)(fourth *text-color*) :smoothp t)) + (color-r *text-color*) (color-g *text-color*) (color-b *text-color*)(color-a *text-color*) :smoothp t)) (defmethod present ((s (eql :down-arrow)) (g widget) width height) (draw-polygon (list (v 3 3) (v (/ width 2) (- height 3)) (v (- width 3) 3)) - (first *text-color*) (second *text-color*) (third *text-color*)(fourth *text-color*) :smoothp t)) + (color-r *text-color*) (color-g *text-color*) (color-b *text-color*)(color-a *text-color*) :smoothp t)) (defmethod present ((s (eql :right-arrow)) (g widget) width height) (draw-polygon (list (v 3 3) (v (- width 3) (/ height 2)) (v 3 (- height 3))) - (first *text-color*) (second *text-color*) (third *text-color*)(fourth *text-color*) :smoothp t)) + (color-r *text-color*) (color-g *text-color*) (color-b *text-color*)(color-a *text-color*) :smoothp t)) (defmethod present ((s (eql :left-arrow)) (g widget) width height) (draw-polygon (list (v (- width 3) 3) (v 3 (/ height 2)) (v (- width 3) (- height 3))) - (first *text-color*) (second *text-color*) (third *text-color*)(fourth *text-color*) :smoothp t)) + (color-r *text-color*) (color-g *text-color*) (color-b *text-color*)(color-a *text-color*) :smoothp t)) (defmethod present ((s (eql :box)) (g widget) width height) - (draw-rectangle (v 3 3) (- width 6) (- height 6) (first *text-color*) (second *text-color*) (third *text-color*)(fourth *text-color*) :smoothp t)) + (draw-rectangle (v 3 3) (- width 6) (- height 6) (color-r *text-color*) (color-g *text-color*) (color-b *text-color*)(color-a *text-color*) :smoothp t)) (defmethod present ((s (eql :circle)) (g widget) width height) - (draw-circle (v (/ width 2) (/ height 2)) (/ (min width height) pi) (first *text-color*) (second *text-color*) (third *text-color*)(fourth *text-color*) :smoothp t)) + (draw-circle (v (/ width 2) (/ height 2)) (/ (min width height) pi) (color-r *text-color*) (color-g *text-color*) (color-b *text-color*)(color-a *text-color*) :smoothp t)) --- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/30 00:20:41 1.13 +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/30 20:44:46 1.14 @@ -1,35 +1,35 @@ (in-package :pal-gui) +;; (declaim (optimize (speed 3))) -(defparameter *window-color* '(140 140 140 160)) -(defparameter *widget-color* '(180 180 180 128)) -(defparameter *text-color* '(0 0 0 255)) -(defparameter *paper-color* '(255 255 200 255)) -(defparameter *tooltip-delay* 1) + +(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 *gui-font* nil) -(defun get-m () - (truncate (* (get-font-height *gui-font*) 1.5))) + (defun get-text-bounds (string) (let ((fh (get-font-height *gui-font*))) (values (max (truncate (* 1.5 fh)) (+ (get-text-size string *gui-font*) fh)) (truncate (* fh 1.5))))) -(defun get-text-offset () - (let ((fh (get-font-height *gui-font*))) - (v (truncate fh 2) (truncate fh 4)))) (defun draw-frame (pos width height color &key style (border 1) (fill t)) (let ((pos (v-floor pos)) (width (truncate width)) (height (truncate height)) - (r (first color)) - (g (second color)) - (b (third color)) - (a (fourth color))) + (r (color-r color)) + (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 @@ -48,6 +48,7 @@ +(defgeneric present (object gob width height)) @@ -62,10 +63,10 @@ (on-key-down :accessor on-key-down-of :initarg :on-key-down :initform (lambda (widget char) (declare (ignore widget char)) nil)) (on-enter :accessor on-enter-of :initarg :on-enter :initform (lambda (widget) (declare (ignore widget)) nil)) (on-leave :accessor on-leave-of :initarg :on-leave :initform (lambda (widget) (declare (ignore widget)) nil))) - (:default-initargs :width (get-m) :height (get-m))) + (:default-initargs :width *m* :height *m*)) -(defmethod on-inspect ((g widget)) +(defmethod on-inspect ((g gob)) (message g)) (defmethod on-drag :around ((g widget) pos d) @@ -120,39 +121,38 @@ (defmethod repaint ((g box)) (when (label-of g) - (let ((text-offset (get-text-offset))) - (with-accessors ((width width-of) (height height-of) (label label-of)) g + (with-accessors ((width width-of) (height height-of) (label label-of)) g - (draw-line (v 0 0) (v 0 height) 0 0 0 160) - (draw-line (v width 0) (v width height) 0 0 0 160) - (draw-line (v 0 height) (v width height) 0 0 0 160) + (draw-line (v 0 0) (v 0 height) 0 0 0 160) + (draw-line (v width 0) (v width height) 0 0 0 160) + (draw-line (v 0 height) (v width height) 0 0 0 160) - (draw-line (v 0 0) (v (vx text-offset) 0) 0 0 0 160) - (draw-line (v (- (get-text-bounds label) (vx text-offset)) 0) (v width 0) 0 0 0 160) + (draw-line (v 0 0) (v (vx *text-offset*) 0) 0 0 0 160) + (draw-line (v (- (get-text-bounds label) (vx *text-offset*)) 0) (v width 0) 0 0 0 160) - (with-blend (:color *text-color*) - (draw-text label (v- text-offset (v 0 (truncate (get-m) 2))) *gui-font*)))))) + (with-blend (:color *text-color*) + (draw-text label (v- *text-offset* (v 0 (truncate *m* 2))) *gui-font*))))) (defclass v-box (box v-packing) () - (:default-initargs :x-pad 0 :y-pad 0 :gap (truncate (get-m) 3))) + (:default-initargs :x-pad 0 :y-pad 0 :gap (truncate *m* 3))) (defmethod initialize-instance :after ((g v-box) &key label) (when label - (setf (y-pad-of g) (truncate (get-m) 2) - (x-pad-of g) (truncate (get-m) 2)))) + (setf (y-pad-of g) (truncate *m* 2) + (x-pad-of g) (truncate *m* 2)))) (defclass h-box (box h-packing) () - (:default-initargs :x-pad 0 :y-pad 0 :gap (truncate (get-m) 2))) + (:default-initargs :x-pad 0 :y-pad 0 :gap (truncate *m* 2))) (defmethod initialize-instance :after ((g h-box) &key label) (when label - (setf (y-pad-of g) (truncate (get-m) 2) - (x-pad-of g) (truncate (get-m) 2)))) + (setf (y-pad-of g) (truncate *m* 2) + (x-pad-of g) (truncate *m* 2)))) @@ -169,29 +169,29 @@ (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 :x-pad (truncate (get-m) 2) :y-pad (truncate (get-m) 3) :gap (truncate (get-m) 3) :pos (v 10 10))) + (:default-initargs :activep t :width 100 :height 100 :x-pad (truncate *m* 2) :y-pad (truncate *m* 3) :gap (truncate *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-drag :around ((g window) start d) (declare (ignore d)) - (when (< (vy start) (get-m)) + (when (< (vy start) *m*) (call-next-method))) (defmethod on-button-down ((g window) pos) - (when (< (vy pos) (get-m)) + (when (< (vy pos) *m*) (raise g))) (defmethod repaint ((g window)) (with-accessors ((width width-of) (height height-of) (label label-of)) g (draw-frame (v 0 0) width height *window-color* :style :raised) - (draw-rectangle (v 0 0) width (get-m) 0 0 0 128) - (draw-line (v 0 (get-m)) (v width (get-m)) 0 0 0 160) - (draw-line (v 0 (1+ (get-m))) (v width (1+ (get-m))) 0 0 0 64) - (draw-line (v 0 (+ (get-m) 2)) (v width (+ (get-m) 2)) 0 0 0 32) - (with-blend (:color '(255 255 255 255)) - (draw-text label (get-text-offset) *gui-font*)))) + (draw-rectangle (v 0 0) width *m* 0 0 0 128) + (draw-line (v 0 *m*) (v width *m*) 0 0 0 160) + (draw-line (v 0 (1+ *m*)) (v width (1+ *m*)) 0 0 0 64) + (draw-line (v 0 (+ *m* 2)) (v width (+ *m* 2)) 0 0 0 32) + (with-blend (:color (color 255 255 255 255)) + (draw-text label *text-offset* *gui-font*)))) @@ -213,16 +213,14 @@ (defclass pin (label sliding highlighted constrained) - ((r :accessor r-of :initarg :r :initform 255) - (g :accessor g-of :initarg :g :initform 255) - (b :accessor b-of :initarg :b :initform 255) - (a :accessor a-of :initarg :a :initform 255)) + ((color :accessor color-of :initarg :color :initform *paper-color*)) (:default-initargs :activep t)) (defmethod repaint ((g pin)) - (draw-rectangle (v 0 0) (width-of g) (height-of g) (r-of g) (g-of g) (b-of g) (a-of g)) - (call-next-method) - (draw-rectangle (v 0 0) (width-of g) (height-of g) 0 0 0 (a-of g) :fill nil)) + (let ((c (color-of g))) + (draw-rectangle (v 0 0) (width-of g) (height-of g) (color-r c) (color-g c) (color-b c) (color-a c)) + (call-next-method) + (draw-rectangle (v 0 0) (width-of g) (height-of g) 0 0 0 (color-a c) :fill nil))) @@ -273,15 +271,14 @@ (with-accessors ((width width-of) (height height-of) (value value-of) (min-value min-value-of) (max-value max-value-of)) g (let* ((vt (princ-to-string value)) (sw (get-text-bounds vt)) - (m (get-m)) (k (truncate (* (/ (width-of g) (abs (- min-value max-value))) (- value min-value)))) (kpos (v (- k (truncate sw 2)) 0))) - (draw-frame (v 0 (truncate m 3)) width (truncate height 2) *window-color* :style :sunken) - (draw-frame kpos sw m *widget-color* :style :raised) - (draw-frame (v+ kpos (v (truncate sw 2) 0)) 3 (/ m 4) '(0 0 0 0) :style :sunken :fill nil) - (draw-frame (v+ kpos (v (truncate sw 2) m)) 3 (- (/ m 4)) '(0 0 0 0) :style :sunken :fill nil) + (draw-frame (v 0 (truncate *m* 3)) width (truncate height 2) *window-color* :style :sunken) + (draw-frame kpos sw *m* *widget-color* :style :raised) + (draw-frame (v+ kpos (v (truncate sw 2) 0)) 3 (/ *m* 4) (color 0 0 0 0) :style :sunken :fill nil) + (draw-frame (v+ kpos (v (truncate sw 2) *m*)) 3 (- (/ *m* 4)) (color 0 0 0 0) :style :sunken :fill nil) (with-blend (:color *text-color*) - (draw-text vt (v+ kpos (get-text-offset)) *gui-font*))))) + (draw-text vt (v+ kpos *text-offset*) *gui-font*))))) @@ -315,7 +312,7 @@ *widget-color* :style :raised) (draw-frame (v+ kpos (v 1 (1- (truncate (min height (- height (* (- units ps) usize))) 2)))) (- width 2) - 3 '(255 255 255 0) :style :sunken)))) + 3 (color 255 255 255 0) :style :sunken)))) @@ -337,19 +334,19 @@ (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 3) by 2 do + (loop for x from 1 to (- k 3) by 3 do (draw-line (v x 1) (v x (1- height)) 148 148 148 255)) (with-blend (:color *widget-color*) - (draw-text (princ-to-string value) (v+ (v 1 1) (get-text-offset)) *gui-font*)) + (draw-text (princ-to-string value) (v+ (v 1 1) *text-offset*) *gui-font*)) (with-blend (:color *text-color*) - (draw-text (princ-to-string value) (get-text-offset) *gui-font*))))) + (draw-text (princ-to-string value) *text-offset* *gui-font*))))) (defclass list-view (widget) - ((items :accessor items-of :initarg :items :initform '()) - (item-height :reader item-height-of :initarg :item-height :initform (get-m)) + ((items :accessor items-of :initarg :items :initform nil) + (item-height :reader item-height-of :initarg :item-height :initform *m*) (multip :reader multip :initarg :multip :initform nil) (selected :accessor selected-of :initform nil) (scroll :reader scroll-of :initform 0)) @@ -405,8 +402,8 @@ (slider :accessor slider-of)) (:default-initargs :gap 3)) -(defmethod initialize-instance :after ((g list-widget) &key items (item-height (get-m)) (multip nil) &allow-other-keys) - (let* ((w (truncate (get-m) 1.5)) +(defmethod initialize-instance :after ((g list-widget) &key items (item-height *m*) (multip nil) &allow-other-keys) + (let* ((w (truncate *m* 1.5)) (list-view (make-instance 'list-view :multip multip :items items @@ -471,23 +468,23 @@ (defmethod repaint ((g radio-item)) (with-accessors ((height height-of) (width width-of) (value value-of)) g - (let* ((m/2 (truncate (get-m) 2)) + (let* ((m/2 (truncate *m* 2)) (m/4 (truncate m/2 2)) (ypos (truncate height 2))) (draw-circle (v m/4 ypos) (1+ (truncate m/2 2)) 0 0 0 255 - :smoothp t) + :smoothp t :segments 10) (draw-circle (v m/4 ypos) (truncate m/2 2) - (first *paper-color*) (second *paper-color*) (third *paper-color*) (fourth *paper-color*) - :smoothp t) + (color-r *paper-color*) (color-g *paper-color*) (color-b *paper-color*) (color-a *paper-color*) + :smoothp t :segments 10) (when (state-of g) (draw-circle (v m/4 ypos) (- (truncate m/2 2) 2) 0 0 0 255 - :smoothp t)) - (with-transformation (:pos (v (truncate (get-m) 1.5) 0)) - (present value g (- width (get-m)) height))))) + :smoothp t :segments 10)) + (with-transformation (:pos (v (truncate *m* 1.5) 0)) + (present value g (- width *m*) height))))) (defclass choice-item (button) @@ -495,7 +492,7 @@ (defmethod repaint ((g choice-item)) (with-accessors ((height height-of) (width width-of) (value value-of)) g - (let* ((m/2 (truncate (get-m) 2)) + (let* ((m/2 (truncate *m* 2)) (ypos (- (truncate height 2) (truncate m/2 2)))) (draw-frame (v 0 ypos) m/2 m/2 @@ -506,17 +503,17 @@ (- m/2 1) (- m/2 1) *widget-color* :style :raised)) - (with-transformation (:pos (v (truncate (get-m) 1.5) 0)) - (present value g (- width (get-m)) height))))) + (with-transformation (:pos (v (truncate *m* 1.5) 0)) + (present value g (- width *m*) height))))) (defclass choice-widget (v-box) ((multip :accessor multip :initarg :multip :initform nil) - (items :accessor items-of :initarg :items :initform '()))) + (items :accessor items-of :initarg :items :initform nil))) -(defmethod initialize-instance :after ((g choice-widget) &key items multip (item-height (get-m)) &allow-other-keys) +(defmethod initialize-instance :after ((g choice-widget) &key items multip (item-height *m*) &allow-other-keys) (setf (items-of g) (mapcar (lambda (i) (make-instance (if multip 'choice-item 'radio-item) :parent g @@ -556,14 +553,13 @@ (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-rectangle (v 1 1) (1- width) (1- height) (first *paper-color*) (second *paper-color*) (third *paper-color*) (fourth *paper-color*)) - (let* ((offset (get-text-offset)) - (point-x (+ (vx offset) (get-text-size (subseq text 0 point))))) + (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*) - (draw-text text offset *gui-font*) + (draw-text text *text-offset* *gui-font*) (when (focusedp g) - (draw-rectangle (v point-x (vy offset)) - 2 (- height (* 2 (vy offset))) + (draw-rectangle (v point-x (vy *text-offset*)) + 2 (- height (* 2 (vy *text-offset*))) 0 0 0 255)))))) (defmethod on-key-down ((g text-widget) char) @@ -576,7 +572,7 @@ (defclass tooltip (gob) ((host :accessor host-of :initarg :host) (text :reader text-of :initarg :text :initform "")) - (:default-initargs :activep nil :width 100 :height (get-m) :pos (get-mouse-pos))) + (:default-initargs :activep nil :width 100 :height *m* :pos (get-mouse-pos))) (defmethod initialize-instance :after ((g tooltip) &key text &allow-other-keys) (setf (width-of g) (get-text-bounds text)) @@ -586,7 +582,7 @@ (defmethod repaint ((g tooltip)) (unless (pointedp (host-of g)) (setf (parent-of g) nil)) - (draw-rectangle (v 0 0) (width-of g) (height-of g) (first *paper-color*) (second *paper-color*) (third *paper-color*) (fourth *paper-color*)) + (draw-rectangle (v 0 0) (width-of g) (height-of g) (color-r *paper-color*) (color-g *paper-color*) (color-b *paper-color*) (color-a *paper-color*)) (draw-rectangle (v 0 0) (width-of g) (height-of g) 0 0 0 255 :fill nil) (with-blend (:color *text-color*) - (draw-text (text-of g) (get-text-offset) *gui-font*))) \ No newline at end of file + (draw-text (text-of g) *text-offset* *gui-font*))) \ No newline at end of file

1 0

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

30 Oct '07

Update of /project/pal/cvsroot/pal-gui/examples In directory clnet:/tmp/cvs-serv32566/examples Modified Files: colors.lisp packing.lisp test.lisp Log Message: GET-MIN-HEIGHT/WIDTH didn't work under CLisp, fixed. Widgets now use PAL:COLOR structure where appropriate. --- /project/pal/cvsroot/pal-gui/examples/colors.lisp 2007/10/29 20:06:01 1.1 +++ /project/pal/cvsroot/pal-gui/examples/colors.lisp 2007/10/30 20:44:45 1.2 @@ -1,13 +1,11 @@ (in-package :pal-gui) -(defstruct color r g b) - -(defparameter *bg* (make-color :r 0 :g 0 :b 0)) +(defparameter *bg* (color 0 0 0 255)) (defmethod present ((c color) w width height) - (with-blend (:color (list (color-r c) (color-g c) (color-b c) 255)) - (draw-text (format nil "#~16R~16R~16R" (color-r c) (color-g c) (color-b c)) (get-text-offset)))) + (with-blend (:color c) + (draw-text (format nil "#~16R~16R~16R" (color-r c) (color-g c) (color-b c)) *text-offset*))) (defmethod present ((c color) (w list-view) width height) (draw-rectangle (v 0 0) width height (color-r c) (color-g c) (color-b c) 255)) @@ -21,9 +19,7 @@ (list (make-instance 'list-widget :parent window :on-select (lambda (g) (setf (value-of button) (selected-of g))) - :items (loop repeat 100 collecting (make-color :r (random 255) - :g (random 255) - :b (random 255)))))) + :items (loop repeat 100 collecting (random-color))))) (setf (on-select-of button) (lambda (g) (setf *bg* (selected-of list)))) --- /project/pal/cvsroot/pal-gui/examples/packing.lisp 2007/10/29 21:09:20 1.2 +++ /project/pal/cvsroot/pal-gui/examples/packing.lisp 2007/10/30 20:44:45 1.3 @@ -20,12 +20,11 @@ (f (make-instance 'button :value "a Button" :parent left-box))) (gui-loop () - (clear-screen 50 50 255)))))) + (clear-screen 50 50 255)))))) ;; (test) - (defun test () (with-gui () (let* ((window (make-instance 'window :pos (v 200 200) :width 300 :height 200))) @@ -35,7 +34,7 @@ (c (make-instance 'button :value "Foo" :parent window :y-expand-p t))) (gui-loop () - (clear-screen 50 50 255)))))) + (clear-screen 50 50 255)))))) ;; (test) @@ -56,6 +55,6 @@ (loop repeat 10 do (make-instance 'pin :value "Foo" :b 0 :pos (v (random 800) (random 600)))) (gui-loop () - (clear-screen 50 50 255)))))) + (clear-screen 50 50 255)))))) ;; (test) \ No newline at end of file --- /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/30 00:20:40 1.12 +++ /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/30 20:44:45 1.13 @@ -1,8 +1,8 @@ ;; TODO: ;; -;; window sizing, dialogs, menus, keyboard control, scrollwheel, fix pal's clipping +;; window sizing, dialogs, menus, keyboard control, scrollwheel ;; debugging utils, scrolling mixin -;; joystick, scroll box, paragraph, text box, simple editor, combo box, tree view, gridbox, property list +;; scroll box, paragraph, text box, simple editor, combo box, tree view, gridbox, property list ;; File open/save, choose directory, yes/no dialogs (defpackage :test @@ -34,7 +34,7 @@ (ag (make-instance 'h-gauge :parent left-box :min-value 0 :max-value 255 :value 0)) (list (make-instance 'list-widget :parent window-2 - :item-height 64 + :item-height 48 :items (loop for i from 0 to 50 collect (format nil "FooBar ~a" i)) :multip nil :on-select (lambda (g) @@ -44,14 +44,14 @@ :parent window-2 :on-select (lambda (g) (setf (items-of list) (remove-if-not 'image-p pal-ffi::*resources*))))) (choice (make-instance 'choice-widget :label "Foo" :parent window-2 :items '("First" "Second" "and Third"))) - (pin (make-instance 'pin :value "Plane" :pos (v 400 300) :a 128)) + (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 '(0 0 0 64)) + (with-blend (:color (color 0 0 0 64)) (draw-image plane (pos-of pin))) - (with-blend (:color (list (value-of rg) (value-of gg) (value-of bg) (value-of ag))) + (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

1 0

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

30 Oct '07

Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv32428 Modified Files: package.lisp pal-macros.lisp pal.asd pal.lisp todo.txt vector.lisp Added Files: color.lisp Log Message: Added color.lisp. WITH-BLEND now takes a COLOR structure as its :COLOR argument instead of a list. --- /project/pal/cvsroot/pal/package.lisp 2007/10/24 18:07:03 1.20 +++ /project/pal/cvsroot/pal/package.lisp 2007/10/30 20:43:10 1.21 @@ -370,7 +370,7 @@ #:free-resource #:free-all-resources #:define-tags - #:add-tag + #:add-tag #:tag #:sample #:music @@ -388,8 +388,8 @@ #:random-elt #:clamp #:do-n - - #:handle-events + + #:handle-events #:key-pressed-p #:keysym-char #:test-keys @@ -451,6 +451,8 @@ #:play-music #:halt-music + #:color #:color-r #:color-g #:color-b #:color-a #:random-color + #:v #:vec #:copy-vec #:angle-v #:v-angle #:vx #:vy #:v= #:v-round #:v-floor #:v-random #:v+ #:v+! #:v- #:v-! #:v* #:v*! #:v/ #:v/! #:v-max #:v-min #:v-rotate --- /project/pal/cvsroot/pal/pal-macros.lisp 2007/10/24 17:51:47 1.15 +++ /project/pal/cvsroot/pal/pal-macros.lisp 2007/10/30 20:43:10 1.16 @@ -90,20 +90,20 @@ (defmacro with-default-settings (&body body) "Evaluate BODY with default transformations and blend settings." `(with-transformation () - (with-blend (:mode :blend :color '(255 255 255 255)) + (with-blend (:mode :blend :color (color 255 255 255 255)) (pal-ffi:gl-load-identity) ,@body))) (defmacro with-blend ((&key (mode t) color) &body body) - "Evaluate BODY with blend options set to MODE and COLOR. Color is a list of (r g b a) values." + "Evaluate BODY with blend options set to MODE and COLOR." `(progn (close-quads) (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-color-buffer-bit+ pal-ffi:+gl-current-bit+ pal-ffi:+gl-enable-bit+)) ,(unless (eq mode t) `(set-blend-mode ,mode)) ,(when color - `(set-blend-color (first ,color) (second ,color) (third ,color) (fourth ,color))) + `(set-blend-color (color-r ,color) (color-g ,color) (color-b ,color) (color-a ,color))) (prog1 (progn ,@body) (close-quads) --- /project/pal/cvsroot/pal/pal.asd 2007/07/21 16:34:16 1.3 +++ /project/pal/cvsroot/pal/pal.asd 2007/10/30 20:43:10 1.4 @@ -8,12 +8,14 @@ :components ((:file "ffi" :depends-on ("package")) + (:file "color" + :depends-on ("package")) (:file "vector" :depends-on ("pal-macros")) (:file "pal-macros" - :depends-on ("ffi")) + :depends-on ("ffi" "color")) (:file "pal" - :depends-on ("pal-macros" "vector")) + :depends-on ("pal-macros" "color" "vector")) (:file "package")) :depends-on ("cffi")) --- /project/pal/cvsroot/pal/pal.lisp 2007/10/29 20:04:19 1.37 +++ /project/pal/cvsroot/pal/pal.lisp 2007/10/30 20:43:10 1.38 @@ -1,8 +1,3 @@ -;; Notes: -;; add start/end args to draw-circle -;; check for redundant close-quads, optimise rotations/offsets etc. in draw-image -;; optimise gl state handling, fix clipping, structured color values - (declaim (optimize (speed 3) (safety 1))) @@ -185,10 +180,12 @@ (defunct keysym-char (keysym) (symbol keysym) - (let ((kv (cffi:foreign-enum-value 'pal-ffi:sdl-key keysym))) - (if (and (> kv 0) (< kv 256)) - (code-char kv) - nil))) + (if (or (eq keysym :key-mouse-1) (eq keysym :key-mouse-2) (eq keysym :key-mouse-3)) + nil + (let ((kv (cffi:foreign-enum-value 'pal-ffi:sdl-key keysym))) + (if (and (> kv 0) (< kv 256)) + (code-char kv) + nil)))) (declaim (inline get-mouse-pos)) (defun get-mouse-pos () @@ -882,9 +879,7 @@ (declaim (inline get-font-height)) (defunct get-font-height (&optional font) ((or font boolean) font) - (pal-ffi:font-height (if font - font - (tag 'default-font)))) + (pal-ffi:font-height (or font (tag 'default-font)))) (defunct get-text-size (text &optional font) ((or font boolean) font simple-string text) @@ -904,5 +899,4 @@ (defun message (&rest messages) (setf *messages* (append *messages* (list (format nil "~{~S ~}" messages)))) (when (> (length *messages*) (- (truncate (get-screen-height) (get-font-height)) 1)) - (pop *messages*))) - + (pop *messages*))) \ No newline at end of file --- /project/pal/cvsroot/pal/todo.txt 2007/10/29 20:04:20 1.19 +++ /project/pal/cvsroot/pal/todo.txt 2007/10/30 20:43:10 1.20 @@ -1,7 +1,26 @@ TODO: + +For v1.1 + +- Fix offsets in draw-image. + +- Polygon smooth hint? + - Add align, scale and angle options to DRAW-IMAGE*. +- Better clipping. + +- Structured color values. + + + +After v1.1 + +- Better drawing primitives, real lines, start/end args to draw-circle etc. + +- As always, optimise GL state handling. + - Implement image mirroring, tiles and animation. - Box/box/line/circle etc. overlap functions, faster v-dist. @@ -16,9 +35,11 @@ As separate projects on top of PAL: -- Native CL font resource builder +- GUI, work in progress. + +- Native CL font resource builder. -- TTF support +- TTF support. - Some sort of sprite library? --- /project/pal/cvsroot/pal/vector.lisp 2007/10/11 19:26:23 1.9 +++ /project/pal/cvsroot/pal/vector.lisp 2007/10/30 20:43:10 1.10 @@ -12,12 +12,12 @@ (declaim (inline component)) (defunct component (x) - (number x) + (number x) (coerce x 'component)) (declaim (inline v)) (defunct v (x y) - (component x component y) + (component x component y) (make-vec :x x :y y)) (declaim (inline vf)) @@ -29,74 +29,74 @@ (declaim (inline rad)) (defunct rad (degrees) - (component degrees) + (component degrees) (* (/ pi 180) degrees)) (declaim (inline deg)) (defunct deg (radians) - (component radians) + (component radians) (* (/ 180 pi) radians)) (declaim (inline angle-v)) (defunct angle-v (angle) - (component angle) + (component angle) (v (sin (rad angle)) (- (cos (rad angle))))) (declaim (inline v-angle)) (defunct v-angle (vec) - (vec vec) + (vec vec) (mod (deg (atan (vx vec) (if (zerop (vy vec)) least-negative-short-float - (- (vy vec))))) + (- (vy vec))) )) 360)) (defunct v-random (length) - (number length) + (number length) (v* (angle-v (random 360.0)) length)) (declaim (inline v-round)) (defunct v-round (v) - (vec v) + (vec v) (v (round (vx v)) (round (vy v)))) (declaim (inline v-floor)) (defunct v-floor (v) - (vec v) + (vec v) (v (floor (vx v)) (floor (vy v)))) (declaim (inline v=)) (defunct v= (a b) - (vec a vec b) + (vec a vec b) (and (= (vx a) (vx b)) (= (vy a) (vy b)))) (declaim (inline v+!)) (defunct v+! (a b) - (vec a vec b) + (vec a vec b) (setf (vx a) (+ (vx a) (vx b))) (setf (vy a) (+ (vy a) (vy b))) nil) (declaim (inline v+)) (defunct v+ (a b) - (vec a vec b) + (vec a vec b) (vf (+ (vx a) (vx b)) (+ (vy a) (vy b)))) (declaim (inline v-)) (defunct v- (a b) - (vec a vec b) + (vec a vec b) (vf (- (vx a) (vx b)) (- (vy a) (vy b)))) (declaim (inline v-!)) (defunct v-! (a b) - (vec a vec b) + (vec a vec b) (setf (vx a) (- (vx a) (vx b))) (setf (vy a) (- (vy a) (vy b))) nil) @@ -104,47 +104,47 @@ (declaim (inline v*!)) (defunct v*! (v m) - (component m) + (component m) (setf (vx v) (* (vx v) m)) (setf (vy v) (* (vy v) m)) nil) (declaim (inline v*)) (defunct v* (v m) - (vec v component m) + (vec v component m) (vf (* (vx v) m) (* (vy v) m))) (declaim (inline v/)) (defunct v/ (v d) - (vec v component d) + (vec v component d) (vf (/ (vx v) d) (/ (vy v) d))) (declaim (inline v/!)) (defunct v/! (v d) - (vec v component d) + (vec v component d) (setf (vx v) (/ (vx v) d)) (setf (vy v) (/ (vy v) d)) nil) (declaim (inline v-max)) (defunct v-max (a b) - (vec a vec b) + (vec a vec b) (if (< (v-magnitude a) (v-magnitude b)) b a)) (declaim (inline v-min)) (defunct v-min (a b) - (vec a vec b) + (vec a vec b) (if (< (v-magnitude a) (v-magnitude b)) a b)) (defunct v-rotate (v a) - (vec v component a) + (vec v component a) (let ((a (rad a))) (v (- (* (cos a) (vx v)) (* (sin a) (vy v))) @@ -153,20 +153,20 @@ (declaim (inline v-dot)) (defunct v-dot (a b) - (vec a vec b) + (vec a vec b) (+ (* (vx a) (vx b)) (* (vy a) (vy b)))) (declaim (inline v-magnitude)) (defunct v-magnitude (v) - (vec v) + (vec v) (the component (sqrt (the component (+ (expt (vx v) 2) (expt (vy v) 2)))))) (defunct v-normalize (v) - (vec v) + (vec v) (let ((m (v-magnitude v))) (if (/= m 0f0) (vf (/ (vx v) m) @@ -174,23 +174,23 @@ (vf 0f0 0f0)))) (defunct v-direction (from-vector to-vector) - (vec from-vector vec to-vector) + (vec from-vector vec to-vector) (v-normalize (v- to-vector from-vector))) (defunct v-distance (v1 v2) - (vec v1 vec v2) + (vec v1 vec v2) (v-magnitude (v- v1 v2))) (defunct v-truncate (v l) - (vec v component l) + (vec v component l) (v* (v-normalize v) l)) (defunct closest-point-to-line (a b p) - (vec a vec b vec p) + (vec a vec b vec p) (let* ((dir (v- b a)) (diff (v- p a)) (len (v-dot dir dir))) @@ -204,14 +204,14 @@ a))))) (defunct point-in-line-p (a b p) - (vec a vec b vec p) + (vec a vec b vec p) (let ((d (v-direction a b))) (if (< (abs (+ (v-dot d (v-direction a p)) (v-dot d (v-direction b p)))) .00001) t nil))) (defunct lines-intersection (la1 la2 lb1 lb2) - (vec la1 vec la2 vec lb1 vec lb2) + (vec la1 vec la2 vec lb1 vec lb2) (let ((x1 (vx la1)) (y1 (vy la1)) (x2 (vx la2)) @@ -237,7 +237,7 @@ nil)))))) (defunct circle-line-intersection (a b co r) - (vec a vec b vec co component r) + (vec a vec b vec co component r) (let ((cp (closest-point-to-line a b co))) (if cp (if (<= (v-distance co cp) r) @@ -246,14 +246,14 @@ nil))) (defunct distance-from-line (a b p) - (vec a vec b vec p) + (vec a vec b vec p) (let ((cp (closest-point-to-line a b p))) (if cp (v-distance cp p) nil))) (defunct point-inside-rectangle-p (topleft width height point) - (vec topleft vec point component width component height) + (vec topleft vec point component width component height) (let* ((x1 (vx topleft)) (y1 (vy topleft)) (x2 (+ x1 width)) @@ -266,10 +266,10 @@ (declaim (inline point-inside-circle-p)) (defunct point-inside-circle-p (co r p) - (vec co vec p component r) + (vec co vec p component r) (<= (v-distance co p) r)) (declaim (inline circles-overlap-p)) (defunct circles-overlap-p (c1 r1 c2 r2) - (vec c1 vec c2 component r1 component r2) + (vec c1 vec c2 component r1 component r2) (<= (v-distance c1 c2) (+ r2 r1))) \ No newline at end of file --- /project/pal/cvsroot/pal/color.lisp 2007/10/30 20:43:11 NONE +++ /project/pal/cvsroot/pal/color.lisp 2007/10/30 20:43:11 1.1 (in-package :pal) (defstruct color (r 0 :type pal::u8) (g 0 :type pal::u8) (b 0 :type pal::u8) (a 0 :type pal::u8)) (declaim (inline color)) (defun color (r g b a) (make-color :r r :g g :b b :a a)) (defun random-color () (color (random 255) (random 255) (random 255) (random 255)))

1 0

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

30 Oct '07

Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv3131 Modified Files: gob.lisp gui.lisp package.lisp widgets.lisp Log Message: Added tooltips. --- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/29 21:09:20 1.12 +++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/30 00:20:41 1.13 @@ -60,6 +60,14 @@ (point-inside-rectangle-p (absolute-pos-of g) (width-of g) (height-of g) point)) +(defgeneric on-inspect (gob)) +(defmethod on-inspect ((g gob)) + nil) + +(defgeneric on-over (gob)) +(defmethod on-over ((gob gob)) + nil) + (defgeneric on-enter (gob)) (defmethod on-enter ((gob gob)) nil) --- /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/29 21:09:20 1.8 +++ /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/30 00:20:41 1.9 @@ -16,6 +16,8 @@ (otherwise (pal::funcall? ,key-up-fn key))))) (key-down (lambda (key) (case key + (:key-mouse-2 (when *pointed-gob* + (on-inspect *pointed-gob*))) (:key-escape (unless ,key-down-fn (return-from event-loop))) (:key-mouse-1 (cond @@ -36,15 +38,16 @@ (pal::do-event ,event key-up key-down ,mouse-motion-fn ,quit-fn) ,@redraw (let ((g (first (last (active-gobs-at-point (get-mouse-pos) *root*))))) - (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))))) + ((and g (not (eq g *pointed-gob*))) + (on-enter g))) + (when g + (on-over g)) + (when (and *pointed-gob* (not (eq *pointed-gob* g))) + (on-leave *pointed-gob*)) + (setf *pointed-gob* g)) (update-gui))))))) --- /project/pal/cvsroot/pal-gui/package.lisp 2007/10/29 21:09:20 1.3 +++ /project/pal/cvsroot/pal-gui/package.lisp 2007/10/30 00:20:41 1.4 @@ -4,9 +4,10 @@ #:present - #:window #:button #:list-widget #:text-widget #:choice-widget #:pin #:label #:h-gauge #:v-slider #:h-meter #:filler + #:window #:button #:list-widget #:text-widget #:choice-widget #:pin #:label #:h-gauge + #:v-slider #:h-meter #:filler #:tooltip #:sliding #:clipping #:highlighted #:constrained - #:on-select #:on-button-down #:on-button-up #:on-key-down #:on-enter #:on-leave #:on-repaint #:on-drag #:repaint + #:on-select #:on-button-down #:on-button-up #:on-key-down #:on-enter #:on-leave #:on-repaint #:on-drag #:on-over #:repaint #:box #:v-box #:h-box --- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/29 21:09:20 1.12 +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/30 00:20:41 1.13 @@ -5,6 +5,8 @@ (defparameter *widget-color* '(180 180 180 128)) (defparameter *text-color* '(0 0 0 255)) (defparameter *paper-color* '(255 255 200 255)) +(defparameter *tooltip-delay* 1) +(defparameter *widget-enter-time* nil) (defvar *gui-font* nil) @@ -50,8 +52,10 @@ (defclass widget (gob) - ((on-drag :accessor on-drag-of :initarg :on-drag :initform (lambda (widget pos d) (declare (ignore widget pos d)) nil)) + ((tooltip :accessor tooltip-of :initarg :tooltip :initform nil) + (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) (declare (ignore widget)) nil)) + (on-over :accessor on-over-of :initarg :on-over :initform (lambda (widget) (declare (ignore widget)) nil)) (on-repaint :accessor on-repaint-of :initarg :on-repaint :initform (lambda (widget) (declare (ignore widget)) nil)) (on-button-down :accessor on-button-down-of :initarg :on-button-down :initform (lambda (widget pos) (declare (ignore widget pos)) nil)) (on-button-up :accessor on-button-up-of :initarg :on-button-up :initform (lambda (widget pos) (declare (ignore widget pos)) nil)) @@ -60,6 +64,10 @@ (on-leave :accessor on-leave-of :initarg :on-leave :initform (lambda (widget) (declare (ignore widget)) nil))) (:default-initargs :width (get-m) :height (get-m))) + +(defmethod on-inspect ((g widget)) + (message g)) + (defmethod on-drag :around ((g widget) pos d) (unless (funcall (on-drag-of g) g pos d) (call-next-method))) @@ -72,6 +80,13 @@ (unless (funcall (on-repaint-of g) g) (call-next-method))) +(defmethod on-over :around ((g widget)) + (when (and *widget-enter-time* (tooltip-of g) (> (- (get-universal-time) *widget-enter-time*) *tooltip-delay*)) + (setf *widget-enter-time* nil) + (make-instance 'tooltip :text (tooltip-of g) :host g)) + (unless (funcall (on-over-of g) g) + (call-next-method))) + (defmethod on-button-down :around ((g widget) pos) (unless (funcall (on-button-down-of g) g pos) (call-next-method))) @@ -85,6 +100,7 @@ (call-next-method))) (defmethod on-enter :around ((g widget)) + (setf *widget-enter-time* (get-universal-time)) (unless (funcall (on-enter-of g) g) (call-next-method))) @@ -115,7 +131,7 @@ (draw-line (v (- (get-text-bounds label) (vx text-offset)) 0) (v width 0) 0 0 0 160) (with-blend (:color *text-color*) - (draw-text label (v- text-offset (v 0 (truncate (get-m) 2))))))))) + (draw-text label (v- text-offset (v 0 (truncate (get-m) 2))) *gui-font*)))))) @@ -175,7 +191,7 @@ (draw-line (v 0 (1+ (get-m))) (v width (1+ (get-m))) 0 0 0 64) (draw-line (v 0 (+ (get-m) 2)) (v width (+ (get-m) 2)) 0 0 0 32) (with-blend (:color '(255 255 255 255)) - (draw-text label (get-text-offset))))) + (draw-text label (get-text-offset) *gui-font*)))) @@ -265,7 +281,7 @@ (draw-frame (v+ kpos (v (truncate sw 2) 0)) 3 (/ m 4) '(0 0 0 0) :style :sunken :fill nil) (draw-frame (v+ kpos (v (truncate sw 2) m)) 3 (- (/ m 4)) '(0 0 0 0) :style :sunken :fill nil) (with-blend (:color *text-color*) - (draw-text vt (v+ kpos (get-text-offset))))))) + (draw-text vt (v+ kpos (get-text-offset)) *gui-font*))))) @@ -324,9 +340,9 @@ (loop for x from 1 to (- k 3) by 2 do (draw-line (v x 1) (v x (1- height)) 148 148 148 255)) (with-blend (:color *widget-color*) - (draw-text (princ-to-string value) (v+ (v 1 1) (get-text-offset)))) + (draw-text (princ-to-string value) (v+ (v 1 1) (get-text-offset)) *gui-font*)) (with-blend (:color *text-color*) - (draw-text (princ-to-string value) (get-text-offset)))))) + (draw-text (princ-to-string value) (get-text-offset) *gui-font*))))) @@ -544,7 +560,7 @@ (let* ((offset (get-text-offset)) (point-x (+ (vx offset) (get-text-size (subseq text 0 point))))) (with-blend (:color *text-color*) - (draw-text text offset) + (draw-text text offset *gui-font*) (when (focusedp g) (draw-rectangle (v point-x (vy offset)) 2 (- height (* 2 (vy offset))) @@ -552,4 +568,25 @@ (defmethod on-key-down ((g text-widget) char) (setf (text-of g) (concatenate 'string (text-of g) (string char))) - (incf (point-of g))) \ No newline at end of file + (incf (point-of g))) + + + + +(defclass tooltip (gob) + ((host :accessor host-of :initarg :host) + (text :reader text-of :initarg :text :initform "")) + (:default-initargs :activep nil :width 100 :height (get-m) :pos (get-mouse-pos))) + +(defmethod initialize-instance :after ((g tooltip) &key text &allow-other-keys) + (setf (width-of g) (get-text-bounds text)) + (raise g)) + + +(defmethod repaint ((g tooltip)) + (unless (pointedp (host-of g)) + (setf (parent-of g) nil)) + (draw-rectangle (v 0 0) (width-of g) (height-of g) (first *paper-color*) (second *paper-color*) (third *paper-color*) (fourth *paper-color*)) + (draw-rectangle (v 0 0) (width-of g) (height-of g) 0 0 0 255 :fill nil) + (with-blend (:color *text-color*) + (draw-text (text-of g) (get-text-offset) *gui-font*))) \ No newline at end of file

1 0

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

30 Oct '07

Update of /project/pal/cvsroot/pal-gui/examples In directory clnet:/tmp/cvs-serv3131/examples Modified Files: test.lisp Log Message: Added tooltips. --- /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/29 21:09:20 1.11 +++ /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/30 00:20:40 1.12 @@ -1,6 +1,7 @@ ;; TODO: ;; -;; window sizing, dialogs, menus, tooltips, keyboard control, scrollwheel, fix pal's clipping, constrained mixin, scrolling mixin +;; window sizing, dialogs, menus, keyboard control, scrollwheel, fix pal's clipping +;; debugging utils, scrolling mixin ;; joystick, scroll box, paragraph, text box, simple editor, combo box, tree view, gridbox, property list ;; File open/save, choose directory, yes/no dialogs @@ -14,7 +15,7 @@ (let* ((plane (load-image "lego-plane.png")) (tile (load-image "ground.png")) - (window (make-instance 'window :pos (v 200 200) :width 300 :height 240)) + (window (make-instance 'window :pos (v 480 200) :width 300 :height 240)) (window-2 (make-instance 'window :width 200 :height 300)) (box (make-instance 'h-box :parent window)) @@ -39,6 +40,7 @@ :on-select (lambda (g) (message (selected-of g))))) (button (make-instance 'button :value :circle + :tooltip "Push me to change the listview" :parent window-2 :on-select (lambda (g) (setf (items-of list) (remove-if-not 'image-p pal-ffi::*resources*))))) (choice (make-instance 'choice-widget :label "Foo" :parent window-2 :items '("First" "Second" "and Third")))

1 0

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

29 Oct '07

Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv5882 Modified Files: gob.lisp gui.lisp package.lisp widgets.lisp Log Message: Finished the CHOICE-WIDGET. --- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/29 20:06:01 1.11 +++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/29 21:09:20 1.12 @@ -283,6 +283,28 @@ +(defclass constrained () + ()) + +(defmethod (setf pos-of) :around (pos (g constrained)) + (call-next-method) + (constrain g)) + +(defmethod (setf width-of) :around (width (g constrained)) + (call-next-method) + (constrain g)) + +(defmethod (setf height-of) :around (height (g constrained)) + (call-next-method) + (constrain g)) + +(defmethod constrain ((g constrained)) + (with-accessors ((pos pos-of) (width width-of) (height height-of) (parent parent-of)) g + (setf (slot-value g 'pos) (v (clamp 0 (vx pos) (- (width-of parent) width)) + (clamp 0 (vy pos) (- (height-of parent) height)))))) + + + (defclass root (gob) () --- /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/29 20:06:01 1.7 +++ /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/29 21:09:20 1.8 @@ -83,4 +83,8 @@ (reset-blend) (pal-ffi:gl-load-identity) (repaint *root*) - (update-screen)) \ No newline at end of file + (update-screen)) + +(defun set-gui-font (font) + (assert (font-p font)) + (setf *gui-font* font)) \ No newline at end of file --- /project/pal/cvsroot/pal-gui/package.lisp 2007/10/29 20:06:01 1.2 +++ /project/pal/cvsroot/pal-gui/package.lisp 2007/10/29 21:09:20 1.3 @@ -1,11 +1,11 @@ (defpackage #:pal-gui (:use :common-lisp :pal) - (:export #:with-gui #:init-gui #:update-gui #:gui-loop + (:export #:with-gui #:init-gui #:update-gui #:gui-loop #:set-gui-font #:present - #:window #:button #:list-widget #:text-widget #:choice-widget #:pin #:label #:h-gauge #:v-slider #:h-meter - #:sliding #:clipping #:highlighted + #:window #:button #:list-widget #:text-widget #:choice-widget #:pin #:label #:h-gauge #:v-slider #:h-meter #:filler + #:sliding #:clipping #:highlighted #:constrained #:on-select #:on-button-down #:on-button-up #:on-key-down #:on-enter #:on-leave #:on-repaint #:on-drag #:repaint #:box #:v-box #:h-box --- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/29 20:06:01 1.11 +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/29 21:09:20 1.12 @@ -196,7 +196,7 @@ -(defclass pin (label sliding highlighted) +(defclass pin (label sliding highlighted constrained) ((r :accessor r-of :initarg :r :initform 255) (g :accessor g-of :initarg :g :initform 255) (b :accessor b-of :initarg :b :initform 255) @@ -444,31 +444,87 @@ (setf (items-of (list-view-of g)) items (scroll-of (list-view-of g)) 0 (selected-of (list-view-of g)) nil - (max-value-of (slider-of g)) (* (item-height-of (list-view-of g)) (length items)))) + (max-value-of (slider-of g)) (* (item-height-of (list-view-of g)) (length items)) + (value-of (slider-of g)) 0)) + + + + +(defclass radio-item (button) + ()) + +(defmethod repaint ((g radio-item)) + (with-accessors ((height height-of) (width width-of) (value value-of)) g + (let* ((m/2 (truncate (get-m) 2)) + (m/4 (truncate m/2 2)) + (ypos (truncate height 2))) + (draw-circle (v m/4 ypos) + (1+ (truncate m/2 2)) + 0 0 0 255 + :smoothp t) + (draw-circle (v m/4 ypos) + (truncate m/2 2) + (first *paper-color*) (second *paper-color*) (third *paper-color*) (fourth *paper-color*) + :smoothp t) + (when (state-of g) + (draw-circle (v m/4 ypos) (- (truncate m/2 2) 2) + 0 0 0 255 + :smoothp t)) + (with-transformation (:pos (v (truncate (get-m) 1.5) 0)) + (present value g (- width (get-m)) height))))) + + +(defclass choice-item (button) + ()) + +(defmethod repaint ((g choice-item)) + (with-accessors ((height height-of) (width width-of) (value value-of)) g + (let* ((m/2 (truncate (get-m) 2)) + (ypos (- (truncate height 2) (truncate m/2 2)))) + (draw-frame (v 0 ypos) + m/2 m/2 + *paper-color* + :style :sunken) + (when (state-of g) + (draw-frame (v 1 (- ypos -1)) + (- m/2 1) (- m/2 1) + *widget-color* + :style :raised)) + (with-transformation (:pos (v (truncate (get-m) 1.5) 0)) + (present value g (- width (get-m)) height))))) + (defclass choice-widget (v-box) - ((items :accessor items-of :initarg :items :initform '()))) + ((multip :accessor multip :initarg :multip :initform nil) + (items :accessor items-of :initarg :items :initform '()))) (defmethod initialize-instance :after ((g choice-widget) &key items multip (item-height (get-m)) &allow-other-keys) - (setf (items-of g) - (mapcar (lambda (i) - (make-instance 'button - :parent g - :height item-height - :value i - :stickyp t - :on-select (lambda (c) - (declare (ignore c)) - (unless multip - (dolist (c (childs-of g)) - (setf (state-of c) nil))) - nil))) - items))) + (setf (items-of g) (mapcar (lambda (i) + (make-instance (if multip 'choice-item 'radio-item) + :parent g + :height item-height + :value i + :stickyp t + :on-select (lambda (c) + (declare (ignore c)) + (unless multip + (dolist (c (childs-of g)) + (setf (state-of c) nil))) + (on-select g) + nil))) + items)) + (unless multip + (setf (selected-of g) (first items)))) (defmethod selected-of ((g choice-widget)) - (mapcar 'value-of (remove-if-not 'state-of (childs-of g)))) + (if (multip g) + (mapcar 'value-of (remove-if-not 'state-of (childs-of g))) + (first (mapcar 'value-of (remove-if-not 'state-of (childs-of g)))))) + +(defmethod (setf selected-of) (object (g choice-widget)) + (setf (state-of (find object (childs-of g) :key 'value-of)) t))

1 0

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

29 Oct '07

Update of /project/pal/cvsroot/pal-gui/examples In directory clnet:/tmp/cvs-serv5882/examples Modified Files: files.lisp packing.lisp test.lisp Log Message: Finished the CHOICE-WIDGET. --- /project/pal/cvsroot/pal-gui/examples/files.lisp 2007/10/29 20:06:01 1.1 +++ /project/pal/cvsroot/pal-gui/examples/files.lisp 2007/10/29 21:09:20 1.2 @@ -1,15 +1,14 @@ - (in-package :pal-gui) -(defclass file-list (v-box) +(defclass file-widget (v-box) ((list-widget :accessor list-widget-of) (text-widget :accessor text-widget-of) (select :accessor select-of)) (:default-initargs :gap 2)) -(defmethod initialize-instance :after ((g file-list) &key &allow-other-keys) +(defmethod initialize-instance :after ((g file-widget) &key &allow-other-keys) (setf (list-widget-of g) (make-instance 'list-widget :parent g :on-select (lambda (lg) (setf (text-of (text-widget-of g)) (selected-of lg))))) @@ -18,7 +17,7 @@ (setf (select-of g) (make-instance 'button :x-expand-p nil :width (get-m) :value :box :parent hbox))) (update-view g)) -(defmethod update-view ((g file-list)) +(defmethod update-view ((g file-widget)) (setf (items-of (list-widget-of g)) (mapcar (lambda (f) (if (pathname-name f) (pathname-name f) @@ -30,7 +29,7 @@ (with-gui () (let* ((window (make-instance 'window :pos (v 200 200) :width 300 :height 200)) - (hbox (make-instance 'file-list :parent window :label "Choose"))) + (hbox (make-instance 'file-widget :parent window :label "Choose"))) (gui-loop () (clear-screen 150 150 150))))) --- /project/pal/cvsroot/pal-gui/examples/packing.lisp 2007/10/29 20:06:01 1.1 +++ /project/pal/cvsroot/pal-gui/examples/packing.lisp 2007/10/29 21:09:20 1.2 @@ -1,6 +1,6 @@ - -(in-package :pal-gui) - +(defpackage :test + (:use :cl :pal :pal-gui)) +(in-package :test) (defun test () @@ -53,7 +53,7 @@ (vbox (make-instance 'v-box :label "foo" :parent hbox :width 30 :x-expand-p nil)) (c (make-instance 'button :value "Foo" :parent vbox))) - (loop repeat 10 do (make-instance 'pin :value "Foo" :b 0 :pos (v (random 800) (random 600)))) + (loop repeat 10 do (make-instance 'pin :value "Foo" :b 0 :pos (v (random 800) (random 600)))) (gui-loop () (clear-screen 50 50 255)))))) --- /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/29 20:06:01 1.10 +++ /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/29 21:09:20 1.11 @@ -1,8 +1,8 @@ ;; TODO: ;; -;; Exports, window sizing dialogs, menus, tooltips, keyboard control, scrollwheel, fix pal's clipping -;; radio box, check box, joystick, scroll box, paragraph, text box, simple editor, combo box, tree view, gridbox, property list -;; File open/save, directory, yes/no dialogs +;; window sizing, dialogs, menus, tooltips, keyboard control, scrollwheel, fix pal's clipping, constrained mixin, scrolling mixin +;; joystick, scroll box, paragraph, text box, simple editor, combo box, tree view, gridbox, property list +;; File open/save, choose directory, yes/no dialogs (defpackage :test (:use :cl :pal :pal-gui)) @@ -23,6 +23,7 @@ (bottom-box (make-instance 'v-box :parent window :label "Bar" :y-expand-p nil)) (meter (make-instance 'h-meter :parent right-box :max-value 100 :on-repaint (lambda (g) (setf (value-of g) (get-fps)) nil))) + (multichoice (make-instance 'choice-widget :multip t :parent right-box :items '(Foo Bar Baz))) (rg (make-instance 'h-gauge :parent left-box :min-value 0 :max-value 255 :value 0)) (gg (make-instance 'h-gauge :parent left-box @@ -40,7 +41,7 @@ (button (make-instance 'button :value :circle :parent window-2 :on-select (lambda (g) (setf (items-of list) (remove-if-not 'image-p pal-ffi::*resources*))))) - (choice (make-instance 'choice-widget :label "Foo" :parent window-2 :items '(Foo Bar Baz))) + (choice (make-instance 'choice-widget :label "Foo" :parent window-2 :items '("First" "Second" "and Third"))) (pin (make-instance 'pin :value "Plane" :pos (v 400 300) :a 128)) (text (make-instance 'text-widget :text "Text" :parent bottom-box)))

1 0