From tneste at common-lisp.net Thu Oct 11 19:26:23 2007 From: tneste at common-lisp.net (tneste) Date: Thu, 11 Oct 2007 15:26:23 -0400 (EDT) Subject: [pal-cvs] CVS pal Message-ID: <20071011192623.C3F0E1E0D5@common-lisp.net> Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv13992 Modified Files: ffi.lisp pal-macros.lisp pal.lisp vector.lisp Log Message: Added some comments and docstrings. --- /project/pal/cvsroot/pal/ffi.lisp 2007/09/07 07:55:16 1.20 +++ /project/pal/cvsroot/pal/ffi.lisp 2007/10/11 19:26:23 1.21 @@ -21,9 +21,10 @@ (:unix (:or "libGL.so"))) #+win32 (cffi:define-foreign-library shell32 - (:windows "shell32.dll")) + (:windows "shell32.dll")) ;; We use a function from shell32.dll to find the users application data directory. (defun load-foreign-libraries () + "Load all the foreing libs. Useful when dumping and restarting images with CLisp." (cffi:use-foreign-library sdl) (cffi:use-foreign-library sdl-mixer) (cffi:use-foreign-library sdl-image) @@ -38,6 +39,9 @@ (deftype u16 () '(unsigned-byte 16)) + +;; Basic SDL ffi definitions + (defconstant +init-audio+ #x00000010) (defconstant +init-video+ #x00000020) (defconstant +fullscreen+ #x80000000) @@ -168,6 +172,9 @@ (defconstant +resize-event+ 16) (defconstant +expose-event+ 17) + +;; Keycodes used by PAL. +;; In addition to these :KEY-MOUSE-n are used for mousekeys. (cffi:defcenum sdl-key (:key-unknown 0) (:key-first 0) @@ -424,16 +431,17 @@ ;; Resources -(defvar *resources* ()) + +(defvar *resources* () "List of currently loaded resources.") (defstruct image - (texture 0 :type u11) - (texture-width 0 :type u11) - (texture-height 0 :type u11) - (tx2 0 :type single-float) - (ty2 0 :type single-float) - (height 0 :type u11) - (width 0 :type u11)) + (texture 0 :type u11) ; "GL texture id for image." + (texture-width 0 :type u11) ; "Actual (rounded up to power of two) width of texture." + (texture-height 0 :type u11) ; "Actual (rounded up to power of two) height of texture." + (tx2 0 :type single-float) ; "tx2 = width / texture-width" + (ty2 0 :type single-float) ; "ty2 = height / texture-width" + (height 0 :type u11) ; "Height of textures visible part." + (width 0 :type u11)) ; "Width of textures visible part." (defstruct font (image nil :type (or boolean image)) @@ -454,8 +462,13 @@ -(defgeneric register-resource (resource)) -(defgeneric free-resource (resource)) +(defgeneric register-resource (resource) + (:documentation "Add RESOURCE to *RESOURCES*")) + +;; NOTE: Does not free the resource if it is held by some other resource. +(defgeneric free-resource (resource) + (:documentation "Free the RESOURCE and all system resources used by it. Also resets the TAGs related to the resource.")) + (defgeneric holdsp (holder resource)) @@ -496,7 +509,7 @@ (free-resource image))) (defmethod holdsp ((font font) (image image)) - (eq (font-image font) image)) + (eq (font-image font) image)) ;; Font resources need to hold the image they are using for the glyphs. @@ -515,12 +528,13 @@ (defun free-all-resources () + "Free all loaded resources and reset the TAGS" (loop while *resources* do (free-resource (first *resources*))) (assert (null *resources*))) -;; Main SDL +;; Main SDL functions (cffi:defcfun ("SDL_Init" init) :int (flags :uint)) @@ -903,6 +917,7 @@ (value :int)) +;; Used to get the application data folder. #+win32 (cffi:defcfun "SHGetFolderPathA" :int (owner :pointer) (folder :int) (handle :pointer) (flags :int) (path :pointer)) #+win32 (defun get-application-folder () @@ -910,5 +925,9 @@ (shgetfolderpatha (cffi:null-pointer) #x001a (cffi:null-pointer) 0 path) (concatenate 'string (cffi:foreign-string-to-lisp path) "/"))) + +;; Used to allocate zeroed memory. (cffi:defcfun "calloc" :pointer (nelem :uint) (elsize :uint)) + +;; Can we just use cffi:foreign-free? Just in case... (cffi:defcfun "free" :void (ptr :pointer)) \ No newline at end of file --- /project/pal/cvsroot/pal/pal-macros.lisp 2007/08/15 14:36:21 1.13 +++ /project/pal/cvsroot/pal/pal-macros.lisp 2007/10/11 19:26:23 1.14 @@ -4,7 +4,13 @@ (in-package :pal) -(defvar *tags* (make-hash-table :test 'eq)) +;; TAGs are lazily evaluated thunks that load some resource (image, font etc.) when called with (TAG tag-name). +;; Their values are cached and automatically cleaned when resource is freed. +;; NOTE: Once defined the TAG definitions persist thru the whole Lisp session. Only the result values get initialized. + + +(defvar *tags* (make-hash-table :test 'eq) + "*TAGS* is a hashtable of TAG-NAME -> (FUNCTION . RESOURCE) we use to hold TAGS.") (defmacro define-tags (&body tags) `(progn @@ -18,6 +24,8 @@ (setf (gethash tag *tags*) (cons fn nil))) + +;; Clean all the values from tag table. Internal use only! (defun reset-tags (&key resource) (maphash (if resource (lambda (k v) @@ -29,6 +37,8 @@ (setf (cdr v) nil))) *tags*)) + + (defun tag (name) (declare (type symbol name)) (let ((resource (gethash name *tags*))) @@ -49,6 +59,7 @@ (float `(coerce ,value 'float))))) +;; Messy. Like DEFUN but automatically coerce some types (defined up there -^ ) and declare their types. (defmacro defunct (name lambda-list declarations &body body) (let* ((decls (loop for (a b) on declarations by #'cddr collecting `(type ,a ,b))) @@ -66,9 +77,10 @@ (declare , at decls) , at body)))) -;; (declaim (ftype (function (double-float double-float) double-float) sss)) + (defmacro with-resource ((resource init-form) &body body) + "Bind the result of INIT-FORM to RESOURCE, evaluate the BODY and free the RESOURCE." `(let ((,resource ,init-form)) (prog1 (progn , at body) @@ -76,6 +88,7 @@ (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)) (pal-ffi:gl-load-identity) @@ -83,6 +96,7 @@ (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." `(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+)) @@ -96,6 +110,7 @@ (pal-ffi:gl-pop-attrib)))) (defmacro with-clipping ((x y width height) &body body) + "Evaluate BODY with clipping. Only the window area defined by X, Y, WIDTH and HEIGHT is affected by drawing primitives." `(progn (push-clip ,x ,y ,width ,height) (prog1 (progn @@ -103,6 +118,7 @@ (pop-clip)))) (defmacro with-transformation ((&key pos angle scale) &body body) + "Evaluate BODY with translation POS, rotation ANGLE and scaling SCALE. Transformations are applied in that order." `(progn (close-quads) (pal-ffi:gl-push-matrix) @@ -120,6 +136,7 @@ (pal-ffi:gl-pop-matrix)))) (defmacro with-gl (mode &body body) + "Wrap BODY between (gl-begin MODE) and (gl-end). When used with +GL-QUADS+ gl-begin/end are possibly completely left out." (if (eq mode 'pal-ffi:+gl-quads+) `(progn (open-quads) @@ -144,6 +161,7 @@ (pal-ffi:gl-pop-attrib))) (defmacro randomly (p &body body) + "There is a 1/P chance of the BODY to be evaluated." `(when (= (random ,p) 0) , at body)) @@ -180,6 +198,7 @@ nil (apply fn args))) +;; Messy... (defmacro do-event (event key-up-fn key-down-fn mouse-motion-fn quit-fn) `(loop while (pal-ffi:poll-event ,event) do @@ -210,7 +229,7 @@ ((= type pal-ffi:+mouse-button-up-event+) (let* ((button (cffi:foreign-slot-value ,event 'pal-ffi:mouse-button-event 'pal-ffi:button)) - (keysym (read-from-string (format nil ":key-mouse-~a" button)))) + (keysym (read-from-string (format nil ":key-mouse-~a" button)))) ;; Mousekeys are handled as keycodes :KEY-MOUSE-n (setf (gethash keysym *pressed-keys*) nil) (funcall? ,key-up-fn keysym))) @@ -240,6 +259,7 @@ (defmacro with-pal (args &body body) + "Open PAL and evaluate BODY. After BODY returns call CLOSE-PAL." `(progn (apply 'open-pal (list , at args)) (unwind-protect --- /project/pal/cvsroot/pal/pal.lisp 2007/09/07 07:55:16 1.30 +++ /project/pal/cvsroot/pal/pal.lisp 2007/10/11 19:26:23 1.31 @@ -12,9 +12,10 @@ (defparameter *pal-directory* (make-pathname :directory (pathname-directory *load-pathname*) :host (pathname-host *load-pathname*) :device (pathname-device *load-pathname*))) -(defvar *messages* nil) -(defvar *pal-running* nil) -(defvar *title* "") + +(defvar *messages* nil "List of messages draw on screen with MESSAGE.") +(defvar *pal-running* nil "T if PAL is already running.") +(defvar *title* "" "PAL windows title. Also used for creating the path to applications data directory.") (defvar *ticks* 0) (defvar *clip-stack* nil) (defvar *fps* 0) @@ -29,9 +30,9 @@ (defvar *cursor-offset* (v 0 0)) (defvar *mouse-x* 0) (defvar *mouse-y* 0) -(defvar *current-image* nil) -(defvar *max-texture-size* 0) -(defvar *quads-open* nil) +(defvar *current-image* nil "Currently set OpenGL texture.") +(defvar *max-texture-size* 0 "Maximum size of OpenGL texture supported by system.") +(defvar *quads-open* nil "T if (GL-BEGIN +GL-QUADS+) is already in effect.") (declaim (type list *messages*) @@ -136,6 +137,7 @@ (setf *pal-running* nil))) (defun get-application-folder () + "Return the application data directory to be used for saving user specific data. PAL windows title is used when forming the directory pathname. Actual behaviour depends on the operating system." (assert (> (length *title* ) 0)) #-win32 (ensure-directories-exist (merge-pathnames (make-pathname :directory (list :relative (concatenate 'string "." *title*))) (user-homedir-pathname))) @@ -143,15 +145,18 @@ (parse-namestring (pal-ffi:get-application-folder))))) (defun get-application-file (file) + "Return a full path to a FILE in the application data directory. PAL windows title is used when forming the directory pathname. Actual behaviour depends on the operating system." (merge-pathnames file (get-application-folder))) (defun add-path (path) + "Add PATH to the list of paths that are searched when loading resources." (if #-:clisp (probe-file path) #+:clisp (ext:probe-directory path) (pushnew path *data-paths*) (format *debug-io* "Illegal data path: ~a" path))) (defun data-path (file) + "Find a FILE from the search paths." (let ((result nil)) (dolist (i *data-paths* result) (when (probe-file (merge-pathnames file i)) @@ -161,6 +166,7 @@ (error "Data file not found: ~a" file)))) (defun get-gl-info () + "Return some information about systems OpenGL implementation." (list :vendor (pal-ffi:gl-get-string pal-ffi:+gl-vendor+) :rendered (pal-ffi:gl-get-string pal-ffi:+gl-renderer+) :version (pal-ffi:gl-get-string pal-ffi:+gl-version+) @@ -174,6 +180,7 @@ (declaim (inline key-pressed-p)) (defunct key-pressed-p (keysym) (symbol keysym) + "Return T if key KEYSYM is currently pressed down." (gethash keysym *pressed-keys*)) (defunct keysym-char (keysym) @@ -198,6 +205,7 @@ (do-event event key-up-fn key-down-fn mouse-motion-fn quit-fn)))) (defun wait-keypress () + "Wait until some key is pressed down and released." (let ((key nil)) (event-loop (:key-down-fn (lambda (k) (setf key k) @@ -220,6 +228,7 @@ (draw-text m (v 0 (incf y fh)))))) (defun update-screen () + "Updates PAL window." (setf *new-fps* (max 1 (the fixnum (- (pal-ffi:get-tick) *ticks*)))) (setf *fps* (truncate (+ *fps* *new-fps*) 2)) (if (> *delay* 0) @@ -270,6 +279,7 @@ *mouse-y* y)) (defun set-cursor (image &optional offset) + "Sets the state of mouse cursor. When IMAGE is NIL hide the cursor, when T show it. If IMAGE is an image resource use that as mouse cursor. OFFSET is a vector that sets the offset of custom cursor image." (assert (and (or (null offset) (vec-p offset)) (or (image-p image) (typep image 'boolean)))) (when offset --- /project/pal/cvsroot/pal/vector.lisp 2007/08/15 14:36:21 1.8 +++ /project/pal/cvsroot/pal/vector.lisp 2007/10/11 19:26:23 1.9 @@ -44,7 +44,7 @@ (component angle) (v (sin (rad angle)) (- (cos (rad angle))))) -(declaim (inline vec-angle)) +(declaim (inline v-angle)) (defunct v-angle (vec) (vec vec) (mod (deg (atan (vx vec) From tneste at common-lisp.net Mon Oct 15 19:04:55 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 15 Oct 2007 15:04:55 -0400 (EDT) Subject: [pal-cvs] CVS pal Message-ID: <20071015190455.C34623203F@common-lisp.net> Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv25911 Modified Files: default-font.fnt default-font.png pal.lisp Log Message: --- /project/pal/cvsroot/pal/default-font.fnt 2007/06/28 20:14:05 1.1 +++ /project/pal/cvsroot/pal/default-font.fnt 2007/10/15 19:04:55 1.2 @@ -2,98 +2,98 @@ Bitmap=default-font.png -Char=" ",1,1,3,13,-1,2 -Char="!",5,1,4,13,1,0 -Char=""",10,1,5,13,0,1 -Char="#",16,1,10,13,0,-1 -Char="$",27,1,9,13,-1,0 -Char="%",37,1,12,13,0,-1 -Char="&",50,1,10,13,0,0 -Char="'",61,1,3,13,0,0 -Char="(",65,1,5,13,0,0 -Char=")",71,1,5,13,0,0 -Char="*",77,1,7,13,-1,0 -Char="+",85,1,9,13,0,0 -Char=",",95,1,5,13,-1,0 -Char="-",101,1,5,13,0,0 -Char=".",107,1,4,13,0,0 -Char="/",112,1,6,13,-1,-1 -Char="0",1,15,8,13,0,0 -Char="1",10,15,8,13,0,0 -Char="2",19,15,8,13,0,0 -Char="3",28,15,8,13,0,0 -Char="4",37,15,9,13,0,-1 -Char="5",47,15,8,13,0,0 -Char="6",56,15,8,13,0,0 -Char="7",65,15,8,13,0,0 -Char="8",74,15,8,13,0,0 -Char="9",83,15,8,13,0,0 -Char=":",92,15,4,13,0,0 -Char=";",97,15,5,13,-1,0 -Char="<",103,15,9,13,0,0 -Char="=",113,15,9,13,0,0 -Char=">",1,29,9,13,0,0 -Char="?",11,29,7,13,0,-1 -Char="@",19,29,12,13,0,-1 -Char="A",32,29,10,13,-1,-1 -Char="B",43,29,9,13,0,0 -Char="C",53,29,9,13,0,0 -Char="D",63,29,9,13,0,0 -Char="E",73,29,8,13,0,0 -Char="F",82,29,8,13,0,0 -Char="G",91,29,9,13,0,0 -Char="H",101,29,9,13,0,0 -Char="I",111,29,4,13,0,0 -Char="J",116,29,6,13,-2,0 -Char="K",1,43,10,13,0,-1 -Char="L",12,43,8,13,0,-1 -Char="M",21,43,11,13,0,0 -Char="N",33,43,9,13,0,0 -Char="O",43,43,10,13,0,0 -Char="P",54,43,9,13,0,-1 -Char="Q",64,43,10,13,0,0 -Char="R",75,43,9,13,0,-1 -Char="S",85,43,8,13,0,0 -Char="T",94,43,10,13,-1,-1 -Char="U",105,43,9,13,0,0 -Char="V",115,43,10,13,-1,-1 -Char="W",1,57,13,13,0,0 -Char="X",15,57,10,13,-1,-1 -Char="Y",26,57,10,13,-1,-1 -Char="Z",37,57,9,13,0,-1 -Char="[",47,57,6,13,0,-1 -Char="\",54,57,6,13,-1,-1 -Char="]",61,57,6,13,-1,0 -Char="^",68,57,9,13,0,0 -Char="_",78,57,8,13,-1,-1 -Char="`",87,57,5,13,0,1 -Char="a",93,57,8,13,0,0 -Char="b",102,57,8,13,0,0 -Char="c",111,57,7,13,0,0 -Char="d",1,71,8,13,0,0 -Char="e",10,71,8,13,0,0 -Char="f",19,71,7,13,-1,-1 -Char="g",27,71,8,13,0,0 -Char="h",36,71,8,13,0,0 -Char="i",45,71,4,13,0,0 -Char="j",50,71,5,13,-1,0 -Char="k",56,71,9,13,0,-2 -Char="l",66,71,4,13,0,0 -Char="m",71,71,12,13,0,-1 -Char="n",84,71,8,13,0,0 -Char="o",93,71,8,13,0,0 -Char="p",102,71,8,13,0,0 -Char="q",111,71,8,13,0,0 -Char="r",120,71,6,13,0,-1 -Char="s",1,85,7,13,0,0 -Char="t",9,85,7,13,-1,-1 -Char="u",17,85,8,13,0,0 -Char="v",26,85,9,13,-1,-1 -Char="w",36,85,11,13,0,0 -Char="x",48,85,9,13,-1,-1 -Char="y",58,85,9,13,-1,-1 -Char="z",68,85,7,13,0,0 -Char="{",76,85,8,13,0,0 -Char="|",85,85,3,13,0,1 -Char="}",89,85,8,13,0,0 -Char="~",98,85,9,13,0,0 +Char=" ",1,1,3,15,-1,1 +Char="!",5,1,3,15,0,0 +Char=""",9,1,5,15,-1,0 +Char="#",15,1,9,15,-1,-1 +Char="$",25,1,7,15,0,0 +Char="%",33,1,11,15,0,0 +Char="&",45,1,9,15,0,-1 +Char="'",55,1,3,15,0,-1 +Char="(",59,1,5,15,0,-1 +Char=")",65,1,5,15,-1,0 +Char="*",71,1,7,15,-1,-1 +Char="+",79,1,7,15,0,0 +Char=",",87,1,3,15,0,0 +Char="-",91,1,5,15,-1,0 +Char=".",97,1,3,15,0,0 +Char="/",101,1,5,15,-1,-1 +Char="0",107,1,7,15,0,0 +Char="1",115,1,5,15,0,2 +Char="2",1,17,7,15,0,0 +Char="3",9,17,7,15,0,0 +Char="4",17,17,7,15,0,0 +Char="5",25,17,7,15,0,0 +Char="6",33,17,7,15,0,0 +Char="7",41,17,7,15,0,0 +Char="8",49,17,7,15,0,0 +Char="9",57,17,7,15,0,0 +Char=":",65,17,3,15,0,0 +Char=";",69,17,3,15,0,0 +Char="<",73,17,7,15,0,0 +Char="=",81,17,8,15,-1,0 +Char=">",90,17,7,15,0,0 +Char="?",98,17,7,15,0,0 +Char="@",106,17,13,15,0,-1 +Char="A",1,33,9,15,-1,-1 +Char="B",11,33,8,15,0,0 +Char="C",20,33,9,15,0,0 +Char="D",30,33,9,15,0,0 +Char="E",40,33,8,15,0,0 +Char="F",49,33,7,15,0,0 +Char="G",57,33,9,15,0,0 +Char="H",67,33,9,15,0,0 +Char="I",77,33,3,15,0,0 +Char="J",81,33,7,15,-1,0 +Char="K",89,33,9,15,0,-1 +Char="L",99,33,8,15,0,-1 +Char="M",108,33,9,15,0,0 +Char="N",1,49,9,15,0,0 +Char="O",11,49,9,15,0,0 +Char="P",21,49,8,15,0,0 +Char="Q",30,49,9,15,0,0 +Char="R",40,49,9,15,0,0 +Char="S",50,49,8,15,0,0 +Char="T",59,49,9,15,-1,-1 +Char="U",69,49,9,15,0,0 +Char="V",79,49,9,15,-1,-1 +Char="W",89,49,13,15,-1,-1 +Char="X",103,49,9,15,-1,-1 +Char="Y",113,49,9,15,-1,-1 +Char="Z",1,65,9,15,-1,-1 +Char="[",11,65,4,15,0,-1 +Char="\",16,65,5,15,-1,-1 +Char="]",22,65,4,15,-1,0 +Char="^",27,65,7,15,-1,-1 +Char="_",35,65,9,15,-1,-1 +Char="`",45,65,4,15,0,0 +Char="a",50,65,7,15,0,0 +Char="b",58,65,7,15,0,0 +Char="c",66,65,6,15,0,0 +Char="d",73,65,7,15,0,0 +Char="e",81,65,7,15,0,0 +Char="f",89,65,6,15,-1,-2 +Char="g",96,65,7,15,0,0 +Char="h",104,65,7,15,0,0 +Char="i",112,65,3,15,0,0 +Char="j",116,65,5,15,-2,0 +Char="k",1,81,7,15,0,-1 +Char="l",9,81,3,15,0,0 +Char="m",13,81,11,15,0,0 +Char="n",25,81,7,15,0,0 +Char="o",33,81,7,15,0,0 +Char="p",41,81,7,15,0,0 +Char="q",49,81,7,15,0,0 +Char="r",57,81,5,15,0,-1 +Char="s",63,81,7,15,0,0 +Char="t",71,81,5,15,-1,-1 +Char="u",77,81,7,15,0,0 +Char="v",85,81,7,15,-1,-1 +Char="w",93,81,11,15,-1,-1 +Char="x",105,81,7,15,-1,-1 +Char="y",113,81,7,15,-1,-1 +Char="z",1,97,7,15,-1,-1 +Char="{",9,97,5,15,-1,0 +Char="|",15,97,3,15,0,0 +Char="}",19,97,5,15,0,-1 +Char="~",25,97,8,15,0,-1 Binary files /project/pal/cvsroot/pal/default-font.png 2007/06/28 20:14:05 1.1 and /project/pal/cvsroot/pal/default-font.png 2007/10/15 19:04:55 1.2 differ --- /project/pal/cvsroot/pal/pal.lisp 2007/10/11 19:26:23 1.31 +++ /project/pal/cvsroot/pal/pal.lisp 2007/10/15 19:04:55 1.32 @@ -728,7 +728,8 @@ (pal-ffi:gl-pop-attrib)) (defunct draw-circle (pos radius r g b a &key (fill t) absolutep (size 1f0) smoothp (segments 30)) - (vec pos single-float radius u8 r u8 g u8 b u8 a (or image symbol) fill boolean absolutep single-float size boolean smoothp fixnum segments) + (vec pos single-float radius u8 r u8 g u8 b u8 a + (or image symbol) fill boolean absolutep single-float size boolean smoothp fixnum segments) (declare (type vec pos) (type fixnum segments)) (draw-polygon (loop for a from 0 to (* 2 pi) by (/ (* 2 pi) segments) collecting (v+ pos From tneste at common-lisp.net Mon Oct 15 19:04:55 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 15 Oct 2007 15:04:55 -0400 (EDT) Subject: [pal-cvs] CVS pal/examples Message-ID: <20071015190455.F3F6C7E007@common-lisp.net> Update of /project/pal/cvsroot/pal/examples In directory clnet:/tmp/cvs-serv25911/examples Removed Files: ground.png Log Message: From tneste at common-lisp.net Mon Oct 15 19:08:34 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 15 Oct 2007 15:08:34 -0400 (EDT) Subject: [pal-cvs] CVS pal/examples Message-ID: <20071015190834.5C2F74B027@common-lisp.net> Update of /project/pal/cvsroot/pal/examples In directory clnet:/tmp/cvs-serv26106 Added Files: ground.png Log Message: From tneste at common-lisp.net Mon Oct 15 19:12:58 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 15 Oct 2007 15:12:58 -0400 (EDT) Subject: [pal-cvs] CVS pal-gui Message-ID: <20071015191258.4072AA149@common-lisp.net> Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv26295 Log Message: Status: Vendor Tag: tcvs-vendor Release Tags: tcvs-release No conflicts created by this import From tneste at common-lisp.net Mon Oct 15 19:13:48 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 15 Oct 2007 15:13:48 -0400 (EDT) Subject: [pal-cvs] CVS pal-gui/examples Message-ID: <20071015191348.DAB3D1900B@common-lisp.net> Update of /project/pal/cvsroot/pal-gui/examples In directory clnet:/tmp/cvs-serv26339/examples Log Message: Directory /project/pal/cvsroot/pal-gui/examples added to the repository From tneste at common-lisp.net Mon Oct 15 19:14:36 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 15 Oct 2007 15:14:36 -0400 (EDT) Subject: [pal-cvs] CVS pal-gui/examples Message-ID: <20071015191436.37C172823E@common-lisp.net> Update of /project/pal/cvsroot/pal-gui/examples In directory clnet:/tmp/cvs-serv26366/examples Added Files: test.lisp Log Message: Project created. --- /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/15 19:14:36 NONE +++ /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/15 19:14:36 1.1 (in-package :pal-gui) (define-tags plane (load-image "lego-plane.png") tile (load-image "ground.png")) (defun test () (with-gui (:paths (merge-pathnames "examples/" pal::*pal-directory*)) (let* ((window (make-instance 'window :pos (v 200 200) :width 300 :height 200)) (slider (make-instance 'v-slider :pos (v 250 20) :height 150 :parent window :max-value 200 :page-size 100)) (meter (make-instance 'h-meter :pos (v 30 50) :width 150 :parent window :max-value 80 :display-fn (lambda (v) (format nil "FPS: ~a" v)))) (gauge (make-instance 'h-gauge :pos (v 30 20) :width 150 :parent window :min-value 0 :max-value 255 :value 0 :display-fn (lambda (v) (format nil "R: ~a" v)))) (button (make-instance 'button :pos (v 100 100) :value "FooBar!" :parent window))) (gui-loop () (setf (value-of button) (value-of slider)) (setf (value-of meter) (get-fps)) (draw-image* (tag 'tile) (v 0 0) (v 0 0) 800 600) (with-blend (:color (list (value-of gauge) 0 0 64)) (draw-image (tag 'plane) (v 320 220))) (draw-image (tag 'plane) (v 300 200)))))) ;; (test) From tneste at common-lisp.net Mon Oct 15 19:14:36 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 15 Oct 2007 15:14:36 -0400 (EDT) Subject: [pal-cvs] CVS pal-gui Message-ID: <20071015191436.6E8612B158@common-lisp.net> Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv26366 Added Files: gob.lisp gui.lisp package.lisp pal-gui.asd widgets.lisp Log Message: Project created. --- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/15 19:14:36 NONE +++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/15 19:14:36 1.1 (in-package :pal-gui) (defvar *root* nil) (defvar *gobs* nil) (defvar *drag-start-pos* nil) (defvar *relative-drag-start-pos* nil) (defvar *focused-gob* nil) (defvar *pointed-gob* nil) (defvar *armed-gob* nil) (defclass gob () ((pos :accessor pos-of :initarg :pos :initform (v 0 0)) (parent :reader parent-of :initform nil) (activep :accessor activep :initform t :initarg :activep) (width :accessor width-of :initarg :width :initform 0) (height :accessor height-of :initarg :height :initform 0))) (defmethod initialize-instance :after ((g gob) &key (parent *root*) &allow-other-keys) (setf (parent-of g) parent) (push g *gobs*)) (defmethod draw ((g gob)) (declare (ignore g)) nil) (defmethod absolute-pos-of ((g gob)) (if (parent-of g) (v+ (pos-of g) (absolute-pos-of (parent-of g))) (pos-of g))) (defmethod (setf absolute-pos-of) (pos (g gob)) (setf (pos-of g) (v+ (v- pos (absolute-pos-of g)) (pos-of g)))) (defmethod point-inside-p ((g gob) point) (point-inside-rectangle-p (absolute-pos-of g) (width-of g) (height-of g) point)) (defmethod on-enter ((gob gob)) nil) (defmethod on-leave ((gob gob)) nil) (defgeneric on-button-down (gob pos)) (defmethod on-button-down ((gob gob) pos) nil) (defgeneric on-button-up (gob pos)) (defmethod on-button-up ((gob gob) pos) nil) (defgeneric on-select (gob pos)) (defmethod on-select ((gob gob) pos) nil) (defgeneric on-drag (gob start-pos delta-pos)) (defmethod on-drag ((gob gob) start-pos delta) (declare (ignore start-pos delta)) nil) (defgeneric pointedp (gob)) (defmethod pointedp ((gob gob)) (eq *pointed-gob* gob)) (defgeneric armedp (gob)) (defmethod armedp ((gob gob)) (eq *armed-gob* gob)) (defclass containing () ((childs :reader childs-of :initform nil)) (:default-initargs :activep nil)) (defmethod draw :around ((g containing)) (call-next-method) (draw-childs g)) (defmethod draw-childs ((g containing)) (with-transformation (:pos (pos-of g)) (dolist (c (childs-of g)) (draw c)))) (defgeneric adopt (parent child)) (defmethod adopt ((parent containing) (child gob)) (setf (slot-value child 'parent) parent) (push child (slot-value parent 'childs))) (defgeneric abandon (child)) (defmethod abandon ((child gob)) (when (parent-of child) (setf (slot-value (parent-of child) 'childs) (remove child (slot-value (parent-of child) 'childs)) (parent-of child) nil))) (defmethod (setf parent-of) ((parent containing) (child gob)) (abandon child) (adopt parent child)) (defclass sliding () ((start-pos :accessor start-pos-of))) (defmethod on-button-down :around ((g sliding) pos) (declare (ignore pos)) (setf (start-pos-of g) (pos-of g)) (call-next-method)) (defmethod on-drag :around ((g sliding) start-pos delta) (declare (ignore start-pos)) (setf (pos-of g) (v- (start-pos-of g) delta)) (call-next-method)) (defclass root (gob containing) () (:default-initargs :width (get-screen-width) :height (get-screen-height) :pos (v 0 0) :parent nil)) (defmethod (setf parent-of) (parent (root root)) (declare (ignore parent)) nil)--- /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/15 19:14:36 NONE +++ /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/15 19:14:36 1.1 (in-package :pal-gui) (defmacro gui-loop ((&key key-up-fn key-down-fn mouse-motion-fn quit-fn) &body redraw) (let ((event (gensym))) `(block event-loop (cffi:with-foreign-object (,event :char 500) (let ((key-up (lambda (key) (case key (:key-mouse-1 (setf *armed-gob* nil) (cond (*pointed-gob* (when (eq *armed-gob* *pointed-gob*) (on-select *armed-gob* (v- (get-mouse-pos) (absolute-pos-of *armed-gob*)))) (on-button-up *pointed-gob* (v- (get-mouse-pos) (absolute-pos-of *pointed-gob*)))) (t (pal::funcall? ,key-up-fn key)))) (otherwise (pal::funcall? ,key-up-fn key))))) (key-down (lambda (key) (case key (:key-escape (unless ,key-down-fn (return-from event-loop))) (:key-mouse-1 (cond (*pointed-gob* (setf *drag-start-pos* (get-mouse-pos)) (setf *relative-drag-start-pos* (v- *drag-start-pos* (absolute-pos-of *pointed-gob*))) (setf *armed-gob* *pointed-gob*) (on-button-down *pointed-gob* (v- (get-mouse-pos) (absolute-pos-of *pointed-gob*)))) (t (pal::funcall? ,key-down-fn key)))) (otherwise (pal::funcall? ,key-down-fn key)))))) (loop (pal::do-event ,event key-up key-down ,mouse-motion-fn ,quit-fn) , at redraw (let ((g (gob-at-point (get-mouse-pos)))) (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))))) (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)))) (defun init-gui () (setf *gobs* nil *root* (make-instance 'root))) (defun update-gui () (draw *root*)) (defun gob-at-point (point) (find-if (lambda (g) (and (activep g) (point-inside-p g point))) *gobs*)) --- /project/pal/cvsroot/pal-gui/package.lisp 2007/10/15 19:14:36 NONE +++ /project/pal/cvsroot/pal-gui/package.lisp 2007/10/15 19:14:36 1.1 (defpackage #:pal-gui (:use :common-lisp :pal)) --- /project/pal/cvsroot/pal-gui/pal-gui.asd 2007/10/15 19:14:36 NONE +++ /project/pal/cvsroot/pal-gui/pal-gui.asd 2007/10/15 19:14:36 1.1 (in-package #:asdf) (defsystem pal-gui :description "Pixel Art Library GUI" :author "Tomi Neste" :license "MIT" :components ((:file "gob" :depends-on ("package")) (:file "widgets" :depends-on ("gob")) (:file "gui" :depends-on ("gob" "widgets")) (:file "package")) :depends-on ("pal")) --- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/15 19:14:36 NONE +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/15 19:14:36 1.1 (in-package :pal-gui) (defparameter *window-color* '(160 160 160 160)) (defparameter *widget-color* '(180 180 180 255)) (defparameter *text-color* '(0 0 0 255)) (defun get-text-bounds (string &optional font) (let ((fh (get-font-height font))) (values (max (truncate (* 1.5 fh)) (+ (get-text-size string) fh)) (truncate (* fh 1.5))))) (defun get-text-offset (&optional font) (let ((fh (get-font-height font))) (v (truncate fh 2) (truncate fh 4)))) (defun get-m (&optional font) (truncate (* (get-font-height font) 1.5))) (defun draw-frame (pos width height color &key style (border 1)) (let ((r (first color)) (g (second color)) (b (third color)) (a (fourth color))) (draw-rectangle (v- pos (v border border)) (+ width (* 2 border) ) (+ height (* 2 border)) 0 0 0 a) (draw-rectangle pos width height r g b a) (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)) (: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))))) (defclass window (gob containing sliding) ((color :accessor color-of :initform *window-color* :initarg :color)) (:default-initargs :activep t)) (defmethod draw ((g window)) (draw-rectangle (v+ (v 6 6) (pos-of g)) (width-of g) (height-of g) 0 0 0 64) (draw-frame (pos-of g) (width-of g) (height-of g) (color-of g) :style :raised)) (defclass button (gob) ((color :accessor color-of :initform *widget-color* :initarg :color) (display-fn :accessor display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v))) (value :accessor value-of :initform "" :initarg :value))) (defmethod initialize-instance :after ((g button) &key width &allow-other-keys) (multiple-value-bind (w h) (get-text-bounds (value-of g)) (unless width (setf (width-of g) w)) (setf (height-of g) h))) (defmethod draw ((g button)) (let ((color (color-of g)) (value (funcall (display-fn-of g) (value-of g))) (fpos (v+ (pos-of g) (get-text-offset)))) (cond ((armedp g) (draw-frame (pos-of g) (width-of g) (height-of g) color :style :sunken :border 2) (with-blend (:color *text-color*) (draw-text value (v+ fpos (v 1 1))) )) ((pointedp g) (draw-frame (pos-of g) (width-of g) (height-of g) color :border 2 :style :raised) (with-blend (:color *text-color*) (draw-text value fpos) )) (t (draw-frame (pos-of g) (width-of g) (height-of g) color :style :raised) (with-blend (:color *text-color*) (draw-text value fpos)))))) (defclass h-gauge (gob) ((value :reader value-of :initarg :value :initform 0) (min-value :accessor min-value-of :initarg :min-value :initform 0) (max-value :accessor max-value-of :initarg :max-value :initform 100) (display-fn :accessor display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) (:default-initargs :height (get-m))) (defmethod (setf value-of) (value (g h-gauge)) (setf (slot-value g 'value) (clamp (min-value-of g) value (max-value-of g)))) (defmethod on-drag ((g h-gauge) start-pos delta) (let ((x (vx (v- start-pos delta)))) (setf (value-of g) (+ (truncate x (/ (width-of g) (abs (- (min-value-of g) (max-value-of g))))) (min-value-of g))))) (defmethod draw ((g h-gauge)) (let* ((vt (funcall (display-fn-of g) (value-of g))) (sw (get-text-bounds vt)) (m (get-m)) (k (truncate (* (/ (width-of g) (abs (- (min-value-of g) (max-value-of g)))) (- (value-of g) (min-value-of g))))) (kpos (v+ (pos-of g) (v (- k (truncate sw 2)) 0)))) (draw-frame (v+ (pos-of g) (v 0 (truncate m 3))) (width-of g) (truncate (height-of g) 2) *window-color* :style :sunken) (draw-frame kpos sw m *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1)) (draw-line (v+ kpos (v (truncate sw 2) 0)) (v+ kpos (v (truncate sw 2) (/ m 8))) 255 255 255 128) (draw-line (v+ kpos (v (truncate sw 2) (- m (/ m 8)))) (v+ kpos (v (truncate sw 2) m)) 0 0 0 128 :size 2) (with-blend (:color *text-color*) (draw-text vt (v+ kpos (get-text-offset)))))) (defclass v-slider (gob) ((value :reader value-of :initarg :value :initform 0) (page-size :accessor page-size-of :initarg :page-size :initform 1) (min-value :accessor min-value-of :initarg :min-value :initform 0) (max-value :accessor max-value-of :initarg :max-value :initform 100)) (:default-initargs :width (truncate (get-m) 2))) (defmethod (setf value-of) (value (g v-slider)) (setf (slot-value g 'value) (clamp (min-value-of g) value (- (max-value-of g) (page-size-of g))))) (defmethod on-drag ((g v-slider) start-pos delta) (let ((y (vy (v- start-pos delta)))) (setf (value-of g) (+ (truncate y (/ (height-of g) (abs (- (min-value-of g) (max-value-of g))))) (min-value-of g))))) (defmethod draw ((g v-slider)) (let* ((units (abs (- (min-value-of g) (max-value-of g)))) (usize (/ (height-of g) units)) (k (truncate (* usize (- (value-of g) (min-value-of g))))) (kpos (v+ (pos-of g) (v 0 k)))) (draw-frame (pos-of g) (width-of g) (height-of g) *window-color* :style :sunken) (draw-frame kpos (width-of g) (* (- units (page-size-of g)) usize) *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1)))) (defclass h-meter (gob) ((value :reader value-of :initarg :value :initform 0) (min-value :accessor min-value-of :initarg :min-value :initform 0) (max-value :accessor max-value-of :initarg :max-value :initform 100) (display-fn :accessor display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) (:default-initargs :activep nil :height (get-m))) (defmethod (setf value-of) (value (g h-meter)) (setf (slot-value g 'value) (clamp (min-value-of g) value (max-value-of g)))) (defmethod draw ((g h-meter)) (let* ((m (get-m)) (k (truncate (* (/ (width-of g) (abs (- (min-value-of g) (max-value-of g)))) (- (value-of g) (min-value-of g))))) ) (draw-frame (pos-of g) (width-of g) (height-of g) *window-color* :style :sunken) (loop for x from 0 to k by 2 do (draw-line (v+ (pos-of g) (v x 1)) (v+ (pos-of g) (v x (1- m))) 148 148 148 255)) (with-blend (:color *text-color*) [14 lines skipped] From tneste at common-lisp.net Mon Oct 15 21:48:00 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 15 Oct 2007 17:48:00 -0400 (EDT) Subject: [pal-cvs] CVS pal Message-ID: <20071015214800.9BB497E01C@common-lisp.net> Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv17532 Modified Files: pal.lisp Log Message: Fixed handling of coordinates in with-clipping. --- /project/pal/cvsroot/pal/pal.lisp 2007/10/15 19:04:55 1.32 +++ /project/pal/cvsroot/pal/pal.lisp 2007/10/15 21:48:00 1.33 @@ -297,9 +297,10 @@ (defunct push-clip (x y width height) (u16 x u16 y u16 width u16 height) (close-quads) - (pal-ffi:gl-scissor x y width height) - (pal-ffi:gl-enable pal-ffi:+gl-scissor-test+) - (push (vector x y width height) *clip-stack*)) + (let ((y (- (get-screen-height) y height))) + (pal-ffi:gl-scissor x y width height) + (pal-ffi:gl-enable pal-ffi:+gl-scissor-test+) + (push (vector x y width height) *clip-stack*))) (defun pop-clip () (close-quads) From tneste at common-lisp.net Mon Oct 15 21:55:54 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 15 Oct 2007 17:55:54 -0400 (EDT) Subject: [pal-cvs] CVS pal-gui/examples Message-ID: <20071015215554.0471A4B053@common-lisp.net> Update of /project/pal/cvsroot/pal-gui/examples In directory clnet:/tmp/cvs-serv18131/examples Modified Files: test.lisp Log Message: Getting off the ground. --- /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/15 19:14:35 1.1 +++ /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/15 21:55:54 1.2 @@ -6,16 +6,17 @@ (defun test () (with-gui (:paths (merge-pathnames "examples/" pal::*pal-directory*)) (let* ((window (make-instance 'window :pos (v 200 200) :width 300 :height 200)) - (slider (make-instance 'v-slider :pos (v 250 20) :height 150 :parent window :max-value 200 :page-size 100)) (meter (make-instance 'h-meter :pos (v 30 50) :width 150 :parent window :max-value 80 :display-fn (lambda (v) (format nil "FPS: ~a" v)))) (gauge (make-instance 'h-gauge :pos (v 30 20) :width 150 :parent window :min-value 0 :max-value 255 :value 0 :display-fn (lambda (v) (format nil "R: ~a" v)))) - (button (make-instance 'button :pos (v 100 100) :value "FooBar!" :parent window))) + (button (make-instance 'button :pos (v 100 100) :value "FooBar!" :parent window :width 100 :on-select (lambda (g pos) (message 'foo) t))) + + (window-2 (make-instance 'window :pos (v 20 20) :width 200 :height 300)) + (list (make-instance 'list-box :pos (v 10 10) :parent window-2 :items (loop for i from 0 to 10 collect (format nil "FooBar ~a" i))))) (gui-loop () - (setf (value-of button) (value-of slider)) (setf (value-of meter) (get-fps)) (draw-image* (tag 'tile) (v 0 0) (v 0 0) 800 600) (with-blend (:color (list (value-of gauge) 0 0 64)) From tneste at common-lisp.net Mon Oct 15 21:55:55 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 15 Oct 2007 17:55:55 -0400 (EDT) Subject: [pal-cvs] CVS pal-gui Message-ID: <20071015215555.410F05D00B@common-lisp.net> Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv18131 Modified Files: gob.lisp gui.lisp widgets.lisp Log Message: Getting off the ground. --- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/15 19:14:36 1.1 +++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/15 21:55:55 1.2 @@ -21,24 +21,28 @@ (setf (parent-of g) parent) (push g *gobs*)) -(defmethod draw ((g gob)) - (declare (ignore g)) - nil) +(defgeneric repaint (gob)) +(defgeneric absolute-pos-of (gob)) (defmethod absolute-pos-of ((g gob)) (if (parent-of g) (v+ (pos-of g) (absolute-pos-of (parent-of g))) (pos-of g))) +(defgeneric (setf absolute-pos-of) (pos gob)) (defmethod (setf absolute-pos-of) (pos (g gob)) (setf (pos-of g) (v+ (v- pos (absolute-pos-of g)) (pos-of g)))) +(defgeneric point-inside-p (gob point)) (defmethod point-inside-p ((g gob) point) (point-inside-rectangle-p (absolute-pos-of g) (width-of g) (height-of g) point)) + +(defgeneric on-enter (gob)) (defmethod on-enter ((gob gob)) nil) +(defgeneric on-leave (gob)) (defmethod on-leave ((gob gob)) nil) @@ -76,14 +80,15 @@ (:default-initargs :activep nil)) -(defmethod draw :around ((g containing)) +(defmethod repaint :around ((g containing)) (call-next-method) - (draw-childs g)) + (repaint-childs g)) -(defmethod draw-childs ((g containing)) +(defgeneric repaint-childs (container)) +(defmethod repaint-childs ((g containing)) (with-transformation (:pos (pos-of g)) (dolist (c (childs-of g)) - (draw c)))) + (repaint c)))) (defgeneric adopt (parent child)) (defmethod adopt ((parent containing) (child gob)) @@ -96,11 +101,19 @@ (setf (slot-value (parent-of child) 'childs) (remove child (slot-value (parent-of child) 'childs)) (parent-of child) nil))) +(defgeneric (setf parent-of) (parent child)) (defmethod (setf parent-of) ((parent containing) (child gob)) (abandon child) (adopt parent child)) +(defclass v-packing (containing) + ()) + + + + + @@ -128,6 +141,9 @@ () (:default-initargs :width (get-screen-width) :height (get-screen-height) :pos (v 0 0) :parent nil)) +(defmethod repaint ((g root)) + (declare (ignore g)) + nil) (defmethod (setf parent-of) (parent (root root)) (declare (ignore parent)) --- /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/15 19:14:36 1.1 +++ /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/15 21:55:55 1.2 @@ -8,13 +8,13 @@ (let ((key-up (lambda (key) (case key - (:key-mouse-1 (setf *armed-gob* nil) - (cond + (:key-mouse-1 (cond (*pointed-gob* (when (eq *armed-gob* *pointed-gob*) (on-select *armed-gob* (v- (get-mouse-pos) (absolute-pos-of *armed-gob*)))) (on-button-up *pointed-gob* (v- (get-mouse-pos) (absolute-pos-of *pointed-gob*)))) - (t (pal::funcall? ,key-up-fn key)))) + (t (pal::funcall? ,key-up-fn key))) + (setf *armed-gob* nil)) (otherwise (pal::funcall? ,key-up-fn key))))) (key-down (lambda (key) (case key @@ -60,7 +60,7 @@ *root* (make-instance 'root))) (defun update-gui () - (draw *root*)) + (repaint *root*)) (defun gob-at-point (point) (find-if (lambda (g) (and (activep g) (point-inside-p g point))) *gobs*)) --- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/15 19:14:36 1.1 +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/15 21:55:55 1.2 @@ -4,6 +4,7 @@ (defparameter *window-color* '(160 160 160 160)) (defparameter *widget-color* '(180 180 180 255)) (defparameter *text-color* '(0 0 0 255)) +(defparameter *paper-color* '(255 255 200 255)) (defun get-text-bounds (string &optional font) @@ -19,7 +20,10 @@ (truncate (* (get-font-height font) 1.5))) (defun draw-frame (pos width height color &key style (border 1)) - (let ((r (first color)) + (let ((pos (v-floor pos)) + (width (truncate width)) + (height (truncate height)) + (r (first color)) (g (second color)) (b (third color)) (a (fourth color))) @@ -37,16 +41,33 @@ (draw-line (v+ pos (v (- width 1) (- height 1))) (v+ pos (v width 0)) 255 255 255 128) (draw-line (v+ pos (v width (- height 1))) (v+ pos (v 0 height)) 255 255 255 128))))) +(defun display-value (widget &optional value) + (funcall (display-fn-of widget) (or value (value-of widget)))) +(defclass widget (gob) + ((on-drag :accessor on-drag-of :initarg :on-drag :initform (lambda (widget pos d) (declare (ignore widget pos d)) nil)) + (on-select :accessor on-select-of :initarg :on-select :initform (lambda (widget pos) (declare (ignore widget pos)) nil))) + (:default-initargs :width (get-m) :height (get-m))) +(defmethod on-drag :around ((g widget) pos d) + (unless (funcall (on-drag-of g) g pos d) + (call-next-method))) -(defclass window (gob containing sliding) +(defmethod on-select :around ((g widget) pos) + (unless (funcall (on-select-of g) g pos) + (call-next-method))) + + + + + +(defclass window (widget containing sliding) ((color :accessor color-of :initform *window-color* :initarg :color)) (:default-initargs :activep t)) -(defmethod draw ((g window)) +(defmethod repaint ((g window)) (draw-rectangle (v+ (v 6 6) (pos-of g)) (width-of g) (height-of g) 0 0 0 64) (draw-frame (pos-of g) (width-of g) (height-of g) (color-of g) :style :raised)) @@ -58,9 +79,9 @@ -(defclass button (gob) +(defclass button (widget) ((color :accessor color-of :initform *widget-color* :initarg :color) - (display-fn :accessor display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v))) + (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v))) (value :accessor value-of :initform "" :initarg :value))) (defmethod initialize-instance :after ((g button) &key width &allow-other-keys) @@ -69,7 +90,7 @@ (setf (width-of g) w)) (setf (height-of g) h))) -(defmethod draw ((g button)) +(defmethod repaint ((g button)) (let ((color (color-of g)) (value (funcall (display-fn-of g) (value-of g))) (fpos (v+ (pos-of g) (get-text-offset)))) @@ -93,11 +114,11 @@ -(defclass h-gauge (gob) +(defclass h-gauge (widget) ((value :reader value-of :initarg :value :initform 0) (min-value :accessor min-value-of :initarg :min-value :initform 0) (max-value :accessor max-value-of :initarg :max-value :initform 100) - (display-fn :accessor display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) + (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) (:default-initargs :height (get-m))) (defmethod (setf value-of) (value (g h-gauge)) @@ -108,7 +129,7 @@ (let ((x (vx (v- start-pos delta)))) (setf (value-of g) (+ (truncate x (/ (width-of g) (abs (- (min-value-of g) (max-value-of g))))) (min-value-of g))))) -(defmethod draw ((g h-gauge)) +(defmethod repaint ((g h-gauge)) (let* ((vt (funcall (display-fn-of g) (value-of g))) (sw (get-text-bounds vt)) (m (get-m)) @@ -131,7 +152,7 @@ -(defclass v-slider (gob) +(defclass v-slider (widget) ((value :reader value-of :initarg :value :initform 0) (page-size :accessor page-size-of :initarg :page-size :initform 1) (min-value :accessor min-value-of :initarg :min-value :initform 0) @@ -146,13 +167,16 @@ (let ((y (vy (v- start-pos delta)))) (setf (value-of g) (+ (truncate y (/ (height-of g) (abs (- (min-value-of g) (max-value-of g))))) (min-value-of g))))) -(defmethod draw ((g v-slider)) +(defmethod repaint ((g v-slider)) (let* ((units (abs (- (min-value-of g) (max-value-of g)))) (usize (/ (height-of g) units)) (k (truncate (* usize (- (value-of g) (min-value-of g))))) (kpos (v+ (pos-of g) (v 0 k)))) (draw-frame (pos-of g) (width-of g) (height-of g) *window-color* :style :sunken) - (draw-frame kpos (width-of g) (* (- units (page-size-of g)) usize) *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1)))) + (draw-frame kpos + (width-of g) + (min (height-of g) (- (height-of g) (* (- units (page-size-of g)) usize))) + *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1)))) @@ -161,17 +185,17 @@ -(defclass h-meter (gob) +(defclass h-meter (widget) ((value :reader value-of :initarg :value :initform 0) (min-value :accessor min-value-of :initarg :min-value :initform 0) (max-value :accessor max-value-of :initarg :max-value :initform 100) - (display-fn :accessor display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) + (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) (:default-initargs :activep nil :height (get-m))) (defmethod (setf value-of) (value (g h-meter)) (setf (slot-value g 'value) (clamp (min-value-of g) value (max-value-of g)))) -(defmethod draw ((g h-meter)) +(defmethod repaint ((g h-meter)) (let* ((m (get-m)) (k (truncate (* (/ (width-of g) (abs (- (min-value-of g) (max-value-of g)))) (- (value-of g) (min-value-of g))))) ) (draw-frame (pos-of g) (width-of g) (height-of g) *window-color* :style :sunken) @@ -183,12 +207,45 @@ -(defclass v-list (gob) +(defclass list-view (widget) ((items :accessor items-of :initarg :items :initform '()) (scroll :accessor scroll-of :initform 0) - (display-fn :accessor display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) - (:default-initargs :width (* 10 (get-m)) :height (* 5 (get-m)))) + (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) + (:default-initargs :width (* 6 (get-m)) :height (* 5 (get-m)))) + + +(defmethod repaint ((g list-view)) + (with-accessors ((width width-of) (height height-of) (pos pos-of) (ap absolute-pos-of)) g + (draw-frame pos width height *paper-color* :style :sunken) + (with-clipping ((vx ap) (vy ap) width height) + (with-blend (:color *text-color*) + (let ((pos (v+ pos (get-text-offset))) + (y 0)) + (dolist (i (items-of g)) + (when (oddp y) + (draw-rectangle (v- (v+ pos (v 0 (- (* y (get-m)) (scroll-of g)))) (get-text-offset)) width (get-m) 0 0 0 32)) + (draw-text (display-value g i) (v+ pos (v 0 (- (* y (get-m)) (scroll-of g))))) + (incf y))))))) + + -(defmethod draw ((g v-list)) - ()) \ No newline at end of file +(defclass list-box (widget containing) + () + (:default-initargs :height (* 6 (get-m)) :width (* 5 (get-m)))) + +(defmethod initialize-instance :after ((g list-box) &key pos items &allow-other-keys) + (let* ((lv (make-instance 'list-view :items items :pos pos :parent g :height (height-of g) :width (width-of g))) + (sl (make-instance 'v-slider :pos (v+ pos (v (+ (width-of lv) 3) 0)) + :parent g + :max-value (* (get-m) (length items)) + :height (height-of g) + :page-size (height-of lv) + :on-drag (lambda (g pos d) + (declare (ignore pos d)) + (setf (scroll-of lv) (value-of g)) + nil)))))) + +(defmethod repaint ((g list-box)) + (declare (ignore g)) + nil) \ No newline at end of file From tneste at common-lisp.net Mon Oct 15 22:53:15 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 15 Oct 2007 18:53:15 -0400 (EDT) Subject: [pal-cvs] CVS pal-gui/examples Message-ID: <20071015225315.EE4F953112@common-lisp.net> Update of /project/pal/cvsroot/pal-gui/examples In directory clnet:/tmp/cvs-serv30295/examples Modified Files: test.lisp Log Message: Primitive widget packing. --- /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/15 21:55:54 1.2 +++ /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/15 22:53:15 1.3 @@ -6,15 +6,13 @@ (defun test () (with-gui (:paths (merge-pathnames "examples/" pal::*pal-directory*)) (let* ((window (make-instance 'window :pos (v 200 200) :width 300 :height 200)) - (meter (make-instance 'h-meter :pos (v 30 50) :width 150 :parent window :max-value 80 :display-fn (lambda (v) (format nil "FPS: ~a" v)))) - (gauge (make-instance 'h-gauge :pos (v 30 20) - :width 150 + (window-2 (make-instance 'window :width 200 :height 300)) + (meter (make-instance 'h-meter :width 150 :parent window-2 :max-value 80 :display-fn (lambda (v) (format nil "FPS: ~a" v)))) + (gauge (make-instance 'h-gauge :width 150 :parent window :min-value 0 :max-value 255 :value 0 :display-fn (lambda (v) (format nil "R: ~a" v)))) - (button (make-instance 'button :pos (v 100 100) :value "FooBar!" :parent window :width 100 :on-select (lambda (g pos) (message 'foo) t))) - - (window-2 (make-instance 'window :pos (v 20 20) :width 200 :height 300)) - (list (make-instance 'list-box :pos (v 10 10) :parent window-2 :items (loop for i from 0 to 10 collect (format nil "FooBar ~a" i))))) + (button (make-instance 'button :value "FooBar!" :parent window :width 100 :on-select (lambda (g pos) (message 'foo) t))) + (list (make-instance 'list-box :parent window-2 :items (loop for i from 0 to 10 collect (format nil "FooBar ~a" i))))) (gui-loop () (setf (value-of meter) (get-fps)) From tneste at common-lisp.net Mon Oct 15 22:53:16 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 15 Oct 2007 18:53:16 -0400 (EDT) Subject: [pal-cvs] CVS pal-gui Message-ID: <20071015225316.34AB95D0E0@common-lisp.net> Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv30295 Modified Files: gob.lisp widgets.lisp Log Message: Primitive widget packing. --- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/15 21:55:55 1.2 +++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/15 22:53:16 1.3 @@ -9,6 +9,7 @@ (defvar *armed-gob* nil) + (defclass gob () ((pos :accessor pos-of :initarg :pos :initform (v 0 0)) (parent :reader parent-of :initform nil) @@ -95,25 +96,55 @@ (setf (slot-value child 'parent) parent) (push child (slot-value parent 'childs))) -(defgeneric abandon (child)) -(defmethod abandon ((child gob)) - (when (parent-of child) - (setf (slot-value (parent-of child) 'childs) (remove child (slot-value (parent-of child) 'childs)) - (parent-of child) nil))) +(defgeneric abandon (parent child)) +(defmethod abandon ((parent containing) (child gob)) + (setf (slot-value parent 'childs) (remove child (slot-value parent 'childs)) + (parent-of child) nil)) (defgeneric (setf parent-of) (parent child)) (defmethod (setf parent-of) ((parent containing) (child gob)) - (abandon child) + (when (parent-of child) + (abandon (parent-of child) child)) (adopt parent child)) (defclass v-packing (containing) - ()) + ((xpad :accessor xpad-of :initarg :xpad :initform 0) + (ypad :accessor ypad-of :initarg :ypad :initform 0) + (gap :accessor gap-of :initarg :gap :initform 0))) + +(defmethod adopt ((parent v-packing) (child gob)) + (call-next-method) + (pack parent)) + +(defmethod abandon ((parent v-packing) (child gob)) + (call-next-method) + (pack parent)) +(defgeneric pack (container)) +(defmethod pack ((g v-packing)) + (let ((pos (v (xpad-of g) (ypad-of g)))) + (dolist (c (reverse (childs-of g))) + (setf (pos-of c) pos) + (setf pos (v+ pos (v 0 (+ (gap-of g) (height-of c)))))))) +(defclass h-packing (v-packing) + ((xpad :accessor xpad-of :initarg :xpad :initform 0) + (ypad :accessor ypad-of :initarg :ypad :initform 0) + (gap :accessor gap-of :initarg :gap :initform 0))) + +(defgeneric pack (container)) +(defmethod pack ((g h-packing)) + (let ((pos (v (xpad-of g) (ypad-of g)))) + (dolist (c (reverse (childs-of g))) + (setf (pos-of c) pos) + (setf pos (v+ pos (v (+ (gap-of g) (width-of c)) 0)))))) + + + @@ -133,6 +164,14 @@ +(defclass clipping () + ()) + +(defmethod repaint-childs :around ((g clipping)) + (let ((ap (absolute-pos-of g))) + (with-clipping ((vx ap) (vy ap) (width-of g) (height-of g)) + (call-next-method)))) + --- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/15 21:55:55 1.2 +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/15 22:53:16 1.3 @@ -7,6 +7,9 @@ (defparameter *paper-color* '(255 255 200 255)) +(defun get-m (&optional font) + (truncate (* (get-font-height font) 1.5))) + (defun get-text-bounds (string &optional font) (let ((fh (get-font-height font))) (values (max (truncate (* 1.5 fh)) (+ (get-text-size string) fh)) @@ -16,9 +19,6 @@ (let ((fh (get-font-height font))) (v (truncate fh 2) (truncate fh 4)))) -(defun get-m (&optional font) - (truncate (* (get-font-height font) 1.5))) - (defun draw-frame (pos width height color &key style (border 1)) (let ((pos (v-floor pos)) (width (truncate width)) @@ -63,9 +63,9 @@ -(defclass window (widget containing sliding) +(defclass window (widget v-packing sliding clipping) ((color :accessor color-of :initform *window-color* :initarg :color)) - (:default-initargs :activep t)) + (:default-initargs :activep t :xpad (truncate (get-m) 2) :ypad (truncate (get-m) 2) :gap (truncate (get-m) 3) :pos (v 10 10))) (defmethod repaint ((g window)) (draw-rectangle (v+ (v 6 6) (pos-of g)) (width-of g) (height-of g) 0 0 0 64) @@ -219,25 +219,23 @@ (draw-frame pos width height *paper-color* :style :sunken) (with-clipping ((vx ap) (vy ap) width height) (with-blend (:color *text-color*) - (let ((pos (v+ pos (get-text-offset))) - (y 0)) + (let ((y 0)) (dolist (i (items-of g)) (when (oddp y) - (draw-rectangle (v- (v+ pos (v 0 (- (* y (get-m)) (scroll-of g)))) (get-text-offset)) width (get-m) 0 0 0 32)) - (draw-text (display-value g i) (v+ pos (v 0 (- (* y (get-m)) (scroll-of g))))) + (draw-rectangle (v+ pos (v 0 (- (* y (get-m)) (scroll-of g)))) width (get-m) 0 0 0 32)) + (draw-text (display-value g i) (v+ (v+ pos (get-text-offset)) (v 0 (- (* y (get-m)) (scroll-of g))))) (incf y))))))) -(defclass list-box (widget containing) +(defclass list-box (widget h-packing) () - (:default-initargs :height (* 6 (get-m)) :width (* 5 (get-m)))) + (:default-initargs :height (* 6 (get-m)) :width (* 5 (get-m)) :gap 3 :xpad 0 :ypad 0)) -(defmethod initialize-instance :after ((g list-box) &key pos items &allow-other-keys) - (let* ((lv (make-instance 'list-view :items items :pos pos :parent g :height (height-of g) :width (width-of g))) - (sl (make-instance 'v-slider :pos (v+ pos (v (+ (width-of lv) 3) 0)) - :parent g +(defmethod initialize-instance :after ((g list-box) &key items &allow-other-keys) + (let* ((lv (make-instance 'list-view :items items :parent g :height (height-of g) :width (width-of g))) + (sl (make-instance 'v-slider :parent g :max-value (* (get-m) (length items)) :height (height-of g) :page-size (height-of lv) From tneste at common-lisp.net Tue Oct 16 00:16:41 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 15 Oct 2007 20:16:41 -0400 (EDT) Subject: [pal-cvs] CVS pal-gui/examples Message-ID: <20071016001641.B7D421E0B7@common-lisp.net> Update of /project/pal/cvsroot/pal-gui/examples In directory clnet:/tmp/cvs-serv12729/examples Modified Files: test.lisp Log Message: Improved packing. --- /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/15 22:53:15 1.3 +++ /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/16 00:16:41 1.4 @@ -7,12 +7,14 @@ (with-gui (:paths (merge-pathnames "examples/" pal::*pal-directory*)) (let* ((window (make-instance 'window :pos (v 200 200) :width 300 :height 200)) (window-2 (make-instance 'window :width 200 :height 300)) - (meter (make-instance 'h-meter :width 150 :parent window-2 :max-value 80 :display-fn (lambda (v) (format nil "FPS: ~a" v)))) - (gauge (make-instance 'h-gauge :width 150 - :parent window + (cont (make-instance 'h-container :parent window)) + (cont-2 (make-instance 'v-container :parent cont)) + (meter (make-instance 'h-meter :parent cont :max-value 80 :display-fn (lambda (v) (format nil "FPS: ~a" v)))) + (gauge (make-instance 'h-gauge :parent cont-2 :min-value 0 :max-value 255 :value 0 :display-fn (lambda (v) (format nil "R: ~a" v)))) - (button (make-instance 'button :value "FooBar!" :parent window :width 100 :on-select (lambda (g pos) (message 'foo) t))) - (list (make-instance 'list-box :parent window-2 :items (loop for i from 0 to 10 collect (format nil "FooBar ~a" i))))) + (button (make-instance 'button :value "FooBar!" :parent cont-2 :on-select (lambda (g pos) (message 'foo) t))) + (button (make-instance 'button :value "List" :parent window-2 :on-select (lambda (g pos) (message 'foo) t))) + (list (make-instance 'list-box :parent window-2 :items (loop for i from 0 to 100 collect (format nil "FooBar ~a" i))))) (gui-loop () (setf (value-of meter) (get-fps)) From tneste at common-lisp.net Tue Oct 16 00:16:41 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 15 Oct 2007 20:16:41 -0400 (EDT) Subject: [pal-cvs] CVS pal-gui Message-ID: <20071016001641.EE31D1E0B5@common-lisp.net> Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv12729 Modified Files: gob.lisp widgets.lisp Log Message: Improved packing. --- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/15 22:53:16 1.3 +++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/16 00:16:41 1.4 @@ -13,6 +13,8 @@ (defclass gob () ((pos :accessor pos-of :initarg :pos :initform (v 0 0)) (parent :reader parent-of :initform nil) + (x-expand-p :accessor x-expand-p :initform nil :initarg :x-expand-p) + (y-expand-p :accessor y-expand-p :initform nil :initarg :y-expand-p) (activep :accessor activep :initform t :initarg :activep) (width :accessor width-of :initarg :width :initform 0) (height :accessor height-of :initarg :height :initform 0))) @@ -123,10 +125,19 @@ (defgeneric pack (container)) (defmethod pack ((g v-packing)) - (let ((pos (v (xpad-of g) (ypad-of g)))) - (dolist (c (reverse (childs-of g))) - (setf (pos-of c) pos) - (setf pos (v+ pos (v 0 (+ (gap-of g) (height-of c)))))))) + (with-accessors ((gap gap-of) (width width-of) (height height-of) (pos pos-of) (childs childs-of) (ypad ypad-of) (xpad xpad-of)) g + (let* ((exp-count (count-if #'y-expand-p childs)) + (solids-need (loop for c in childs summing (if (y-expand-p c) 0 (+ gap (height-of c))))) + (exp-size (max 10 (- height solids-need (* 2 ypad))))) + (dolist (c childs) + (when (y-expand-p c) + (setf (height-of c) (truncate exp-size exp-count))) + (when (x-expand-p c) + (setf (width-of c) (- width (* 2 xpad)))))) + (let ((cpos (v xpad ypad))) + (dolist (c (reverse childs)) + (setf (pos-of c) cpos) + (setf cpos (v+ cpos (v 0 (+ gap (height-of c))))))))) @@ -136,12 +147,20 @@ (ypad :accessor ypad-of :initarg :ypad :initform 0) (gap :accessor gap-of :initarg :gap :initform 0))) -(defgeneric pack (container)) (defmethod pack ((g h-packing)) - (let ((pos (v (xpad-of g) (ypad-of g)))) - (dolist (c (reverse (childs-of g))) - (setf (pos-of c) pos) - (setf pos (v+ pos (v (+ (gap-of g) (width-of c)) 0)))))) + (with-accessors ((gap gap-of) (height height-of) (width width-of) (pos pos-of) (childs childs-of) (ypad ypad-of) (xpad xpad-of)) g + (let* ((exp-count (count-if #'x-expand-p childs)) + (solids-need (loop for c in childs summing (if (x-expand-p c) 0 (+ gap (width-of c))))) + (exp-size (max 10 (- width solids-need (* 2 ypad))))) + (dolist (c childs) + (when (x-expand-p c) + (setf (width-of c) (truncate exp-size exp-count))) + (when (y-expand-p c) + (setf (height-of c) (- height (* 2 ypad)))))) + (let ((cpos (v xpad ypad))) + (dolist (c (reverse childs)) + (setf (pos-of c) cpos) + (setf cpos (v+ cpos (v (+ gap (width-of c)) 0))))))) --- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/15 22:53:16 1.3 +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/16 00:16:41 1.4 @@ -63,17 +63,30 @@ -(defclass window (widget v-packing sliding clipping) - ((color :accessor color-of :initform *window-color* :initarg :color)) - (:default-initargs :activep t :xpad (truncate (get-m) 2) :ypad (truncate (get-m) 2) :gap (truncate (get-m) 3) :pos (v 10 10))) +(defclass v-container (widget v-packing) + () + (:default-initargs :activep nil :x-expand-p t :y-expand-p t :xpad 0 :ypad 0 :gap (truncate (get-m) 3))) -(defmethod repaint ((g window)) - (draw-rectangle (v+ (v 6 6) (pos-of g)) (width-of g) (height-of g) 0 0 0 64) - (draw-frame (pos-of g) (width-of g) (height-of g) (color-of g) :style :raised)) +(defmethod repaint ((g v-container)) + (draw-rectangle (pos-of g) (width-of g) (height-of g) 0 0 0 64 :fill nil) + ) +(defclass h-container (widget h-packing) + () + (:default-initargs :activep nil :x-expand-p t :y-expand-p t :xpad 0 :ypad 0 :gap (truncate (get-m) 3))) +(defmethod repaint ((g h-container)) + (draw-rectangle (pos-of g) (width-of g) (height-of g) 0 0 0 64 :fill nil) + ) +(defclass window (v-container sliding clipping) + ((color :accessor color-of :initform *window-color* :initarg :color)) + (:default-initargs :activep t :width 100 :height 100 :xpad (truncate (get-m) 2) :ypad (truncate (get-m) 2) :gap (truncate (get-m) 3) :pos (v 10 10))) + +(defmethod repaint ((g window)) + (draw-rectangle (v+ (v 6 6) (pos-of g)) (width-of g) (height-of g) 0 0 0 64) + (draw-frame (pos-of g) (width-of g) (height-of g) (color-of g) :style :raised)) @@ -82,12 +95,12 @@ (defclass button (widget) ((color :accessor color-of :initform *widget-color* :initarg :color) (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v))) - (value :accessor value-of :initform "" :initarg :value))) + (value :accessor value-of :initform "" :initarg :value)) + (:default-initargs :x-expand-p t)) -(defmethod initialize-instance :after ((g button) &key width &allow-other-keys) +(defmethod initialize-instance :after ((g button) &key &allow-other-keys) (multiple-value-bind (w h) (get-text-bounds (value-of g)) - (unless width - (setf (width-of g) w)) + (declare (ignore w)) (setf (height-of g) h))) (defmethod repaint ((g button)) @@ -119,7 +132,7 @@ (min-value :accessor min-value-of :initarg :min-value :initform 0) (max-value :accessor max-value-of :initarg :max-value :initform 100) (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) - (:default-initargs :height (get-m))) + (:default-initargs :x-expand-p t)) (defmethod (setf value-of) (value (g h-gauge)) (setf (slot-value g 'value) (clamp (min-value-of g) value (max-value-of g)))) @@ -157,7 +170,7 @@ (page-size :accessor page-size-of :initarg :page-size :initform 1) (min-value :accessor min-value-of :initarg :min-value :initform 0) (max-value :accessor max-value-of :initarg :max-value :initform 100)) - (:default-initargs :width (truncate (get-m) 2))) + (:default-initargs :width (truncate (get-m) 2) :y-expand-p t)) (defmethod (setf value-of) (value (g v-slider)) (setf (slot-value g 'value) (clamp (min-value-of g) value (- (max-value-of g) (page-size-of g))))) @@ -190,7 +203,7 @@ (min-value :accessor min-value-of :initarg :min-value :initform 0) (max-value :accessor max-value-of :initarg :max-value :initform 100) (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) - (:default-initargs :activep nil :height (get-m))) + (:default-initargs :activep nil :x-expand-p t)) (defmethod (setf value-of) (value (g h-meter)) (setf (slot-value g 'value) (clamp (min-value-of g) value (max-value-of g)))) @@ -211,7 +224,7 @@ ((items :accessor items-of :initarg :items :initform '()) (scroll :accessor scroll-of :initform 0) (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) - (:default-initargs :width (* 6 (get-m)) :height (* 5 (get-m)))) + (:default-initargs :x-expand-p t)) (defmethod repaint ((g list-view)) @@ -231,18 +244,18 @@ (defclass list-box (widget h-packing) () - (:default-initargs :height (* 6 (get-m)) :width (* 5 (get-m)) :gap 3 :xpad 0 :ypad 0)) + (:default-initargs :gap 3 :xpad 0 :ypad 0 :y-expand-p t :x-expand-p t)) (defmethod initialize-instance :after ((g list-box) &key items &allow-other-keys) - (let* ((lv (make-instance 'list-view :items items :parent g :height (height-of g) :width (width-of g))) - (sl (make-instance 'v-slider :parent g - :max-value (* (get-m) (length items)) - :height (height-of g) - :page-size (height-of lv) - :on-drag (lambda (g pos d) - (declare (ignore pos d)) - (setf (scroll-of lv) (value-of g)) - nil)))))) + (let* ((lv (make-instance 'list-view :items items :parent g :height (height-of g) :width (width-of g)))) + (make-instance 'v-slider :parent g + :max-value (* (get-m) (length items)) + :height (height-of g) + :page-size (height-of lv) + :on-drag (lambda (g pos d) + (declare (ignore pos d)) + (setf (scroll-of lv) (value-of g)) + nil)))) (defmethod repaint ((g list-box)) (declare (ignore g)) From tneste at common-lisp.net Tue Oct 16 21:46:09 2007 From: tneste at common-lisp.net (tneste) Date: Tue, 16 Oct 2007 17:46:09 -0400 (EDT) Subject: [pal-cvs] CVS pal-gui/examples Message-ID: <20071016214609.B105974162@common-lisp.net> Update of /project/pal/cvsroot/pal-gui/examples In directory clnet:/tmp/cvs-serv9325/examples Modified Files: test.lisp Log Message: Several fixes, mostly in widget packing. --- /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/16 00:16:41 1.4 +++ /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/16 21:46:09 1.5 @@ -5,22 +5,35 @@ (defun test () (with-gui (:paths (merge-pathnames "examples/" pal::*pal-directory*)) - (let* ((window (make-instance 'window :pos (v 200 200) :width 300 :height 200)) + (let* ((window (make-instance 'window :pos (v 200 200) :width 300 :height 230)) (window-2 (make-instance 'window :width 200 :height 300)) - (cont (make-instance 'h-container :parent window)) - (cont-2 (make-instance 'v-container :parent cont)) - (meter (make-instance 'h-meter :parent cont :max-value 80 :display-fn (lambda (v) (format nil "FPS: ~a" v)))) - (gauge (make-instance 'h-gauge :parent cont-2 - :min-value 0 :max-value 255 :value 0 :display-fn (lambda (v) (format nil "R: ~a" v)))) - (button (make-instance 'button :value "FooBar!" :parent cont-2 :on-select (lambda (g pos) (message 'foo) t))) - (button (make-instance 'button :value "List" :parent window-2 :on-select (lambda (g pos) (message 'foo) t))) - (list (make-instance 'list-box :parent window-2 :items (loop for i from 0 to 100 collect (format nil "FooBar ~a" i))))) + + (box (make-instance 'h-box :parent window)) + (right-box (make-instance 'v-box :parent box)) + (left-box (make-instance 'v-box :parent box)) + (bottom-box (make-instance 'v-box :parent window)) + + (meter (make-instance 'h-meter :parent right-box :max-value 80 :display-fn (lambda (v) (format nil "FPS: ~a" v)))) + (rg (make-instance 'h-gauge :parent left-box + :min-value 0 :max-value 255 :value 0 :display-fn (lambda (v) (format nil "R: ~a" v)))) + (gg (make-instance 'h-gauge :parent left-box + :min-value 0 :max-value 255 :value 0 :display-fn (lambda (v) (format nil "G: ~a" v)))) + (bg (make-instance 'h-gauge :parent left-box + :min-value 0 :max-value 255 :value 0 :display-fn (lambda (v) (format nil "B: ~a" v)))) + (ag (make-instance 'h-gauge :parent left-box + :min-value 0 :max-value 255 :value 0 :display-fn (lambda (v) (format nil "A: ~a" v)))) + (list (make-instance 'list-box :parent window-2 :items (loop for i from 0 to 100 collect (format nil "FooBar ~a" i)))) + (button (make-instance 'button :value "FooBar!" :parent window-2 :on-select (lambda (g pos) (message 'foo) t))) + ) + + (make-instance 'button :value "Button" :parent bottom-box) (gui-loop () (setf (value-of meter) (get-fps)) (draw-image* (tag 'tile) (v 0 0) (v 0 0) 800 600) - (with-blend (:color (list (value-of gauge) 0 0 64)) + (with-blend (:color '(0 0 0 64)) (draw-image (tag 'plane) (v 320 220))) - (draw-image (tag 'plane) (v 300 200)))))) + (with-blend (:color (list (value-of rg) (value-of gg) (value-of bg) (value-of ag))) + (draw-image (tag 'plane) (v 300 200))))))) ;; (test) \ No newline at end of file From tneste at common-lisp.net Tue Oct 16 21:46:10 2007 From: tneste at common-lisp.net (tneste) Date: Tue, 16 Oct 2007 17:46:10 -0400 (EDT) Subject: [pal-cvs] CVS pal-gui Message-ID: <20071016214610.0BE2874162@common-lisp.net> Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv9325 Modified Files: gob.lisp gui.lisp widgets.lisp Log Message: Several fixes, mostly in widget packing. --- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/16 00:16:41 1.4 +++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/16 21:46:09 1.5 @@ -25,6 +25,19 @@ (push g *gobs*)) (defgeneric repaint (gob)) +(defmethod repaint :around ((g gob)) + (with-transformation (:pos (pos-of g)) + (call-next-method))) + +(defgeneric lower (gob)) +(defmethod lower ((g gob)) + (setf (slot-value (parent-of g) 'childs) + (cons g (remove g (childs-of (parent-of g)))))) + +(defgeneric raise (gob)) +(defmethod raise ((g gob)) + (setf (slot-value (parent-of g) 'childs) + (append (remove g (childs-of (parent-of g))) (list g)))) (defgeneric absolute-pos-of (gob)) (defmethod absolute-pos-of ((g gob)) @@ -87,11 +100,15 @@ (call-next-method) (repaint-childs g)) +(defgeneric pack (containing)) +(defmethod pack ((g containing)) + (when (parent-of g) + (pack (parent-of g)))) + (defgeneric repaint-childs (container)) (defmethod repaint-childs ((g containing)) - (with-transformation (:pos (pos-of g)) - (dolist (c (childs-of g)) - (repaint c)))) + (dolist (c (childs-of g)) + (repaint c))) (defgeneric adopt (parent child)) (defmethod adopt ((parent containing) (child gob)) @@ -109,6 +126,21 @@ (abandon (parent-of child) child)) (adopt parent child)) +(defgeneric min-height-of (containing)) +(defmethod min-height-of ((g containing)) + (+ (* (length (childs-of g)) (gap-of g)) + (loop for c in (childs-of g) summing (if (y-expand-p c) 0 (if (typep c 'containing) + (min-height-of c) + (height-of c)))))) +(defgeneric min-width-of (containing)) +(defmethod min-width-of ((g containing)) + (+ (* (length (childs-of g)) (gap-of g)) + (loop for c in (childs-of g) summing (if (x-expand-p c) 0 (if (typep c 'containing) + (min-width-of c) + (width-of c)))))) + + + (defclass v-packing (containing) ((xpad :accessor xpad-of :initarg :xpad :initform 0) @@ -123,17 +155,18 @@ (call-next-method) (pack parent)) -(defgeneric pack (container)) (defmethod pack ((g v-packing)) (with-accessors ((gap gap-of) (width width-of) (height height-of) (pos pos-of) (childs childs-of) (ypad ypad-of) (xpad xpad-of)) g (let* ((exp-count (count-if #'y-expand-p childs)) - (solids-need (loop for c in childs summing (if (y-expand-p c) 0 (+ gap (height-of c))))) - (exp-size (max 10 (- height solids-need (* 2 ypad))))) + (solids-need (min-height-of g)) + (exp-size (- height solids-need (* 2 ypad)))) (dolist (c childs) (when (y-expand-p c) - (setf (height-of c) (truncate exp-size exp-count))) + (setf (height-of c) (max 10 (truncate exp-size exp-count)))) (when (x-expand-p c) - (setf (width-of c) (- width (* 2 xpad)))))) + (setf (width-of c) (- width (* 2 xpad)))) + (when (typep c 'containing) + (pack c)))) (let ((cpos (v xpad ypad))) (dolist (c (reverse childs)) (setf (pos-of c) cpos) @@ -150,13 +183,15 @@ (defmethod pack ((g h-packing)) (with-accessors ((gap gap-of) (height height-of) (width width-of) (pos pos-of) (childs childs-of) (ypad ypad-of) (xpad xpad-of)) g (let* ((exp-count (count-if #'x-expand-p childs)) - (solids-need (loop for c in childs summing (if (x-expand-p c) 0 (+ gap (width-of c))))) - (exp-size (max 10 (- width solids-need (* 2 ypad))))) + (solids-need (min-width-of g)) + (exp-size (- width solids-need (* 2 xpad)))) (dolist (c childs) (when (x-expand-p c) - (setf (width-of c) (truncate exp-size exp-count))) + (setf (width-of c) (max 10 (truncate exp-size exp-count)))) (when (y-expand-p c) - (setf (height-of c) (- height (* 2 ypad)))))) + (setf (height-of c) (- height (* 2 ypad)))) + (when (typep c 'containing) + (pack c)))) (let ((cpos (v xpad ypad))) (dolist (c (reverse childs)) (setf (pos-of c) cpos) @@ -188,7 +223,7 @@ (defmethod repaint-childs :around ((g clipping)) (let ((ap (absolute-pos-of g))) - (with-clipping ((vx ap) (vy ap) (width-of g) (height-of g)) + (with-clipping ((1+ (vx ap)) (1+ (vy ap)) (- (width-of g) 2) (- (height-of g) 2)) (call-next-method)))) --- /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/15 21:55:55 1.2 +++ /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/16 21:46:09 1.3 @@ -33,11 +33,11 @@ (pal::do-event ,event key-up key-down ,mouse-motion-fn ,quit-fn) , at redraw (let ((g (gob-at-point (get-mouse-pos)))) - (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))) + (t (setf *pointed-gob* g) + (when (and g (not (activep g))) (when *pointed-gob* (on-leave *pointed-gob*)) (on-enter g))))) --- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/16 00:16:41 1.4 +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/16 21:46:09 1.5 @@ -1,7 +1,7 @@ (in-package :pal-gui) -(defparameter *window-color* '(160 160 160 160)) +(defparameter *window-color* '(160 160 160 128)) (defparameter *widget-color* '(180 180 180 255)) (defparameter *text-color* '(0 0 0 255)) (defparameter *paper-color* '(255 255 200 255)) @@ -19,7 +19,7 @@ (let ((fh (get-font-height font))) (v (truncate fh 2) (truncate fh 4)))) -(defun draw-frame (pos width height color &key style (border 1)) +(defun draw-frame (pos width height color &key style (border 1) (fill t)) (let ((pos (v-floor pos)) (width (truncate width)) (height (truncate height)) @@ -27,8 +27,10 @@ (g (second color)) (b (third color)) (a (fourth color))) - (draw-rectangle (v- pos (v border border)) (+ width (* 2 border) ) (+ height (* 2 border)) 0 0 0 a) - (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)) + (when fill + (draw-rectangle pos width height r g b a)) (case style (:raised (draw-line (v+ pos (v 1 1)) (v+ pos (v width 0)) 255 255 255 128) @@ -62,31 +64,66 @@ +(defclass box (widget containing) + () + (:default-initargs :activep nil :x-expand-p t :y-expand-p t)) + +(defmethod repaint ((g box)) + (declare (ignore g)) + ;; (draw-rectangle (pos-of g) (width-of g) (height-of g) 0 0 0 64 :fill nil) + ) -(defclass v-container (widget v-packing) +(defclass v-box (widget v-packing) () (:default-initargs :activep nil :x-expand-p t :y-expand-p t :xpad 0 :ypad 0 :gap (truncate (get-m) 3))) -(defmethod repaint ((g v-container)) - (draw-rectangle (pos-of g) (width-of g) (height-of g) 0 0 0 64 :fill nil) +(defmethod repaint ((g v-box)) + (declare (ignore g)) + ;; (draw-rectangle (pos-of g) (width-of g) (height-of g) 0 0 0 64 :fill nil) ) -(defclass h-container (widget h-packing) +(defclass h-box (widget h-packing) () - (:default-initargs :activep nil :x-expand-p t :y-expand-p t :xpad 0 :ypad 0 :gap (truncate (get-m) 3))) + (:default-initargs :activep nil :x-expand-p t :y-expand-p t :xpad 0 :ypad 0 :gap (truncate (get-m) 1))) -(defmethod repaint ((g h-container)) - (draw-rectangle (pos-of g) (width-of g) (height-of g) 0 0 0 64 :fill nil) +(defmethod repaint ((g h-box)) + (declare (ignore g)) + ;; (draw-rectangle (pos-of g) (width-of g) (height-of g) 0 0 0 64 :fill nil) ) -(defclass window (v-container sliding clipping) - ((color :accessor color-of :initform *window-color* :initarg :color)) - (:default-initargs :activep t :width 100 :height 100 :xpad (truncate (get-m) 2) :ypad (truncate (get-m) 2) :gap (truncate (get-m) 3) :pos (v 10 10))) + + +(defclass filler (widget) + () + (:default-initargs :activep nil)) + +(defmethod repaint ((g filler)) + (declare (ignore g)) + nil) + + + +(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 :xpad (truncate (get-m) 2) :ypad (truncate (get-m) 3) :gap (truncate (get-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-button-down ((g window) pos) + (declare (ignore pos)) + (raise g)) (defmethod repaint ((g window)) - (draw-rectangle (v+ (v 6 6) (pos-of g)) (width-of g) (height-of g) 0 0 0 64) - (draw-frame (pos-of g) (width-of g) (height-of g) (color-of g) :style :raised)) + (let ((th 6)) + (draw-rectangle (v 6 6) (width-of g) (height-of g) 0 0 0 64) + (draw-frame (v 0 0) (width-of g) (height-of g) *window-color* :style :raised) + (draw-rectangle (v 0 0) (width-of g) (get-m) 0 0 0 64) + (draw-line (v 0 (get-m)) (v (width-of g) (get-m)) 0 0 0 160) + (draw-line (v 0 (1+ (get-m))) (v (width-of g) (1+ (get-m))) 0 0 0 64) + (draw-text (label-of g) (get-text-offset)))) @@ -98,28 +135,23 @@ (value :accessor value-of :initform "" :initarg :value)) (:default-initargs :x-expand-p t)) -(defmethod initialize-instance :after ((g button) &key &allow-other-keys) - (multiple-value-bind (w h) (get-text-bounds (value-of g)) - (declare (ignore w)) - (setf (height-of g) h))) - (defmethod repaint ((g button)) (let ((color (color-of g)) - (value (funcall (display-fn-of g) (value-of g))) - (fpos (v+ (pos-of g) (get-text-offset)))) + (value (display-value g)) + (fpos (get-text-offset))) (cond ((armedp g) - (draw-frame (pos-of g) (width-of g) (height-of g) color :style :sunken :border 2) + (draw-frame (v 0 0) (width-of g) (height-of g) color :style :sunken :border 2) (with-blend (:color *text-color*) (draw-text value (v+ fpos (v 1 1))) )) ((pointedp g) - (draw-frame (pos-of g) (width-of g) (height-of g) color :border 2 :style :raised) + (draw-frame (v 0 0) (width-of g) (height-of g) color :border 2 :style :raised) (with-blend (:color *text-color*) (draw-text value fpos) )) (t - (draw-frame (pos-of g) (width-of g) (height-of g) color :style :raised) + (draw-frame (v 0 0) (width-of g) (height-of g) color :style :raised) (with-blend (:color *text-color*) (draw-text value fpos)))))) @@ -143,20 +175,18 @@ (setf (value-of g) (+ (truncate x (/ (width-of g) (abs (- (min-value-of g) (max-value-of g))))) (min-value-of g))))) (defmethod repaint ((g h-gauge)) - (let* ((vt (funcall (display-fn-of g) (value-of g))) + (let* ((vt (display-value g)) (sw (get-text-bounds vt)) (m (get-m)) (k (truncate (* (/ (width-of g) (abs (- (min-value-of g) (max-value-of g)))) (- (value-of g) (min-value-of g))))) - (kpos (v+ (pos-of g) (v (- k (truncate sw 2)) 0)))) - (draw-frame (v+ (pos-of g) (v 0 (truncate m 3))) (width-of g) (truncate (height-of g) 2) *window-color* :style :sunken) + (kpos (v (- k (truncate sw 2)) 0))) + (draw-frame (v 0 (truncate m 3)) (width-of g) (truncate (height-of g) 2) *window-color* :style :sunken) (draw-frame kpos sw m *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1)) - (draw-line (v+ kpos (v (truncate sw 2) 0)) - (v+ kpos (v (truncate sw 2) (/ m 8))) - 255 255 255 128) - (draw-line (v+ kpos (v (truncate sw 2) (- m (/ m 8)))) - (v+ kpos (v (truncate sw 2) m)) - 0 0 0 128 :size 2) + (draw-frame (v+ kpos (v (truncate sw 2) 0)) 3 m '(0 0 0 0) :style :sunken :fill nil) + + (with-blend (:color *widget-color*) + (draw-text vt (v+ (v+ kpos (get-text-offset)) (v 1 1)))) (with-blend (:color *text-color*) (draw-text vt (v+ kpos (get-text-offset)))))) @@ -173,7 +203,7 @@ (:default-initargs :width (truncate (get-m) 2) :y-expand-p t)) (defmethod (setf value-of) (value (g v-slider)) - (setf (slot-value g 'value) (clamp (min-value-of g) value (- (max-value-of g) (page-size-of g))))) + (setf (slot-value g 'value) (clamp (min-value-of g) value (- (max-value-of g) (funcall (page-size-of g)))))) (defmethod on-drag ((g v-slider) start-pos delta) @@ -182,14 +212,18 @@ (defmethod repaint ((g v-slider)) (let* ((units (abs (- (min-value-of g) (max-value-of g)))) + (ps (funcall (page-size-of g))) (usize (/ (height-of g) units)) (k (truncate (* usize (- (value-of g) (min-value-of g))))) - (kpos (v+ (pos-of g) (v 0 k)))) - (draw-frame (pos-of g) (width-of g) (height-of g) *window-color* :style :sunken) + (kpos (v 0 k))) + (draw-frame (v 0 0) (width-of g) (height-of g) *window-color* :style :sunken) (draw-frame kpos (width-of g) - (min (height-of g) (- (height-of g) (* (- units (page-size-of g)) usize))) - *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1)))) + (min (height-of g) (- (height-of g) (* (- units ps) usize))) + *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1)) + (draw-frame (v+ kpos (v 1 (1- (truncate (min (height-of g) (- (height-of g) (* (- units ps) usize))) 2)))) + (- (width-of g) 2) + 3 '(255 255 255 0) :style :sunken))) @@ -209,13 +243,15 @@ (setf (slot-value g 'value) (clamp (min-value-of g) value (max-value-of g)))) (defmethod repaint ((g h-meter)) - (let* ((m (get-m)) - (k (truncate (* (/ (width-of g) (abs (- (min-value-of g) (max-value-of g)))) (- (value-of g) (min-value-of g))))) ) - (draw-frame (pos-of g) (width-of g) (height-of g) *window-color* :style :sunken) - (loop for x from 0 to k by 2 do - (draw-line (v+ (pos-of g) (v x 1)) (v+ (pos-of g) (v x (1- m))) 148 148 148 255)) - (with-blend (:color *text-color*) - (draw-text (funcall (display-fn-of g) (value-of g)) (v+ (pos-of g) (get-text-offset)))))) + (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 by 2 do + (draw-line (v x 1) (v x (1- height)) 148 148 148 255)) + (with-blend (:color *widget-color*) + (draw-text (display-value g) (v+ (v 1 1) (get-text-offset)))) + (with-blend (:color *text-color*) + (draw-text (display-value g) (get-text-offset)))))) @@ -224,19 +260,19 @@ ((items :accessor items-of :initarg :items :initform '()) (scroll :accessor scroll-of :initform 0) (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) - (:default-initargs :x-expand-p t)) + (:default-initargs :x-expand-p t :y-expand-p t)) (defmethod repaint ((g list-view)) - (with-accessors ((width width-of) (height height-of) (pos pos-of) (ap absolute-pos-of)) g - (draw-frame pos width height *paper-color* :style :sunken) + (with-accessors ((width width-of) (height height-of) (ap absolute-pos-of)) g + (draw-frame (v 0 0) width height *paper-color* :style :sunken) (with-clipping ((vx ap) (vy ap) width height) (with-blend (:color *text-color*) (let ((y 0)) (dolist (i (items-of g)) (when (oddp y) - (draw-rectangle (v+ pos (v 0 (- (* y (get-m)) (scroll-of g)))) width (get-m) 0 0 0 32)) - (draw-text (display-value g i) (v+ (v+ pos (get-text-offset)) (v 0 (- (* y (get-m)) (scroll-of g))))) + (draw-rectangle (v 0 (- (* y (get-m)) (scroll-of g))) width (get-m) 0 0 0 32)) + (draw-text (display-value g i) (v+ (get-text-offset) (v 0 (- (* y (get-m)) (scroll-of g))))) (incf y))))))) @@ -247,11 +283,10 @@ (:default-initargs :gap 3 :xpad 0 :ypad 0 :y-expand-p t :x-expand-p t)) (defmethod initialize-instance :after ((g list-box) &key items &allow-other-keys) - (let* ((lv (make-instance 'list-view :items items :parent g :height (height-of g) :width (width-of g)))) + (let* ((lv (make-instance 'list-view :items items :parent g))) (make-instance 'v-slider :parent g :max-value (* (get-m) (length items)) - :height (height-of g) - :page-size (height-of lv) + :page-size (lambda () (height-of lv)) :on-drag (lambda (g pos d) (declare (ignore pos d)) (setf (scroll-of lv) (value-of g)) From tneste at common-lisp.net Wed Oct 17 17:02:52 2007 From: tneste at common-lisp.net (tneste) Date: Wed, 17 Oct 2007 13:02:52 -0400 (EDT) Subject: [pal-cvs] CVS pal-gui/examples Message-ID: <20071017170252.38E8B68230@common-lisp.net> Update of /project/pal/cvsroot/pal-gui/examples In directory clnet:/tmp/cvs-serv31543/examples Modified Files: test.lisp Log Message: --- /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/16 21:46:09 1.5 +++ /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/17 17:02:52 1.6 @@ -1,3 +1,10 @@ +;; TODO: +;; +;; Exports, gob picking, packing, destroy gob, window sizing, box labels, dialogs, menus, tooltips, keyboard control, scrollwheel +;; label, radio box, check box, joystick, scroll box, fix listbox, fix gauge, paragraph, text box, simple editor, drop box. +;; File open/save, directory, yes/no dialogs + + (in-package :pal-gui) (define-tags plane (load-image "lego-plane.png") @@ -9,24 +16,24 @@ (window-2 (make-instance 'window :width 200 :height 300)) (box (make-instance 'h-box :parent window)) - (right-box (make-instance 'v-box :parent box)) - (left-box (make-instance 'v-box :parent box)) - (bottom-box (make-instance 'v-box :parent window)) + (left-box (make-instance 'v-box :parent box :label "RGBA")) + (right-box (make-instance 'v-box :parent box :label "Current FPS")) + (bottom-box (make-instance 'v-box :parent window :label "Bar")) - (meter (make-instance 'h-meter :parent right-box :max-value 80 :display-fn (lambda (v) (format nil "FPS: ~a" v)))) + (meter (make-instance 'h-meter :parent right-box :max-value 100)) (rg (make-instance 'h-gauge :parent left-box - :min-value 0 :max-value 255 :value 0 :display-fn (lambda (v) (format nil "R: ~a" v)))) + :min-value 0 :max-value 255 :value 0)) (gg (make-instance 'h-gauge :parent left-box - :min-value 0 :max-value 255 :value 0 :display-fn (lambda (v) (format nil "G: ~a" v)))) + :min-value 0 :max-value 255 :value 0)) (bg (make-instance 'h-gauge :parent left-box - :min-value 0 :max-value 255 :value 0 :display-fn (lambda (v) (format nil "B: ~a" v)))) + :min-value 0 :max-value 255 :value 0)) (ag (make-instance 'h-gauge :parent left-box - :min-value 0 :max-value 255 :value 0 :display-fn (lambda (v) (format nil "A: ~a" v)))) + :min-value 0 :max-value 255 :value 0)) (list (make-instance 'list-box :parent window-2 :items (loop for i from 0 to 100 collect (format nil "FooBar ~a" i)))) (button (make-instance 'button :value "FooBar!" :parent window-2 :on-select (lambda (g pos) (message 'foo) t))) ) - (make-instance 'button :value "Button" :parent bottom-box) + ;; (make-instance 'button :value "Button" :parent bottom-box) (gui-loop () (setf (value-of meter) (get-fps)) @@ -34,6 +41,7 @@ (with-blend (:color '(0 0 0 64)) (draw-image (tag 'plane) (v 320 220))) (with-blend (:color (list (value-of rg) (value-of gg) (value-of bg) (value-of ag))) - (draw-image (tag 'plane) (v 300 200))))))) + (draw-image (tag 'plane) (v 300 200))) + )))) ;; (test) \ No newline at end of file From tneste at common-lisp.net Wed Oct 17 17:02:52 2007 From: tneste at common-lisp.net (tneste) Date: Wed, 17 Oct 2007 13:02:52 -0400 (EDT) Subject: [pal-cvs] CVS pal-gui Message-ID: <20071017170252.7064A68232@common-lisp.net> Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv31543 Modified Files: gob.lisp widgets.lisp Log Message: --- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/16 21:46:09 1.5 +++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/17 17:02:52 1.6 @@ -17,7 +17,8 @@ (y-expand-p :accessor y-expand-p :initform nil :initarg :y-expand-p) (activep :accessor activep :initform t :initarg :activep) (width :accessor width-of :initarg :width :initform 0) - (height :accessor height-of :initarg :height :initform 0))) + (height :accessor height-of :initarg :height :initform 0) + (childs :reader childs-of :initform nil))) (defmethod initialize-instance :after ((g gob) &key (parent *root*) &allow-other-keys) @@ -27,7 +28,8 @@ (defgeneric repaint (gob)) (defmethod repaint :around ((g gob)) (with-transformation (:pos (pos-of g)) - (call-next-method))) + (call-next-method) + (repaint-childs g))) (defgeneric lower (gob)) (defmethod lower ((g gob)) @@ -74,6 +76,10 @@ (defmethod on-select ((gob gob) pos) nil) +(defgeneric on-destroy (gob)) +(defmethod on-destroy ((gob gob)) + nil) + (defgeneric on-drag (gob start-pos delta-pos)) (defmethod on-drag ((gob gob) start-pos delta) (declare (ignore start-pos delta)) @@ -90,59 +96,53 @@ +(defgeneric pack (gob)) +(defmethod pack ((g gob)) + (declare (ignore g)) + nil) -(defclass containing () - ((childs :reader childs-of :initform nil)) - (:default-initargs :activep nil)) - - -(defmethod repaint :around ((g containing)) - (call-next-method) - (repaint-childs g)) - -(defgeneric pack (containing)) -(defmethod pack ((g containing)) - (when (parent-of g) - (pack (parent-of g)))) - -(defgeneric repaint-childs (container)) -(defmethod repaint-childs ((g containing)) +(defgeneric repaint-childs (gob)) +(defmethod repaint-childs ((g gob)) (dolist (c (childs-of g)) (repaint c))) (defgeneric adopt (parent child)) -(defmethod adopt ((parent containing) (child gob)) +(defmethod adopt ((parent gob) (child gob)) (setf (slot-value child 'parent) parent) (push child (slot-value parent 'childs))) (defgeneric abandon (parent child)) -(defmethod abandon ((parent containing) (child gob)) +(defmethod abandon ((parent gob) (child gob)) (setf (slot-value parent 'childs) (remove child (slot-value parent 'childs)) (parent-of child) nil)) (defgeneric (setf parent-of) (parent child)) -(defmethod (setf parent-of) ((parent containing) (child gob)) +(defmethod (setf parent-of) ((parent gob) (child gob)) (when (parent-of child) (abandon (parent-of child) child)) (adopt parent child)) -(defgeneric min-height-of (containing)) -(defmethod min-height-of ((g containing)) - (+ (* (length (childs-of g)) (gap-of g)) - (loop for c in (childs-of g) summing (if (y-expand-p c) 0 (if (typep c 'containing) - (min-height-of c) - (height-of c)))))) -(defgeneric min-width-of (containing)) -(defmethod min-width-of ((g containing)) - (+ (* (length (childs-of g)) (gap-of g)) - (loop for c in (childs-of g) summing (if (x-expand-p c) 0 (if (typep c 'containing) - (min-width-of c) - (width-of c)))))) +(defgeneric min-height-of (gob)) +(defmethod min-height-of ((g gob)) + (if (childs-of g) + (+ (* (length (childs-of g)) (gap-of g)) + (loop for c in (childs-of g) summing (if (y-expand-p c) 0 (min-height-of c)))) + (height-of g))) + +(defgeneric min-width-of (gob)) +(defmethod min-width-of ((g gob)) + (if (childs-of g) + (+ (* (length (childs-of g)) (gap-of g)) + (loop for c in (childs-of g) summing (if (x-expand-p c) 0 (min-width-of c)))) + (width-of g))) + + + -(defclass v-packing (containing) +(defclass v-packing (gob) ((xpad :accessor xpad-of :initarg :xpad :initform 0) (ypad :accessor ypad-of :initarg :ypad :initform 0) (gap :accessor gap-of :initarg :gap :initform 0))) @@ -165,8 +165,7 @@ (setf (height-of c) (max 10 (truncate exp-size exp-count)))) (when (x-expand-p c) (setf (width-of c) (- width (* 2 xpad)))) - (when (typep c 'containing) - (pack c)))) + (pack c))) (let ((cpos (v xpad ypad))) (dolist (c (reverse childs)) (setf (pos-of c) cpos) @@ -190,8 +189,7 @@ (setf (width-of c) (max 10 (truncate exp-size exp-count)))) (when (y-expand-p c) (setf (height-of c) (- height (* 2 ypad)))) - (when (typep c 'containing) - (pack c)))) + (pack c))) (let ((cpos (v xpad ypad))) (dolist (c (reverse childs)) (setf (pos-of c) cpos) @@ -230,7 +228,7 @@ -(defclass root (gob containing) +(defclass root (gob) () (:default-initargs :width (get-screen-width) :height (get-screen-height) :pos (v 0 0) :parent nil)) --- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/16 21:46:09 1.5 +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/17 17:02:52 1.6 @@ -43,14 +43,33 @@ (draw-line (v+ pos (v (- width 1) (- height 1))) (v+ pos (v width 0)) 255 255 255 128) (draw-line (v+ pos (v width (- height 1))) (v+ pos (v 0 height)) 255 255 255 128))))) -(defun display-value (widget &optional value) - (funcall (display-fn-of widget) (or value (value-of widget)))) + + + +(defgeneric present (object gob width height)) + +(defmethod present :around (object (g gob) width height) + (let ((ap (absolute-pos-of g))) + (with-clipping ((1+ (vx ap)) (1+ (vy ap)) (- (width-of g) 2) (- (height-of g) 2)) + (call-next-method)))) + +(defmethod present (object (g gob) width height) + (with-blend (:color *text-color*) + (draw-text (format nil "~a" object) (get-text-offset)))) + + (defclass widget (gob) ((on-drag :accessor on-drag-of :initarg :on-drag :initform (lambda (widget pos d) (declare (ignore widget pos d)) nil)) - (on-select :accessor on-select-of :initarg :on-select :initform (lambda (widget pos) (declare (ignore widget pos)) nil))) + (on-select :accessor on-select-of :initarg :on-select :initform (lambda (widget pos) (declare (ignore widget pos)) nil)) + (on-button-down :accessor on-button-down-of :initarg :on-button-down-select :initform (lambda (widget pos) (declare (ignore widget pos)) nil)) + (on-button-up :accessor on-button-up-of :initarg :on-button-up-select :initform (lambda (widget pos) (declare (ignore widget pos)) 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)) + (on-destroy :accessor on-destroy-of :initarg :on-destroy :initform (lambda (widget) (declare (ignore widget)) nil))) + (:default-initargs :width (get-m) :height (get-m))) (defmethod on-drag :around ((g widget) pos d) @@ -61,35 +80,55 @@ (unless (funcall (on-select-of g) g pos) (call-next-method))) +(defmethod on-button-down :around ((g widget) pos) + (unless (funcall (on-button-down-of g) g pos) + (call-next-method))) +(defmethod on-button-up :around ((g widget) pos) + (unless (funcall (on-button-up-of g) g pos) + (call-next-method))) +(defmethod on-enter :around ((g widget)) + (unless (funcall (on-enter-of g) g) + (call-next-method))) -(defclass box (widget containing) - () +(defmethod on-leave :around ((g widget)) + (unless (funcall (on-leave-of g) g) + (call-next-method))) + +(defmethod on-destroy :around ((g widget)) + (unless (funcall (on-destroy-of g)) + (call-next-method))) + + + + +(defclass box (widget) + ((label :accessor label-of :initform nil :initarg :label)) (:default-initargs :activep nil :x-expand-p t :y-expand-p t)) +(defmethod initialize-instance :after ((g box) &key label) + (when label + (setf (ypad-of g) (truncate (get-m) 2) + (xpad-of g) (truncate (get-m) 2)))) + (defmethod repaint ((g box)) - (declare (ignore g)) - ;; (draw-rectangle (pos-of g) (width-of g) (height-of g) 0 0 0 64 :fill nil) - ) + (when (label-of g) + (draw-rectangle (v 0 0) (width-of g) (height-of g) 0 0 0 128 :fill nil) + (with-blend (:color *text-color*) + (draw-text (label-of g) (v- (get-text-offset) (v 0 (truncate (get-m) 2))))))) -(defclass v-box (widget v-packing) - () - (:default-initargs :activep nil :x-expand-p t :y-expand-p t :xpad 0 :ypad 0 :gap (truncate (get-m) 3))) -(defmethod repaint ((g v-box)) - (declare (ignore g)) - ;; (draw-rectangle (pos-of g) (width-of g) (height-of g) 0 0 0 64 :fill nil) - ) -(defclass h-box (widget h-packing) +(defclass v-box (box v-packing) () - (:default-initargs :activep nil :x-expand-p t :y-expand-p t :xpad 0 :ypad 0 :gap (truncate (get-m) 1))) + (:default-initargs :xpad 0 :ypad 0 :gap (truncate (get-m) 3))) -(defmethod repaint ((g h-box)) - (declare (ignore g)) - ;; (draw-rectangle (pos-of g) (width-of g) (height-of g) 0 0 0 64 :fill nil) - ) + + +(defclass h-box (box h-packing) + () + (:default-initargs :xpad 0 :ypad 0 :gap (truncate (get-m) 2))) @@ -112,48 +151,48 @@ (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)) + (call-next-method))) + (defmethod on-button-down ((g window) pos) - (declare (ignore pos)) - (raise g)) + (when (< (vy pos) (get-m)) + (raise g))) (defmethod repaint ((g window)) - (let ((th 6)) - (draw-rectangle (v 6 6) (width-of g) (height-of g) 0 0 0 64) - (draw-frame (v 0 0) (width-of g) (height-of g) *window-color* :style :raised) - (draw-rectangle (v 0 0) (width-of g) (get-m) 0 0 0 64) - (draw-line (v 0 (get-m)) (v (width-of g) (get-m)) 0 0 0 160) - (draw-line (v 0 (1+ (get-m))) (v (width-of g) (1+ (get-m))) 0 0 0 64) - (draw-text (label-of g) (get-text-offset)))) + (with-accessors ((width width-of) (height height-of) (label label-of)) g + (draw-rectangle (v 6 6) width height 0 0 0 64) + (draw-frame (v 0 0) width height *window-color* :style :raised) + (draw-rectangle (v 0 0) width (get-m) 0 0 0 64) + (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) + (with-blend (:color '(255 255 255 255)) + (draw-text label (get-text-offset))))) (defclass button (widget) - ((color :accessor color-of :initform *widget-color* :initarg :color) - (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v))) - (value :accessor value-of :initform "" :initarg :value)) + ((value :accessor value-of :initform "" :initarg :value)) (:default-initargs :x-expand-p t)) (defmethod repaint ((g button)) - (let ((color (color-of g)) - (value (display-value g)) - (fpos (get-text-offset))) + (with-accessors ((width width-of) (height height-of) (value value-of)) g (cond ((armedp g) - (draw-frame (v 0 0) (width-of g) (height-of g) color :style :sunken :border 2) + (draw-frame (v 0 0) width height *widget-color* :style :sunken :border 2) (with-blend (:color *text-color*) - (draw-text value (v+ fpos (v 1 1))) - )) + (present value g width height))) ((pointedp g) - (draw-frame (v 0 0) (width-of g) (height-of g) color :border 2 :style :raised) + (draw-frame (v 0 0) width height *widget-color* :border 2 :style :raised) (with-blend (:color *text-color*) - (draw-text value fpos) - )) + (present value g width height))) (t - (draw-frame (v 0 0) (width-of g) (height-of g) color :style :raised) + (draw-frame (v 0 0) width height *widget-color* :style :raised) (with-blend (:color *text-color*) - (draw-text value fpos)))))) + (present value g width height)))))) @@ -162,8 +201,7 @@ (defclass h-gauge (widget) ((value :reader value-of :initarg :value :initform 0) (min-value :accessor min-value-of :initarg :min-value :initform 0) - (max-value :accessor max-value-of :initarg :max-value :initform 100) - (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) + (max-value :accessor max-value-of :initarg :max-value :initform 100)) (:default-initargs :x-expand-p t)) (defmethod (setf value-of) (value (g h-gauge)) @@ -175,20 +213,18 @@ (setf (value-of g) (+ (truncate x (/ (width-of g) (abs (- (min-value-of g) (max-value-of g))))) (min-value-of g))))) (defmethod repaint ((g h-gauge)) - (let* ((vt (display-value g)) - (sw (get-text-bounds vt)) - (m (get-m)) - (k (truncate (* (/ (width-of g) (abs (- (min-value-of g) (max-value-of g)))) (- (value-of g) (min-value-of g))))) - (kpos (v (- k (truncate sw 2)) 0))) - (draw-frame (v 0 (truncate m 3)) (width-of g) (truncate (height-of g) 2) *window-color* :style :sunken) - - (draw-frame kpos sw m *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1)) - (draw-frame (v+ kpos (v (truncate sw 2) 0)) 3 m '(0 0 0 0) :style :sunken :fill nil) - - (with-blend (:color *widget-color*) - (draw-text vt (v+ (v+ kpos (get-text-offset)) (v 1 1)))) - (with-blend (:color *text-color*) - (draw-text vt (v+ kpos (get-text-offset)))))) + (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 :border (if (or (armedp g) (pointedp g)) 2 1)) + (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))))))) @@ -211,19 +247,19 @@ (setf (value-of g) (+ (truncate y (/ (height-of g) (abs (- (min-value-of g) (max-value-of g))))) (min-value-of g))))) (defmethod repaint ((g v-slider)) - (let* ((units (abs (- (min-value-of g) (max-value-of g)))) - (ps (funcall (page-size-of g))) - (usize (/ (height-of g) units)) - (k (truncate (* usize (- (value-of g) (min-value-of g))))) - (kpos (v 0 k))) - (draw-frame (v 0 0) (width-of g) (height-of g) *window-color* :style :sunken) - (draw-frame kpos - (width-of g) - (min (height-of g) (- (height-of g) (* (- units ps) usize))) - *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1)) - (draw-frame (v+ kpos (v 1 (1- (truncate (min (height-of g) (- (height-of g) (* (- units ps) usize))) 2)))) - (- (width-of g) 2) - 3 '(255 255 255 0) :style :sunken))) + (with-accessors ((height height-of) (width width-of) (page-size page-size-of) (value value-of) (min-value min-value-of) (max-value max-value-of)) g + (let* ((units (abs (- min-value max-value))) + (ps (funcall page-size)) + (usize (/ height units)) + (k (truncate (* usize (- value min-value)))) + (kpos (v 0 k))) + (draw-frame (v 0 0) width height *window-color* :style :sunken) + (draw-frame kpos width + (min height (- height (* (- units ps) usize))) + *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1)) + (draw-frame (v+ kpos (v 1 (1- (truncate (min height (- height (* (- units ps) usize))) 2)))) + (- width 2) + 3 '(255 255 255 0) :style :sunken)))) @@ -235,8 +271,7 @@ (defclass h-meter (widget) ((value :reader value-of :initarg :value :initform 0) (min-value :accessor min-value-of :initarg :min-value :initform 0) - (max-value :accessor max-value-of :initarg :max-value :initform 100) - (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) + (max-value :accessor max-value-of :initarg :max-value :initform 100)) (:default-initargs :activep nil :x-expand-p t)) (defmethod (setf value-of) (value (g h-meter)) @@ -246,52 +281,50 @@ (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 by 2 do + (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 (display-value g) (v+ (v 1 1) (get-text-offset)))) + (draw-text (princ-to-string value) (v+ (v 1 1) (get-text-offset)))) (with-blend (:color *text-color*) - (draw-text (display-value g) (get-text-offset)))))) + (draw-text (princ-to-string value) (get-text-offset)))))) (defclass list-view (widget) ((items :accessor items-of :initarg :items :initform '()) - (scroll :accessor scroll-of :initform 0) - (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))) + (item-height :accessor item-height-of :initarg :item-height :initform (get-m)) + (scroll :accessor scroll-of :initform 0)) (:default-initargs :x-expand-p t :y-expand-p t)) (defmethod repaint ((g list-view)) - (with-accessors ((width width-of) (height height-of) (ap absolute-pos-of)) g + (with-accessors ((width width-of) (height height-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-blend (:color *text-color*) - (let ((y 0)) - (dolist (i (items-of g)) - (when (oddp y) - (draw-rectangle (v 0 (- (* y (get-m)) (scroll-of g))) width (get-m) 0 0 0 32)) - (draw-text (display-value g i) (v+ (get-text-offset) (v 0 (- (* y (get-m)) (scroll-of g))))) - (incf y))))))) + (with-transformation (:pos (v 0 (scroll-of g))) + (let ((y 0)) + (dolist (i (items-of g)) + (when (oddp y) + (draw-rectangle (v 0 0) width item-height 0 0 0 32)) + (present i g width item-height) + (translate (v 0 item-height)) + (incf y)))))))) -(defclass list-box (widget h-packing) +(defclass list-box (h-box) () (:default-initargs :gap 3 :xpad 0 :ypad 0 :y-expand-p t :x-expand-p t)) -(defmethod initialize-instance :after ((g list-box) &key items &allow-other-keys) - (let* ((lv (make-instance 'list-view :items items :parent g))) +(defmethod initialize-instance :after ((g list-box) &key items (item-height (get-m)) &allow-other-keys) + (let* ((lv (make-instance 'list-view :items items :item-height item-height :parent g))) (make-instance 'v-slider :parent g - :max-value (* (get-m) (length items)) + :max-value (* item-height (length items)) :page-size (lambda () (height-of lv)) :on-drag (lambda (g pos d) (declare (ignore pos d)) (setf (scroll-of lv) (value-of g)) - nil)))) - -(defmethod repaint ((g list-box)) - (declare (ignore g)) - nil) \ No newline at end of file + nil)))) \ No newline at end of file From tneste at common-lisp.net Thu Oct 18 16:39:13 2007 From: tneste at common-lisp.net (tneste) Date: Thu, 18 Oct 2007 12:39:13 -0400 (EDT) Subject: [pal-cvs] CVS pal/documentation Message-ID: <20071018163913.4CD6774386@common-lisp.net> Update of /project/pal/cvsroot/pal/documentation In directory clnet:/tmp/cvs-serv16317/documentation Log Message: Directory /project/pal/cvsroot/pal/documentation added to the repository From tneste at common-lisp.net Thu Oct 18 16:41:01 2007 From: tneste at common-lisp.net (tneste) Date: Thu, 18 Oct 2007 12:41:01 -0400 (EDT) Subject: [pal-cvs] CVS pal Message-ID: <20071018164101.1564B74393@common-lisp.net> Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv18242 Modified Files: package.lisp Log Message: Added the manual. Removed few unnecessarily exported functions. --- /project/pal/cvsroot/pal/package.lisp 2007/09/07 07:55:16 1.17 +++ /project/pal/cvsroot/pal/package.lisp 2007/10/18 16:41:01 1.18 @@ -366,7 +366,6 @@ #:close-pal #:get-gl-info #:load-foreign-libraries - #:register-resource #:free-resource #:free-all-resources #:define-tags @@ -416,8 +415,6 @@ #:set-blend-color #:with-blend #:with-clipping - #:push-clip - #:pop-clip #:update-screen #:image-from-array From tneste at common-lisp.net Thu Oct 18 16:41:02 2007 From: tneste at common-lisp.net (tneste) Date: Thu, 18 Oct 2007 12:41:02 -0400 (EDT) Subject: [pal-cvs] CVS pal/documentation Message-ID: <20071018164102.C30CC74393@common-lisp.net> Update of /project/pal/cvsroot/pal/documentation In directory clnet:/tmp/cvs-serv18242/documentation Added Files: pal-manual.lyx Log Message: Added the manual. Removed few unnecessarily exported functions. --- /project/pal/cvsroot/pal/documentation/pal-manual.lyx 2007/10/18 16:41:02 NONE +++ /project/pal/cvsroot/pal/documentation/pal-manual.lyx 2007/10/18 16:41:02 1.1 #LyX 1.4.4 created this file. For more info see http://www.lyx.org/ \lyxformat 245 \begin_document \begin_header \textclass article \language english \inputencoding auto \fontscheme default \graphics default \paperfontsize default \papersize default \use_geometry false \use_amsmath 1 \cite_engine basic \use_bibtopic false \paperorientation portrait \secnumdepth 3 \tocdepth 3 \paragraph_separation indent \defskip medskip \quotes_language english \papercolumns 1 \papersides 1 \paperpagestyle default \tracking_changes false \output_changes false \end_header \begin_body \begin_layout Title Pixel Art Library \end_layout \begin_layout Author Tomi Neste tneste at common-lisp.net \end_layout \begin_layout Standard \newpage \end_layout \begin_layout Quote Pixel Art Library is published under the MIT license \end_layout \begin_layout Quote Copyright (c) 2006 Tomi Neste \end_layout \begin_layout Quote Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), 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: \end_layout \begin_layout Quote The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. \end_layout \begin_layout Quote THE SOFTWARE IS PROVIDED "AS IS", 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_layout \begin_layout Standard \newpage \end_layout \begin_layout Standard \begin_inset LatexCommand \tableofcontents{} \end_inset \end_layout \begin_layout Standard \newpage \end_layout \begin_layout Section Introduction and installation \end_layout \begin_layout Subsection What is Pixel Art Library \end_layout \begin_layout Standard 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. \end_layout \begin_layout Standard PAL's design goals are ease of use, portability and reliability. It tries to provide all the \emph on common \emph default 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. \end_layout \begin_layout Subsection Requirements \end_layout \begin_layout Itemize 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 on Note: These come with their own license. \end_layout \begin_layout Itemize 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. \end_layout \begin_layout Itemize For interfacing with the foreign libraries PAL uses the excellent CFFI library. It's available from http://common-lisp.net/project/cffi \end_layout \begin_layout Itemize 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. \end_layout \begin_layout Itemize To get anywhere near reasonable performance you need a graphics card and driver that is capable of hardware accelerated OpenGL graphics. \end_layout \begin_layout Subsection Installation \end_layout \begin_layout Standard After installing CFFI (and possibly ASDF) and downloading and unpacking PAL you should \end_layout \begin_layout Itemize Under Windows copy the .dlls to somewhere where they can be found, for example in your Lisp implementations home folder. \end_layout \begin_layout Itemize Under Linux, check that the SDL, SDL_mixer and SDL_image packages are installed. \end_layout \begin_layout Itemize 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 \end_layout \begin_layout Itemize 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. \end_layout \begin_layout Itemize If everything went fine you can now try your first PAL program, enter in the following: \end_layout \begin_layout Quotation \family typewriter (with-pal (:title \begin_inset Quotes eld \end_inset PAL test \begin_inset Quotes erd \end_inset ) \end_layout \begin_layout Quotation \family typewriter \InsetSpace ~ \InsetSpace ~ (clear-screen 255 255 0) \end_layout \begin_layout Quotation \family typewriter \InsetSpace ~ \InsetSpace ~ (with-transformation (:pos (v 400 300) :angle 45f0 :scale 4f0) \end_layout \begin_layout Quotation \family typewriter \InsetSpace ~ \InsetSpace ~ \InsetSpace ~ \InsetSpace ~ (draw-text \begin_inset Quotes eld \end_inset Hello World! \begin_inset Quotes erd \end_inset (v 0 0)) \end_layout \begin_layout Quotation \family typewriter \InsetSpace ~ \InsetSpace ~ \InsetSpace ~ \InsetSpace ~ (wait-keypress))) \end_layout \begin_layout Standard \newpage \end_layout \begin_layout Section Opening and closing PAL and handling resources \end_layout \begin_layout Subsection OPEN-PAL \end_layout \begin_layout Subsection CLOSE-PAL \end_layout \begin_layout Subsection WITH-PAL \end_layout \begin_layout Subsection LOAD-FOREIGN-LIBRARIES \end_layout \begin_layout Subsection FREE-RESOURCE \end_layout \begin_layout Subsection FREE-ALL-RESOURCES \end_layout \begin_layout Subsection WITH-RESOURCE \end_layout \begin_layout Subsection GET-SCREEN-WIDTH, GET-SCREEN-HEIGHT \end_layout \begin_layout Standard \newpage \end_layout \begin_layout Section Event handling \end_layout \begin_layout Subsection HANDLE-EVENTS \end_layout \begin_layout Subsection EVENT-LOOP \end_layout \begin_layout Subsection GET-MOUSE-POS, GET-MOUSE-X, GET-MOUSE-Y \end_layout \begin_layout Subsection KEY-PRESSED-P \end_layout \begin_layout Subsection TEST-KEYS \end_layout \begin_layout Subsection KEYSYM-CHAR \end_layout \begin_layout Subsection WAIT-KEYPRESS \end_layout \begin_layout Subsection UPDATE-SCREEN \end_layout \begin_layout Standard \newpage \end_layout \begin_layout Section Images and drawing \end_layout \begin_layout Subsection CLEAR-SCREEN \end_layout \begin_layout Subsection DRAW-POINT \end_layout \begin_layout Subsection DRAW-LINE \end_layout \begin_layout Subsection DRAW-ARROW \end_layout \begin_layout Subsection LOAD-IMAGE \end_layout \begin_layout Subsection IMAGE-WIDTH, IMAGE-HEIGHT \end_layout \begin_layout Subsection DRAW-IMAGE \end_layout \begin_layout Subsection DRAW-IMAGE* \end_layout \begin_layout Subsection DRAW-RECTANGLE \end_layout \begin_layout Subsection DRAW-CIRCLE \end_layout \begin_layout Subsection DRAW-POLYGON \end_layout \begin_layout Subsection DRAW-POLYGON* [288 lines skipped] From tneste at common-lisp.net Thu Oct 18 19:29:56 2007 From: tneste at common-lisp.net (tneste) Date: Thu, 18 Oct 2007 15:29:56 -0400 (EDT) Subject: [pal-cvs] CVS pal/documentation Message-ID: <20071018192956.54BD749112@common-lisp.net> Update of /project/pal/cvsroot/pal/documentation In directory clnet:/tmp/cvs-serv9747 Modified Files: pal-manual.lyx Added Files: pal-manual.pdf Log Message: Updated the manual --- /project/pal/cvsroot/pal/documentation/pal-manual.lyx 2007/10/18 16:41:02 1.1 +++ /project/pal/cvsroot/pal/documentation/pal-manual.lyx 2007/10/18 19:29:56 1.2 @@ -269,77 +269,1391 @@ \end_layout \begin_layout Subsection -OPEN-PAL +Introduction \end_layout \begin_layout Subsection -CLOSE-PAL +Functions +\end_layout + +\begin_layout Description +OPEN-PAL (&key +\shape italic +width height fps title fullscreenp paths +\shape default +) +\end_layout + +\begin_layout Standard +Opens and initialises PAL window. +\end_layout + +\begin_layout Description + +\shape italic +width +\shape default +, width of the screen. +\end_layout + +\begin_layout Description + +\shape italic +height +\shape default +, height of the screen. + If width and height are 0 then the default desktop dimensions are used. +\end_layout + +\begin_layout Description + +\shape italic +fps +\shape default +, maximum number of times per second that the screen is updated. +\end_layout + +\begin_layout Description + +\shape italic +title +\shape default +, title of the screen. +\end_layout + +\begin_layout Description + +\shape italic +fullscreenp +\shape default +, open in windowed or fullscreen mode. +\end_layout + +\begin_layout Description + +\shape italic +paths +\shape default +, pathname or list of pathnames that the load-* functions use to find resources. + Initially holds *default-pathname-defauls* and PAL installation directory. +\end_layout + +\begin_layout Description +CLOSE-PAL () +\end_layout + +\begin_layout Standard +Closes PAL screen and frees all loaded resources. +\end_layout + +\begin_layout Description +WITH-PAL (&key +\shape italic +width height fps title fullscreenp paths +\shape default + &body +\shape italic +body +\shape default +) +\end_layout + +\begin_layout Standard +Opens PAL, executes +\shape italic +body +\shape default + and finally closes PAL. + Arguments are same as with OPEN-PAL. +\end_layout + +\begin_layout Description +FREE-RESOURCE ( +\shape italic +resource +\shape default +) +\end_layout + +\begin_layout Standard +Frees the +\shape italic +resource +\shape default + (image, font, sample or music). +\end_layout + +\begin_layout Description +FREE-ALL-RESOURCES () +\end_layout + +\begin_layout Standard +Frees all allocated resources. +\end_layout + +\begin_layout Description +WITH-RESOURCE ( +\shape italic +var init-form +\shape default +) &body +\shape italic +body +\end_layout + +\begin_layout Standard +Binds +\shape italic +var +\shape default + to the result of +\shape italic +init-form +\shape default + and executes +\shape italic +body +\shape default +. + Finally calls FREE-RESOURCE on +\shape italic +var. +\end_layout + +\begin_layout Description +GET-SCREEN-WIDTH () => +\shape italic +number +\end_layout + +\begin_layout Description +GET-SCREEN-HEIGHT () => +\shape italic +number +\end_layout + +\begin_layout Standard +Returns the dimensions of PAL screen. +\end_layout + +\begin_layout Standard + +\newpage + +\end_layout + +\begin_layout Section +Event handling +\end_layout + +\begin_layout Subsection +Introduction +\end_layout + +\begin_layout Standard +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. +\end_layout + +\begin_layout Standard +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. +\end_layout + +\begin_layout Subsection +Functions +\end_layout + +\begin_layout Description +HANDLE-EVENTS (&key +\shape italic +key-up-fn key-down-fn mouse-motion-fn quit-fn +\shape default +) +\end_layout + +\begin_layout Standard +Get next event, if any, and call appropriate handler function. +\end_layout + +\begin_layout Description + +\shape italic +key-up-fn +\shape default +, called with the released key-sym. + For key-syms see chapter 3.3 +\end_layout + +\begin_layout Description + +\shape italic +key-down-fn +\shape default +, called with the pressed key-sym. + When +\shape italic +key-down-fn +\shape default + is not defined pressing Esc-key causes a quit event. +\end_layout + +\begin_layout Description + +\shape italic +mouse-motion-fn +\shape default +, called with x and y mouse coordinates. +\end_layout + +\begin_layout Description + +\shape italic +quit-fn +\shape default +, called without any arguments when user presses the windows close button. + Also called when Esc key is pressed, unless +\shape italic +key-down-fn +\shape default + is defined. +\end_layout + +\begin_layout Description +UPDATE-SCREEN () +\end_layout + +\begin_layout Standard +Updates the PAL screen. + No output is visible until UPDATE-SCREEN is called. + +\end_layout + +\begin_layout Description +EVENT-LOOP ((&key +\shape italic +key-up-fn key-down-fn mouse-motion-fn quit-fn +\shape default +) &body +\shape italic +body +\shape default +) +\end_layout + +\begin_layout Standard +Repeatedly calls +\shape italic +body +\shape default + 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. +\end_layout + +\begin_layout Description +GET-MOUSE-POS () => +\shape italic +vector +\shape default + +\end_layout + +\begin_layout Description +GET-MOUSE-X () => +\shape italic +number +\end_layout + +\begin_layout Description +GET-MOUSE-Y () => +\shape italic +number +\end_layout + +\begin_layout Standard +Returns the current position of mouse pointer. +\end_layout + +\begin_layout Description +SET-MOUSE-POS ( +\shape italic +vector +\shape default +) +\end_layout + +\begin_layout Standard +Sets the position of mouse pointer. +\end_layout + +\begin_layout Description +KEY-PRESSED-P ( +\shape italic +keysym +\shape default +) => +\shape italic +bool +\end_layout + +\begin_layout Standard +Test if the key +\shape italic +keysym +\shape default + is currently pressed down. + For keysyms see chapter 3.3 +\end_layout + +\begin_layout Description +TEST-KEYS (( +\shape italic +key +\shape default + | ( +\shape italic +keys +\shape default +) +\shape italic +form +\shape default +)) +\end_layout + +\begin_layout Standard +Tests if any of the given keys are currently pressed. + Evaluates +\shape italic +all +\shape default + matching forms. +\end_layout + +\begin_layout Standard +Example: +\end_layout + +\begin_layout Quotation +(test-keys +\end_layout + +\begin_layout Quotation +\InsetSpace ~ +\InsetSpace ~ +(:key-left (move-left sprite)) +\end_layout + +\begin_layout Quotation +\InsetSpace ~ +\InsetSpace ~ +(:key-right (move-right sprite)) +\end_layout + +\begin_layout Quotation +\InsetSpace ~ +\InsetSpace ~ +((:key-ctrl :key-mouse-1) (shoot sprite)) +\end_layout + [1038 lines skipped] --- /project/pal/cvsroot/pal/documentation/pal-manual.pdf 2007/10/18 19:29:56 NONE +++ /project/pal/cvsroot/pal/documentation/pal-manual.pdf 2007/10/18 19:29:56 1.1 [6855 lines skipped] From tneste at common-lisp.net Mon Oct 22 12:03:34 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 22 Oct 2007 08:03:34 -0400 (EDT) Subject: [pal-cvs] CVS pal-gui/examples Message-ID: <20071022120334.25F511B01B@common-lisp.net> Update of /project/pal/cvsroot/pal-gui/examples In directory clnet:/tmp/cvs-serv31975/examples Modified Files: test.lisp Log Message: Fixed packing. I think. --- /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/17 17:02:52 1.6 +++ /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/22 12:03:24 1.7 @@ -1,10 +1,9 @@ ;; TODO: ;; -;; Exports, gob picking, packing, destroy gob, window sizing, box labels, dialogs, menus, tooltips, keyboard control, scrollwheel +;; Exports, window sizing, box labels, dialogs, menus, tooltips, keyboard control, scrollwheel, fix pal's clipping ;; label, radio box, check box, joystick, scroll box, fix listbox, fix gauge, paragraph, text box, simple editor, drop box. ;; File open/save, directory, yes/no dialogs - (in-package :pal-gui) (define-tags plane (load-image "lego-plane.png") @@ -30,18 +29,16 @@ (ag (make-instance 'h-gauge :parent left-box :min-value 0 :max-value 255 :value 0)) (list (make-instance 'list-box :parent window-2 :items (loop for i from 0 to 100 collect (format nil "FooBar ~a" i)))) - (button (make-instance 'button :value "FooBar!" :parent window-2 :on-select (lambda (g pos) (message 'foo) t))) - ) - - ;; (make-instance 'button :value "Button" :parent bottom-box) + (button (make-instance 'button :value "FooBar!" :parent window-2 :on-select (lambda (g pos) (message 'foo) (setf (parent-of g) nil))))) + (make-instance 'button :value "Button" :parent bottom-box) + (pack list) (gui-loop () (setf (value-of meter) (get-fps)) (draw-image* (tag 'tile) (v 0 0) (v 0 0) 800 600) (with-blend (:color '(0 0 0 64)) (draw-image (tag 'plane) (v 320 220))) (with-blend (:color (list (value-of rg) (value-of gg) (value-of bg) (value-of ag))) - (draw-image (tag 'plane) (v 300 200))) - )))) + (draw-image (tag 'plane) (v 300 200))))))) ;; (test) \ No newline at end of file From tneste at common-lisp.net Mon Oct 22 12:03:37 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 22 Oct 2007 08:03:37 -0400 (EDT) Subject: [pal-cvs] CVS pal-gui Message-ID: <20071022120337.877E968220@common-lisp.net> Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv31975 Modified Files: gob.lisp gui.lisp widgets.lisp Added Files: license.txt Log Message: Fixed packing. I think. --- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/17 17:02:52 1.6 +++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/22 12:03:35 1.7 @@ -1,7 +1,6 @@ (in-package :pal-gui) (defvar *root* nil) -(defvar *gobs* nil) (defvar *drag-start-pos* nil) (defvar *relative-drag-start-pos* nil) (defvar *focused-gob* nil) @@ -18,12 +17,16 @@ (activep :accessor activep :initform t :initarg :activep) (width :accessor width-of :initarg :width :initform 0) (height :accessor height-of :initarg :height :initform 0) + (min-width :accessor min-width-of :initarg :min-width) + (min-height :accessor min-height-of :initarg :min-height) (childs :reader childs-of :initform nil))) - -(defmethod initialize-instance :after ((g gob) &key (parent *root*) &allow-other-keys) - (setf (parent-of g) parent) - (push g *gobs*)) +(defmethod initialize-instance :after ((g gob) &key (min-height) (min-width) (parent *root*) &allow-other-keys) + (unless min-width + (setf (min-width-of g) (width-of g))) + (unless min-height + (setf (min-height-of g) (height-of g))) + (setf (parent-of g) parent)) (defgeneric repaint (gob)) (defmethod repaint :around ((g gob)) @@ -76,10 +79,6 @@ (defmethod on-select ((gob gob) pos) nil) -(defgeneric on-destroy (gob)) -(defmethod on-destroy ((gob gob)) - nil) - (defgeneric on-drag (gob start-pos delta-pos)) (defmethod on-drag ((gob gob) start-pos delta) (declare (ignore start-pos delta)) @@ -114,28 +113,26 @@ (defgeneric abandon (parent child)) (defmethod abandon ((parent gob) (child gob)) (setf (slot-value parent 'childs) (remove child (slot-value parent 'childs)) - (parent-of child) nil)) + (slot-value child 'parent) nil)) (defgeneric (setf parent-of) (parent child)) -(defmethod (setf parent-of) ((parent gob) (child gob)) +(defmethod (setf parent-of) (parent (child gob)) (when (parent-of child) (abandon (parent-of child) child)) - (adopt parent child)) - -(defgeneric min-height-of (gob)) -(defmethod min-height-of ((g gob)) - (if (childs-of g) - (+ (* (length (childs-of g)) (gap-of g)) - (loop for c in (childs-of g) summing (if (y-expand-p c) 0 (min-height-of c)))) - (height-of g))) - -(defgeneric min-width-of (gob)) -(defmethod min-width-of ((g gob)) - (if (childs-of g) - (+ (* (length (childs-of g)) (gap-of g)) - (loop for c in (childs-of g) summing (if (x-expand-p c) 0 (min-width-of c)))) - (width-of g))) + (when parent + (adopt parent child))) +(defmethod (setf width-of) (width (g gob)) + (when (/= (slot-value g 'width) width) + (setf (slot-value g 'width) width) + (pack g)) + (setf (slot-value g 'width) width)) + +(defmethod (setf height-of) (height (g gob)) + (when (/= (slot-value g 'height) height) + (setf (slot-value g 'height) height) + (pack g)) + (setf (slot-value g 'height) height)) @@ -155,21 +152,29 @@ (call-next-method) (pack parent)) +(defmethod min-width-of ((g v-packing)) + (+ (loop for c in (childs-of g) maximizing (min-width-of c)) (* 2 (xpad-of g)))) + +(defmethod min-height-of ((g v-packing)) + (+ (* (1- (length (childs-of g))) (gap-of g)) (* 2 (ypad-of g)) + (loop for c in (childs-of g) summing (min-height-of c)))) + (defmethod pack ((g v-packing)) - (with-accessors ((gap gap-of) (width width-of) (height height-of) (pos pos-of) (childs childs-of) (ypad ypad-of) (xpad xpad-of)) g + (with-accessors ((gap gap-of) (width width-of) (min-height min-height-of) (height height-of) (pos pos-of) + (parent parent-of) (childs childs-of) (ypad ypad-of) (xpad xpad-of)) g (let* ((exp-count (count-if #'y-expand-p childs)) - (solids-need (min-height-of g)) - (exp-size (- height solids-need (* 2 ypad)))) + (exp-size (- height (+ (* (1- (length (childs-of g))) (gap-of g)) (* 2 (ypad-of g)) + (loop for c in (childs-of g) summing (if (y-expand-p c) 0 (min-height-of c))))))) (dolist (c childs) (when (y-expand-p c) - (setf (height-of c) (max 10 (truncate exp-size exp-count)))) + (setf (height-of c) (max (min-height-of c) (truncate exp-size exp-count)))) (when (x-expand-p c) - (setf (width-of c) (- width (* 2 xpad)))) - (pack c))) + (setf (width-of c) (- width (* 2 xpad)))))) (let ((cpos (v xpad ypad))) (dolist (c (reverse childs)) (setf (pos-of c) cpos) - (setf cpos (v+ cpos (v 0 (+ gap (height-of c))))))))) + (setf cpos (v+ cpos (v 0 (+ gap (height-of c))))))) + (pack parent))) @@ -179,21 +184,29 @@ (ypad :accessor ypad-of :initarg :ypad :initform 0) (gap :accessor gap-of :initarg :gap :initform 0))) +(defmethod min-height-of ((g h-packing)) + (+ (loop for c in (childs-of g) maximizing (min-height-of c)) (gap-of g) (* 2 (ypad-of g)))) + +(defmethod min-width-of ((g h-packing)) + (+ (* (1- (length (childs-of g))) (gap-of g) (* 2 (xpad-of g))) + (loop for c in (childs-of g) summing (min-width-of c)))) + (defmethod pack ((g h-packing)) - (with-accessors ((gap gap-of) (height height-of) (width width-of) (pos pos-of) (childs childs-of) (ypad ypad-of) (xpad xpad-of)) g + (with-accessors ((gap gap-of) (height height-of) (min-width min-width-of) (width width-of) (pos pos-of) + (parent parent-of) (childs childs-of) (ypad ypad-of) (xpad xpad-of)) g (let* ((exp-count (count-if #'x-expand-p childs)) - (solids-need (min-width-of g)) - (exp-size (- width solids-need (* 2 xpad)))) + (exp-size (- width (+ (* (1- (length (childs-of g))) (gap-of g)) (* 2 (xpad-of g)) + (loop for c in (childs-of g) summing (if (x-expand-p c) 0 (min-height-of c))))))) (dolist (c childs) (when (x-expand-p c) - (setf (width-of c) (max 10 (truncate exp-size exp-count)))) + (setf (width-of c) (max (min-width-of c) (truncate exp-size exp-count)))) (when (y-expand-p c) - (setf (height-of c) (- height (* 2 ypad)))) - (pack c))) + (setf (height-of c) (- height (* 2 ypad)))))) (let ((cpos (v xpad ypad))) (dolist (c (reverse childs)) (setf (pos-of c) cpos) - (setf cpos (v+ cpos (v (+ gap (width-of c)) 0))))))) + (setf cpos (v+ cpos (v (+ gap (width-of c)) 0))))) + (pack parent))) --- /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/16 21:46:09 1.3 +++ /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/22 12:03:35 1.4 @@ -6,7 +6,6 @@ `(block event-loop (cffi:with-foreign-object (,event :char 500) (let ((key-up (lambda (key) - (case key (:key-mouse-1 (cond (*pointed-gob* @@ -32,12 +31,12 @@ (loop (pal::do-event ,event key-up key-down ,mouse-motion-fn ,quit-fn) , at redraw - (let ((g (gob-at-point (get-mouse-pos)))) + (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 (setf *pointed-gob* g) - (when (and g (not (activep g))) + (t (when (and g (not (activep g))) (when *pointed-gob* (on-leave *pointed-gob*)) (on-enter g))))) @@ -55,12 +54,19 @@ (close-pal)))) +(defun active-gobs-at-point (point parent) + (let ((c (find-if (lambda (c) + (point-inside-p c point)) + (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 *gobs* nil - *root* (make-instance 'root))) + (setf *root* (make-instance 'root :parent nil) + *gui-font* (tag 'pal::default-font))) (defun update-gui () - (repaint *root*)) - -(defun gob-at-point (point) - (find-if (lambda (g) (and (activep g) (point-inside-p g point))) *gobs*)) + (repaint *root*)) \ No newline at end of file --- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/17 17:02:52 1.6 +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/22 12:03:35 1.7 @@ -1,22 +1,23 @@ (in-package :pal-gui) -(defparameter *window-color* '(160 160 160 128)) -(defparameter *widget-color* '(180 180 180 255)) +(defparameter *window-color* '(200 200 200 255)) +(defparameter *widget-color* '(210 210 210 255)) (defparameter *text-color* '(0 0 0 255)) (defparameter *paper-color* '(255 255 200 255)) +(defvar *gui-font* nil) -(defun get-m (&optional font) - (truncate (* (get-font-height font) 1.5))) +(defun get-m () + (truncate (* (get-font-height *gui-font*) 1.5))) -(defun get-text-bounds (string &optional font) - (let ((fh (get-font-height font))) - (values (max (truncate (* 1.5 fh)) (+ (get-text-size string) fh)) +(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 (&optional font) - (let ((fh (get-font-height font))) +(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)) @@ -46,19 +47,6 @@ -(defgeneric present (object gob width height)) - -(defmethod present :around (object (g gob) width height) - (let ((ap (absolute-pos-of g))) - (with-clipping ((1+ (vx ap)) (1+ (vy ap)) (- (width-of g) 2) (- (height-of g) 2)) - (call-next-method)))) - -(defmethod present (object (g gob) width height) - (with-blend (:color *text-color*) - (draw-text (format nil "~a" object) (get-text-offset)))) - - - (defclass widget (gob) @@ -67,9 +55,7 @@ (on-button-down :accessor on-button-down-of :initarg :on-button-down-select :initform (lambda (widget pos) (declare (ignore widget pos)) nil)) (on-button-up :accessor on-button-up-of :initarg :on-button-up-select :initform (lambda (widget pos) (declare (ignore widget pos)) 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)) - (on-destroy :accessor on-destroy-of :initarg :on-destroy :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))) (defmethod on-drag :around ((g widget) pos d) @@ -96,9 +82,7 @@ (unless (funcall (on-leave-of g) g) (call-next-method))) -(defmethod on-destroy :around ((g widget)) - (unless (funcall (on-destroy-of g)) - (call-next-method))) + @@ -167,13 +151,13 @@ (draw-rectangle (v 0 0) width (get-m) 0 0 0 64) (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))))) - (defclass button (widget) ((value :accessor value-of :initform "" :initarg :value)) (:default-initargs :x-expand-p t)) @@ -183,8 +167,9 @@ (cond ((armedp g) (draw-frame (v 0 0) width height *widget-color* :style :sunken :border 2) - (with-blend (:color *text-color*) - (present value g width height))) + (with-transformation (:pos (v 1 1)) + (with-blend (:color *text-color*) + (present value g width height)))) ((pointedp g) (draw-frame (v 0 0) width height *widget-color* :border 2 :style :raised) (with-blend (:color *text-color*) @@ -317,14 +302,40 @@ (defclass list-box (h-box) () - (:default-initargs :gap 3 :xpad 0 :ypad 0 :y-expand-p t :x-expand-p t)) + (:default-initargs :gap 3 :y-expand-p t :x-expand-p t)) (defmethod initialize-instance :after ((g list-box) &key items (item-height (get-m)) &allow-other-keys) - (let* ((lv (make-instance 'list-view :items items :item-height item-height :parent g))) - (make-instance 'v-slider :parent g - :max-value (* item-height (length items)) - :page-size (lambda () (height-of lv)) - :on-drag (lambda (g pos d) - (declare (ignore pos d)) - (setf (scroll-of lv) (value-of g)) - nil)))) \ No newline at end of file + (let* ((list-view (make-instance 'list-view :items items :item-height item-height :parent g)) + (slider-box (make-instance 'v-box :parent g :gap 0 :x-expand-p nil)) + (up-button (make-instance 'button :parent slider-box :x-expand-p nil :y-expand-p nil)) + (slider (make-instance 'v-slider + :parent slider-box + :max-value (* item-height (length items)) + :page-size (lambda () (height-of list-view)) + :on-drag (lambda (g pos d) + (declare (ignore pos d)) + (setf (scroll-of list-view) (value-of g)) + nil))) + (down-button (make-instance 'button :parent slider-box :x-expand-p nil :y-expand-p nil)) + ))) + + + + + + + + + + + +(defgeneric present (object gob width height)) + +(defmethod present :around (object (g widget) width height) + (let ((ap (absolute-pos-of g))) + (with-clipping ((1+ (vx ap)) (1+ (vy ap)) (- (width-of g) 2) (- (height-of g) 2)) + (call-next-method)))) + +(defmethod present (object (g widget) width height) + (with-blend (:color *text-color*) + (draw-text (format nil "~a" object) (get-text-offset)))) \ No newline at end of file --- /project/pal/cvsroot/pal-gui/license.txt 2007/10/22 12:03:37 NONE +++ /project/pal/cvsroot/pal-gui/license.txt 2007/10/22 12:03:37 1.1 PAL-GUI is published under the MIT license Copyright (c) 2007 Tomi Neste Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), 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 "AS IS", 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. From tneste at common-lisp.net Mon Oct 22 15:56:02 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 22 Oct 2007 11:56:02 -0400 (EDT) Subject: [pal-cvs] CVS pal Message-ID: <20071022155602.A741B201E@common-lisp.net> Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv6053 Modified Files: pal.lisp Log Message: MESSAGE now accepts multiple arguments. --- /project/pal/cvsroot/pal/pal.lisp 2007/10/15 21:48:00 1.33 +++ /project/pal/cvsroot/pal/pal.lisp 2007/10/22 15:56:02 1.34 @@ -889,7 +889,8 @@ (defun draw-fps () (draw-text (prin1-to-string (get-fps)) (v 0 0))) -(defun message (object) - (setf *messages* (append *messages* (list (prin1-to-string object)))) +(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*))) \ No newline at end of file + (pop *messages*))) + From tneste at common-lisp.net Mon Oct 22 15:56:41 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 22 Oct 2007 11:56:41 -0400 (EDT) Subject: [pal-cvs] CVS pal-gui Message-ID: <20071022155641.524BE201F@common-lisp.net> Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv6092 Modified Files: gob.lisp widgets.lisp Log Message: Fixed packing again... --- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/22 12:03:35 1.7 +++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/22 15:56:40 1.8 @@ -153,13 +153,17 @@ (pack parent)) (defmethod min-width-of ((g v-packing)) - (+ (loop for c in (childs-of g) maximizing (min-width-of c)) (* 2 (xpad-of g)))) + (+ (loop for c in (childs-of g) maximizing (min-width-of c)) + (gap-of g) + (* 2 (xpad-of g)))) (defmethod min-height-of ((g v-packing)) - (+ (* (1- (length (childs-of g))) (gap-of g)) (* 2 (ypad-of g)) + (+ (* (1- (length (childs-of g))) (gap-of g)) + (* 2 (ypad-of g)) (loop for c in (childs-of g) summing (min-height-of c)))) (defmethod pack ((g v-packing)) + (with-accessors ((gap gap-of) (width width-of) (min-height min-height-of) (height height-of) (pos pos-of) (parent parent-of) (childs childs-of) (ypad ypad-of) (xpad xpad-of)) g (let* ((exp-count (count-if #'y-expand-p childs)) @@ -169,7 +173,7 @@ (when (y-expand-p c) (setf (height-of c) (max (min-height-of c) (truncate exp-size exp-count)))) (when (x-expand-p c) - (setf (width-of c) (- width (* 2 xpad)))))) + (setf (width-of c) (max 1 (- width (* 2 xpad))))))) (let ((cpos (v xpad ypad))) (dolist (c (reverse childs)) (setf (pos-of c) cpos) @@ -180,15 +184,16 @@ (defclass h-packing (v-packing) - ((xpad :accessor xpad-of :initarg :xpad :initform 0) - (ypad :accessor ypad-of :initarg :ypad :initform 0) - (gap :accessor gap-of :initarg :gap :initform 0))) + ()) (defmethod min-height-of ((g h-packing)) - (+ (loop for c in (childs-of g) maximizing (min-height-of c)) (gap-of g) (* 2 (ypad-of g)))) + (+ (loop for c in (childs-of g) maximizing (min-height-of c)) + (gap-of g) + (* 2 (ypad-of g)))) (defmethod min-width-of ((g h-packing)) - (+ (* (1- (length (childs-of g))) (gap-of g) (* 2 (xpad-of g))) + (+ (* (1- (length (childs-of g))) (gap-of g)) + (* 2 (xpad-of g)) (loop for c in (childs-of g) summing (min-width-of c)))) (defmethod pack ((g h-packing)) @@ -196,12 +201,12 @@ (parent parent-of) (childs childs-of) (ypad ypad-of) (xpad xpad-of)) g (let* ((exp-count (count-if #'x-expand-p childs)) (exp-size (- width (+ (* (1- (length (childs-of g))) (gap-of g)) (* 2 (xpad-of g)) - (loop for c in (childs-of g) summing (if (x-expand-p c) 0 (min-height-of c))))))) + (loop for c in (childs-of g) summing (if (x-expand-p c) 0 (min-width-of c))))))) (dolist (c childs) (when (x-expand-p c) (setf (width-of c) (max (min-width-of c) (truncate exp-size exp-count)))) (when (y-expand-p c) - (setf (height-of c) (- height (* 2 ypad)))))) + (setf (height-of c) (max 1 (- height (* 2 ypad))))))) (let ((cpos (v xpad ypad))) (dolist (c (reverse childs)) (setf (pos-of c) cpos) @@ -240,6 +245,17 @@ +(defclass highlighted () + ()) + +(defgeneric highlight (g)) + +(defmethod repaint :after ((g highlighted)) + (when (or (armedp g) (and (activep g) (pointedp g))) + (highlight g))) + + + (defclass root (gob) () --- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/22 12:03:35 1.7 +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/22 15:56:41 1.8 @@ -1,8 +1,8 @@ (in-package :pal-gui) -(defparameter *window-color* '(200 200 200 255)) -(defparameter *widget-color* '(210 210 210 255)) +(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)) (defvar *gui-font* nil) @@ -82,7 +82,8 @@ (unless (funcall (on-leave-of g) g) (call-next-method))) - +(defmethod highlight ((g widget)) + (draw-rectangle (v 0 0) (width-of g) (height-of g) 255 255 255 32)) @@ -117,6 +118,7 @@ + (defclass filler (widget) () (:default-initargs :activep nil)) @@ -148,7 +150,7 @@ (with-accessors ((width width-of) (height height-of) (label label-of)) g (draw-rectangle (v 6 6) width height 0 0 0 64) (draw-frame (v 0 0) width height *window-color* :style :raised) - (draw-rectangle (v 0 0) width (get-m) 0 0 0 64) + (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) @@ -158,7 +160,7 @@ -(defclass button (widget) +(defclass button (widget highlighted) ((value :accessor value-of :initform "" :initarg :value)) (:default-initargs :x-expand-p t)) @@ -166,14 +168,10 @@ (with-accessors ((width width-of) (height height-of) (value value-of)) g (cond ((armedp g) - (draw-frame (v 0 0) width height *widget-color* :style :sunken :border 2) + (draw-frame (v 0 0) width height *widget-color* :style :sunken) (with-transformation (:pos (v 1 1)) (with-blend (:color *text-color*) (present value g width height)))) - ((pointedp g) - (draw-frame (v 0 0) width height *widget-color* :border 2 :style :raised) - (with-blend (:color *text-color*) - (present value g width height))) (t (draw-frame (v 0 0) width height *widget-color* :style :raised) (with-blend (:color *text-color*) @@ -183,7 +181,7 @@ -(defclass h-gauge (widget) +(defclass h-gauge (widget highlighted) ((value :reader value-of :initarg :value :initform 0) (min-value :accessor min-value-of :initarg :min-value :initform 0) (max-value :accessor max-value-of :initarg :max-value :initform 100)) @@ -205,7 +203,7 @@ (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 :border (if (or (armedp g) (pointedp g)) 2 1)) + (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) (with-blend (:color *text-color*) @@ -216,12 +214,12 @@ -(defclass v-slider (widget) +(defclass v-slider (widget highlighted) ((value :reader value-of :initarg :value :initform 0) (page-size :accessor page-size-of :initarg :page-size :initform 1) (min-value :accessor min-value-of :initarg :min-value :initform 0) (max-value :accessor max-value-of :initarg :max-value :initform 100)) - (:default-initargs :width (truncate (get-m) 2) :y-expand-p t)) + (:default-initargs :y-expand-p t)) (defmethod (setf value-of) (value (g v-slider)) (setf (slot-value g 'value) (clamp (min-value-of g) value (- (max-value-of g) (funcall (page-size-of g)))))) @@ -241,7 +239,7 @@ (draw-frame (v 0 0) width height *window-color* :style :sunken) (draw-frame kpos width (min height (- height (* (- units ps) usize))) - *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1)) + *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)))) @@ -305,10 +303,12 @@ (:default-initargs :gap 3 :y-expand-p t :x-expand-p t)) (defmethod initialize-instance :after ((g list-box) &key items (item-height (get-m)) &allow-other-keys) - (let* ((list-view (make-instance 'list-view :items items :item-height item-height :parent g)) - (slider-box (make-instance 'v-box :parent g :gap 0 :x-expand-p nil)) - (up-button (make-instance 'button :parent slider-box :x-expand-p nil :y-expand-p nil)) + (let* ((w (truncate (get-m) 1.5)) + (list-view (make-instance 'list-view :items items :item-height item-height :parent g)) + (slider-box (make-instance 'v-box :parent g :gap 0 :x-expand-p nil :width w)) + (up-button (make-instance 'button :parent slider-box :x-expand-p nil :y-expand-p nil :width w)) (slider (make-instance 'v-slider + :width w :parent slider-box :max-value (* item-height (length items)) :page-size (lambda () (height-of list-view)) @@ -316,7 +316,7 @@ (declare (ignore pos d)) (setf (scroll-of list-view) (value-of g)) nil))) - (down-button (make-instance 'button :parent slider-box :x-expand-p nil :y-expand-p nil)) + (down-button (make-instance 'button :parent slider-box :x-expand-p nil :y-expand-p nil :width w)) ))) From tneste at common-lisp.net Mon Oct 22 19:25:23 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 22 Oct 2007 15:25:23 -0400 (EDT) Subject: [pal-cvs] CVS pal-gui/examples Message-ID: <20071022192523.E5F9A2E200@common-lisp.net> Update of /project/pal/cvsroot/pal-gui/examples In directory clnet:/tmp/cvs-serv7862/examples Modified Files: test.lisp Log Message: --- /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/22 12:03:24 1.7 +++ /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/22 19:25:23 1.8 @@ -10,8 +10,8 @@ tile (load-image "ground.png")) (defun test () - (with-gui (:paths (merge-pathnames "examples/" pal::*pal-directory*)) - (let* ((window (make-instance 'window :pos (v 200 200) :width 300 :height 230)) + (with-gui (:fps 200 :paths (merge-pathnames "examples/" pal::*pal-directory*)) + (let* ((window (make-instance 'window :pos (v 200 200) :width 300 :height 350)) (window-2 (make-instance 'window :width 200 :height 300)) (box (make-instance 'h-box :parent window)) @@ -32,7 +32,7 @@ (button (make-instance 'button :value "FooBar!" :parent window-2 :on-select (lambda (g pos) (message 'foo) (setf (parent-of g) nil))))) (make-instance 'button :value "Button" :parent bottom-box) - (pack list) + (gui-loop () (setf (value-of meter) (get-fps)) (draw-image* (tag 'tile) (v 0 0) (v 0 0) 800 600) From tneste at common-lisp.net Mon Oct 22 19:25:24 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 22 Oct 2007 15:25:24 -0400 (EDT) Subject: [pal-cvs] CVS pal-gui Message-ID: <20071022192524.4DD955903E@common-lisp.net> Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv7862 Modified Files: gob.lisp gui.lisp widgets.lisp Log Message: --- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/22 15:56:40 1.8 +++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/22 19:25:24 1.9 @@ -17,16 +17,17 @@ (activep :accessor activep :initform t :initarg :activep) (width :accessor width-of :initarg :width :initform 0) (height :accessor height-of :initarg :height :initform 0) - (min-width :accessor min-width-of :initarg :min-width) - (min-height :accessor min-height-of :initarg :min-height) + (min-width :reader min-width-of :initarg :min-width) + (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*) &allow-other-keys) +(defmethod initialize-instance :after ((g gob) &key (min-height) (min-width) (parent *root*) (childs nil) &allow-other-keys) (unless min-width - (setf (min-width-of g) (width-of g))) + (setf (slot-value g 'min-width) (width-of g))) (unless min-height - (setf (min-height-of g) (height-of g))) - (setf (parent-of g) parent)) + (setf (slot-value g 'min-height) (height-of g))) + (setf (parent-of g) parent) + (setf (childs-of g) childs)) (defgeneric repaint (gob)) (defmethod repaint :around ((g gob)) @@ -115,6 +116,17 @@ (setf (slot-value parent 'childs) (remove child (slot-value parent 'childs)) (slot-value child 'parent) nil)) +(defgeneric abandon-all (parent)) +(defmethod abandon-all ((parent gob)) + (dolist (c (childs-of parent)) + (abandon parent c))) + +(defgeneric (setf childs-of) (childs parent)) +(defmethod (setf childs-of) (childs (parent gob)) + (dolist (c childs) + (adopt parent c))) + + (defgeneric (setf parent-of) (parent child)) (defmethod (setf parent-of) (parent (child gob)) (when (parent-of child) @@ -140,8 +152,8 @@ (defclass v-packing (gob) - ((xpad :accessor xpad-of :initarg :xpad :initform 0) - (ypad :accessor ypad-of :initarg :ypad :initform 0) + ((x-pad :accessor x-pad-of :initarg :x-pad :initform 0) + (y-pad :accessor y-pad-of :initarg :y-pad :initform 0) (gap :accessor gap-of :initarg :gap :initform 0))) (defmethod adopt ((parent v-packing) (child gob)) @@ -155,26 +167,25 @@ (defmethod min-width-of ((g v-packing)) (+ (loop for c in (childs-of g) maximizing (min-width-of c)) (gap-of g) - (* 2 (xpad-of g)))) + (* 2 (x-pad-of g)))) (defmethod min-height-of ((g v-packing)) (+ (* (1- (length (childs-of g))) (gap-of g)) - (* 2 (ypad-of g)) + (* 2 (y-pad-of g)) (loop for c in (childs-of g) summing (min-height-of c)))) (defmethod pack ((g v-packing)) - (with-accessors ((gap gap-of) (width width-of) (min-height min-height-of) (height height-of) (pos pos-of) - (parent parent-of) (childs childs-of) (ypad ypad-of) (xpad xpad-of)) g + (parent parent-of) (childs childs-of) (y-pad y-pad-of) (x-pad x-pad-of)) g (let* ((exp-count (count-if #'y-expand-p childs)) - (exp-size (- height (+ (* (1- (length (childs-of g))) (gap-of g)) (* 2 (ypad-of g)) - (loop for c in (childs-of g) summing (if (y-expand-p c) 0 (min-height-of c))))))) + (exp-size (- height (+ (* (1- (length (childs-of g))) (gap-of g)) (* 2 (y-pad-of g)) + (loop for c in (remove-if 'y-expand-p (childs-of g)) summing (min-height-of c)))))) (dolist (c childs) (when (y-expand-p c) (setf (height-of c) (max (min-height-of c) (truncate exp-size exp-count)))) (when (x-expand-p c) - (setf (width-of c) (max 1 (- width (* 2 xpad))))))) - (let ((cpos (v xpad ypad))) + (setf (width-of c) (max 1 (- width (* 2 x-pad))))))) + (let ((cpos (v x-pad y-pad))) (dolist (c (reverse childs)) (setf (pos-of c) cpos) (setf cpos (v+ cpos (v 0 (+ gap (height-of c))))))) @@ -189,25 +200,25 @@ (defmethod min-height-of ((g h-packing)) (+ (loop for c in (childs-of g) maximizing (min-height-of c)) (gap-of g) - (* 2 (ypad-of g)))) + (* 2 (y-pad-of g)))) (defmethod min-width-of ((g h-packing)) (+ (* (1- (length (childs-of g))) (gap-of g)) - (* 2 (xpad-of g)) + (* 2 (x-pad-of g)) (loop for c in (childs-of g) summing (min-width-of c)))) (defmethod pack ((g h-packing)) (with-accessors ((gap gap-of) (height height-of) (min-width min-width-of) (width width-of) (pos pos-of) - (parent parent-of) (childs childs-of) (ypad ypad-of) (xpad xpad-of)) g + (parent parent-of) (childs childs-of) (y-pad y-pad-of) (x-pad x-pad-of)) g (let* ((exp-count (count-if #'x-expand-p childs)) - (exp-size (- width (+ (* (1- (length (childs-of g))) (gap-of g)) (* 2 (xpad-of g)) - (loop for c in (childs-of g) summing (if (x-expand-p c) 0 (min-width-of c))))))) + (exp-size (- width (+ (* (1- (length (childs-of g))) (gap-of g)) (* 2 (x-pad-of g)) + (loop for c in (remove-if 'x-expand-p (childs-of g)) summing (min-width-of c)))))) (dolist (c childs) (when (x-expand-p c) (setf (width-of c) (max (min-width-of c) (truncate exp-size exp-count)))) (when (y-expand-p c) - (setf (height-of c) (max 1 (- height (* 2 ypad))))))) - (let ((cpos (v xpad ypad))) + (setf (height-of c) (max 1 (- height (* 2 y-pad))))))) + (let ((cpos (v x-pad y-pad))) (dolist (c (reverse childs)) (setf (pos-of c) cpos) (setf cpos (v+ cpos (v (+ gap (width-of c)) 0))))) --- /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/22 12:03:35 1.4 +++ /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/22 19:25:24 1.5 @@ -32,11 +32,11 @@ (pal::do-event ,event key-up key-down ,mouse-motion-fn ,quit-fn) , at 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))) + (t (setf *pointed-gob* g) + (when (and g (not (activep g))) (when *pointed-gob* (on-leave *pointed-gob*)) (on-enter g))))) @@ -57,7 +57,7 @@ (defun active-gobs-at-point (point parent) (let ((c (find-if (lambda (c) (point-inside-p c point)) - (childs-of parent)))) + (reverse (childs-of parent))))) (if c (if (activep c) (cons c (active-gobs-at-point point c)) --- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/22 15:56:41 1.8 +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/22 19:25:24 1.9 @@ -52,8 +52,8 @@ (defclass widget (gob) ((on-drag :accessor on-drag-of :initarg :on-drag :initform (lambda (widget pos d) (declare (ignore widget pos d)) nil)) (on-select :accessor on-select-of :initarg :on-select :initform (lambda (widget pos) (declare (ignore widget pos)) nil)) - (on-button-down :accessor on-button-down-of :initarg :on-button-down-select :initform (lambda (widget pos) (declare (ignore widget pos)) nil)) - (on-button-up :accessor on-button-up-of :initarg :on-button-up-select :initform (lambda (widget pos) (declare (ignore widget pos)) 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)) (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))) @@ -94,8 +94,8 @@ (defmethod initialize-instance :after ((g box) &key label) (when label - (setf (ypad-of g) (truncate (get-m) 2) - (xpad-of g) (truncate (get-m) 2)))) + (setf (y-pad-of g) (truncate (get-m) 2) + (x-pad-of g) (truncate (get-m) 2)))) (defmethod repaint ((g box)) (when (label-of g) @@ -107,13 +107,13 @@ (defclass v-box (box v-packing) () - (:default-initargs :xpad 0 :ypad 0 :gap (truncate (get-m) 3))) + (:default-initargs :x-pad 0 :y-pad 0 :gap (truncate (get-m) 3))) (defclass h-box (box h-packing) () - (:default-initargs :xpad 0 :ypad 0 :gap (truncate (get-m) 2))) + (:default-initargs :x-pad 0 :y-pad 0 :gap (truncate (get-m) 2))) @@ -132,7 +132,7 @@ (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 :xpad (truncate (get-m) 2) :ypad (truncate (get-m) 3) :gap (truncate (get-m) 3) :pos (v 10 10))) + (: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))) (defmethod initialize-instance :after ((g window) &key &allow-other-keys) (setf (filler-of g) (make-instance 'filler :parent g :x-expand-p t))) @@ -148,7 +148,6 @@ (defmethod repaint ((g window)) (with-accessors ((width width-of) (height height-of) (label label-of)) g - (draw-rectangle (v 6 6) width height 0 0 0 64) (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) @@ -183,10 +182,11 @@ (defclass h-gauge (widget highlighted) ((value :reader value-of :initarg :value :initform 0) - (min-value :accessor min-value-of :initarg :min-value :initform 0) - (max-value :accessor max-value-of :initarg :max-value :initform 100)) + (min-value :reader min-value-of :initarg :min-value :initform 0) + (max-value :reader max-value-of :initarg :max-value :initform 100)) (:default-initargs :x-expand-p t)) +(defgeneric (setf value-of) (value g)) (defmethod (setf value-of) (value (g h-gauge)) (setf (slot-value g 'value) (clamp (min-value-of g) value (max-value-of g)))) @@ -216,15 +216,14 @@ (defclass v-slider (widget highlighted) ((value :reader value-of :initarg :value :initform 0) - (page-size :accessor page-size-of :initarg :page-size :initform 1) - (min-value :accessor min-value-of :initarg :min-value :initform 0) - (max-value :accessor max-value-of :initarg :max-value :initform 100)) + (page-size :reader page-size-of :initarg :page-size :initform 1) + (min-value :reader min-value-of :initarg :min-value :initform 0) + (max-value :reader max-value-of :initarg :max-value :initform 100)) (:default-initargs :y-expand-p t)) (defmethod (setf value-of) (value (g v-slider)) (setf (slot-value g 'value) (clamp (min-value-of g) value (- (max-value-of g) (funcall (page-size-of g)))))) - (defmethod on-drag ((g v-slider) start-pos delta) (let ((y (vy (v- start-pos delta)))) (setf (value-of g) (+ (truncate y (/ (height-of g) (abs (- (min-value-of g) (max-value-of g))))) (min-value-of g))))) @@ -253,8 +252,8 @@ (defclass h-meter (widget) ((value :reader value-of :initarg :value :initform 0) - (min-value :accessor min-value-of :initarg :min-value :initform 0) - (max-value :accessor max-value-of :initarg :max-value :initform 100)) + (min-value :reader min-value-of :initarg :min-value :initform 0) + (max-value :reader max-value-of :initarg :max-value :initform 100)) (:default-initargs :activep nil :x-expand-p t)) (defmethod (setf value-of) (value (g h-meter)) @@ -275,24 +274,31 @@ (defclass list-view (widget) - ((items :accessor items-of :initarg :items :initform '()) - (item-height :accessor item-height-of :initarg :item-height :initform (get-m)) - (scroll :accessor scroll-of :initform 0)) + ((items :reader items-of :initarg :items :initform '()) + (item-height :reader item-height-of :initarg :item-height :initform (get-m)) + (scroll :reader scroll-of :initform 0)) (:default-initargs :x-expand-p t :y-expand-p t)) +(defgeneric (setf scroll-of) (value list-view)) +(defmethod (setf scroll-of) (value (g list-view)) + (setf (slot-value g 'scroll) + (clamp 0 value (- (* (length (items-of g)) (item-height-of g)) (height-of g))))) + (defmethod repaint ((g list-view)) - (with-accessors ((width width-of) (height height-of) (ap absolute-pos-of) (item-height item-height-of)) g + (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-blend (:color *text-color*) - (with-transformation (:pos (v 0 (scroll-of g))) + (with-transformation (:pos (v 0 (- (mod scroll item-height)))) (let ((y 0)) (dolist (i (items-of g)) - (when (oddp y) - (draw-rectangle (v 0 0) width item-height 0 0 0 32)) - (present i g width item-height) - (translate (v 0 item-height)) + (when (and (> (* (1+ y) item-height) scroll) + (< (* y item-height) (+ scroll height))) + (when (oddp y) + (draw-rectangle (v 0 0) width item-height 0 0 0 32)) + (present i g width item-height) + (translate (v 0 item-height))) (incf y)))))))) @@ -306,7 +312,6 @@ (let* ((w (truncate (get-m) 1.5)) (list-view (make-instance 'list-view :items items :item-height item-height :parent g)) (slider-box (make-instance 'v-box :parent g :gap 0 :x-expand-p nil :width w)) - (up-button (make-instance 'button :parent slider-box :x-expand-p nil :y-expand-p nil :width w)) (slider (make-instance 'v-slider :width w :parent slider-box @@ -315,9 +320,28 @@ :on-drag (lambda (g pos d) (declare (ignore pos d)) (setf (scroll-of list-view) (value-of g)) - nil))) - (down-button (make-instance 'button :parent slider-box :x-expand-p nil :y-expand-p nil :width w)) - ))) + nil)))) + (flet ((scroll-fn (d) (lambda (&rest rest) + (declare (ignore rest)) + (incf (scroll-of list-view) (* d item-height)) + (setf (value-of slider) (scroll-of list-view)) + nil))) + (make-instance 'button + :parent slider-box + :x-expand-p nil + :y-expand-p nil + :width w + :height w + :on-button-down (scroll-fn -1) + :on-drag (scroll-fn -0.3)) + (make-instance 'button + :parent slider-box + :x-expand-p nil + :y-expand-p nil + :width w + :height w + :on-button-down (scroll-fn 1) + :on-drag (scroll-fn 0.3))))) From tneste at common-lisp.net Wed Oct 24 17:51:47 2007 From: tneste at common-lisp.net (tneste) Date: Wed, 24 Oct 2007 13:51:47 -0400 (EDT) Subject: [pal-cvs] CVS pal Message-ID: <20071024175147.AA6BD74389@common-lisp.net> Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv31399 Modified Files: package.lisp pal-macros.lisp pal.lisp Log Message: Remover CURRY and rename RESET-BLEND-MODE to RESET-BLEND --- /project/pal/cvsroot/pal/package.lisp 2007/10/18 16:41:01 1.18 +++ /project/pal/cvsroot/pal/package.lisp 2007/10/24 17:51:47 1.19 @@ -387,8 +387,7 @@ #:random-elt #:clamp #:do-n - #:curry - + #:handle-events #:key-pressed-p #:keysym-char @@ -411,7 +410,7 @@ #:translate #:scale #:set-blend-mode - #:reset-blend-mode + #:reset-blend #:set-blend-color #:with-blend #:with-clipping --- /project/pal/cvsroot/pal/pal-macros.lisp 2007/10/11 19:26:23 1.14 +++ /project/pal/cvsroot/pal/pal-macros.lisp 2007/10/24 17:51:47 1.15 @@ -174,11 +174,6 @@ ,(expand (cddr args))))))) (expand args))) -(defmacro curry (fn &rest args) - (let ((rest (gensym))) - `(lambda (&rest ,rest) - (declare (dynamic-extent ,rest)) - (apply ,fn , at args ,rest)))) (defmacro test-keys (&body args) `(progn --- /project/pal/cvsroot/pal/pal.lisp 2007/10/22 15:56:02 1.34 +++ /project/pal/cvsroot/pal/pal.lisp 2007/10/24 17:51:47 1.35 @@ -357,8 +357,8 @@ (close-quads) (pal-ffi:gl-translatef (vx vec) (vy vec) 0f0)) -(declaim (inline reset-blend-mode)) -(defun reset-blend-mode () +(declaim (inline reset-blend)) +(defun reset-blend () (close-quads) (set-blend-mode :blend) (set-blend-color 255 255 255 255)) From tneste at common-lisp.net Wed Oct 24 18:07:03 2007 From: tneste at common-lisp.net (tneste) Date: Wed, 24 Oct 2007 14:07:03 -0400 (EDT) Subject: [pal-cvs] CVS pal Message-ID: <20071024180703.9C8564405F@common-lisp.net> Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv4391 Modified Files: ffi.lisp package.lisp pal.lisp Log Message: Smoothp option now works with filled polygons. --- /project/pal/cvsroot/pal/ffi.lisp 2007/10/11 19:26:23 1.21 +++ /project/pal/cvsroot/pal/ffi.lisp 2007/10/24 18:07:03 1.22 @@ -706,6 +706,7 @@ (defconstant +gl-dst-alpha+ #x304) (defconstant +gl-one+ 1) (defconstant +gl-flat+ #x1d00) +(defconstant +gl-polygon-smooth+ #xb41) (defconstant +gl-zero+ 0) (defconstant +gl-points+ 0) (defconstant +gl-ONE-MINUS-DST-ALPHA+ #x305) --- /project/pal/cvsroot/pal/package.lisp 2007/10/24 17:51:47 1.19 +++ /project/pal/cvsroot/pal/package.lisp 2007/10/24 18:07:03 1.20 @@ -4,6 +4,7 @@ (:use :common-lisp) (:export #:+NO-EVENT+ #:+gl-line-smooth+ + #:+gl-polygon-smooth+ #:fade-out-music #:fade-in-music #:make-font --- /project/pal/cvsroot/pal/pal.lisp 2007/10/24 17:51:47 1.35 +++ /project/pal/cvsroot/pal/pal.lisp 2007/10/24 18:07:03 1.36 @@ -633,6 +633,7 @@ (v+ pos (v 0 height))) r g b a :fill fill + :smoothp smoothp :absolutep absolutep)) ((eq nil fill) (with-line-settings smoothp size r g b a @@ -655,6 +656,8 @@ ((image-p fill) (close-quads) (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-current-bit+)) + (when smoothp + (pal-ffi:gl-enable pal-ffi:+gl-polygon-smooth+)) (set-image fill) (pal-ffi:gl-color4ub r g b a) (with-gl pal-ffi:+gl-polygon+ @@ -684,18 +687,22 @@ (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-current-bit+ pal-ffi:+gl-enable-bit+)) (pal-ffi:gl-color4ub r g b a) (pal-ffi:gl-disable pal-ffi:+gl-texture-2d+) + (when smoothp + (pal-ffi:gl-enable pal-ffi:+gl-polygon-smooth+)) (with-gl pal-ffi:+gl-polygon+ (dolist (p points) (pal-ffi:gl-vertex2f (vx p) (vy p)))) (pal-ffi:gl-pop-attrib)))) -(defunct draw-polygon* (points &key image tex-coords colors) - (list points list tex-coords list colors (or boolean image) image) +(defunct draw-polygon* (points &key image tex-coords colors smoothp) + (list points list tex-coords list colors (or boolean image) image boolean smoothp) (close-quads) (pal-ffi:gl-push-attrib (logior pal-ffi:+gl-current-bit+ pal-ffi:+gl-enable-bit+)) (cond ((and image tex-coords) (set-image image) + (when smoothp + (pal-ffi:gl-enable pal-ffi:+gl-polygon-smooth+)) (cond (colors (pal-ffi:gl-shade-model pal-ffi:+gl-smooth+) @@ -719,6 +726,8 @@ (t (pal-ffi:gl-shade-model pal-ffi:+gl-smooth+) (pal-ffi:gl-disable pal-ffi:+gl-texture-2d+) + (when smoothp + (pal-ffi:gl-enable pal-ffi:+gl-polygon-smooth+)) (with-gl pal-ffi:+gl-polygon+ (loop for p in points From tneste at common-lisp.net Wed Oct 24 19:59:56 2007 From: tneste at common-lisp.net (tneste) Date: Wed, 24 Oct 2007 15:59:56 -0400 (EDT) Subject: [pal-cvs] CVS pal-gui/examples Message-ID: <20071024195956.89F0819018@common-lisp.net> Update of /project/pal/cvsroot/pal-gui/examples In directory clnet:/tmp/cvs-serv22666/examples Modified Files: test.lisp Log Message: --- /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/22 19:25:23 1.8 +++ /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/24 19:59:56 1.9 @@ -1,7 +1,7 @@ ;; TODO: ;; ;; Exports, window sizing, box labels, dialogs, menus, tooltips, keyboard control, scrollwheel, fix pal's clipping -;; label, radio box, check box, joystick, scroll box, fix listbox, fix gauge, paragraph, text box, simple editor, drop box. +;; label, radio box, check box, joystick, scroll box, paragraph, text box, simple editor, drop box, tree view, gridbox ;; File open/save, directory, yes/no dialogs (in-package :pal-gui) @@ -28,11 +28,14 @@ :min-value 0 :max-value 255 :value 0)) (ag (make-instance 'h-gauge :parent left-box :min-value 0 :max-value 255 :value 0)) - (list (make-instance 'list-box :parent window-2 :items (loop for i from 0 to 100 collect (format nil "FooBar ~a" i)))) - (button (make-instance 'button :value "FooBar!" :parent window-2 :on-select (lambda (g pos) (message 'foo) (setf (parent-of g) nil))))) + (list (make-instance 'list-box :parent window-2 :items (loop for i from 0 to 30 collect (format nil "FooBar ~a" i)) + :multip nil + :on-select (lambda (g) + (message (value-of g))))) + (button (make-instance 'button :value "FooBar!" :parent window-2 :on-select (lambda (g) (message 'foo) (setf (parent-of g) nil)))) + (choice (make-instance 'choice-box :label "Foo" :parent window-2 :items '(Foo Bar Bazzo)))) (make-instance 'button :value "Button" :parent bottom-box) - (gui-loop () (setf (value-of meter) (get-fps)) (draw-image* (tag 'tile) (v 0 0) (v 0 0) 800 600) From tneste at common-lisp.net Wed Oct 24 19:59:56 2007 From: tneste at common-lisp.net (tneste) Date: Wed, 24 Oct 2007 15:59:56 -0400 (EDT) Subject: [pal-cvs] CVS pal-gui Message-ID: <20071024195956.D4BFE25002@common-lisp.net> Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv22666 Modified Files: gob.lisp gui.lisp pal-gui.asd widgets.lisp Log Message: --- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/22 19:25:24 1.9 +++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/24 19:59:56 1.10 @@ -76,8 +76,8 @@ (defmethod on-button-up ((gob gob) pos) nil) -(defgeneric on-select (gob pos)) -(defmethod on-select ((gob gob) pos) +(defgeneric on-select (gob)) +(defmethod on-select ((gob gob)) nil) (defgeneric on-drag (gob start-pos delta-pos)) @@ -262,7 +262,7 @@ (defgeneric highlight (g)) (defmethod repaint :after ((g highlighted)) - (when (or (armedp g) (and (activep g) (pointedp g))) + (when (and (or (not *armed-gob*) (eq g *armed-gob*)) (and (activep g) (pointedp g))) (highlight g))) --- /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/22 19:25:24 1.5 +++ /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/24 19:59:56 1.6 @@ -9,8 +9,6 @@ (case key (:key-mouse-1 (cond (*pointed-gob* - (when (eq *armed-gob* *pointed-gob*) - (on-select *armed-gob* (v- (get-mouse-pos) (absolute-pos-of *armed-gob*)))) (on-button-up *pointed-gob* (v- (get-mouse-pos) (absolute-pos-of *pointed-gob*)))) (t (pal::funcall? ,key-up-fn key))) (setf *armed-gob* nil)) @@ -32,14 +30,15 @@ (pal::do-event ,event key-up key-down ,mouse-motion-fn ,quit-fn) , at 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 (setf *pointed-gob* g) - (when (and g (not (activep g))) - (when *pointed-gob* - (on-leave *pointed-gob*)) - (on-enter g))))) + (t + (when (and g (not (activep g))) + (when *pointed-gob* + (on-leave *pointed-gob*)) + (on-enter g))))) (update-gui) (update-screen))))))) @@ -66,7 +65,12 @@ (defun init-gui () (setf *root* (make-instance 'root :parent nil) - *gui-font* (tag 'pal::default-font))) + *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 () (repaint *root*)) \ No newline at end of file --- /project/pal/cvsroot/pal-gui/pal-gui.asd 2007/10/15 19:14:36 1.1 +++ /project/pal/cvsroot/pal-gui/pal-gui.asd 2007/10/24 19:59:56 1.2 @@ -12,6 +12,8 @@ :depends-on ("gob")) (:file "gui" :depends-on ("gob" "widgets")) + (:file "present" + :depends-on ("widgets")) (:file "package")) :depends-on ("pal")) --- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/22 19:25:24 1.9 +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/24 19:59:56 1.10 @@ -51,7 +51,7 @@ (defclass widget (gob) ((on-drag :accessor on-drag-of :initarg :on-drag :initform (lambda (widget pos d) (declare (ignore widget pos d)) nil)) - (on-select :accessor on-select-of :initarg :on-select :initform (lambda (widget pos) (declare (ignore widget pos)) nil)) + (on-select :accessor on-select-of :initarg :on-select :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)) (on-enter :accessor on-enter-of :initarg :on-enter :initform (lambda (widget) (declare (ignore widget)) nil)) @@ -62,8 +62,8 @@ (unless (funcall (on-drag-of g) g pos d) (call-next-method))) -(defmethod on-select :around ((g widget) pos) - (unless (funcall (on-select-of g) g pos) +(defmethod on-select :around ((g widget)) + (unless (funcall (on-select-of g) g) (call-next-method))) (defmethod on-button-down :around ((g widget) pos) @@ -163,6 +163,10 @@ ((value :accessor value-of :initform "" :initarg :value)) (:default-initargs :x-expand-p t)) +(defmethod on-button-up ((g button) pos) + (when (eq *armed-gob* g) + (on-select g))) + (defmethod repaint ((g button)) (with-accessors ((width width-of) (height height-of) (value value-of)) g (cond @@ -276,6 +280,8 @@ (defclass list-view (widget) ((items :reader items-of :initarg :items :initform '()) (item-height :reader item-height-of :initarg :item-height :initform (get-m)) + (multip :reader multip :initarg :multip :initform nil) + (selected :accessor selected-of :initform nil) (scroll :reader scroll-of :initform 0)) (:default-initargs :x-expand-p t :y-expand-p t)) @@ -285,6 +291,24 @@ (setf (slot-value g 'scroll) (clamp 0 value (- (* (length (items-of g)) (item-height-of g)) (height-of g))))) +(defmethod convert-selected-of ((g list-view)) + (let ((selected (mapcar (lambda (i) (nth i (items-of g))) (selected-of g)))) + (if (multip g) + selected + (first selected)))) + +(defmethod on-button-down ((g list-view) pos) + (with-accessors ((selected selected-of) (scroll scroll-of) (item-height item-height-of)) g + (let* ((y (vy pos)) + (item (truncate (+ y scroll) item-height))) + (if (multip g) + (if (find item selected :test '=) + (setf selected (remove item selected)) + (pushnew item selected)) + (if (and selected (= (first selected) item)) + (on-select g) + (setf selected (list item))))))) + (defmethod repaint ((g list-view)) (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) @@ -295,8 +319,11 @@ (dolist (i (items-of g)) (when (and (> (* (1+ y) item-height) scroll) (< (* y item-height) (+ scroll height))) - (when (oddp y) - (draw-rectangle (v 0 0) width item-height 0 0 0 32)) + (cond + ((find y (selected-of g) :test '=) + (draw-rectangle (v 0 0) width item-height 0 0 0 160)) + ((oddp y) + (draw-rectangle (v 0 0) width item-height 0 0 0 32))) (present i g width item-height) (translate (v 0 item-height))) (incf y)))))))) @@ -305,12 +332,18 @@ (defclass list-box (h-box) - () - (:default-initargs :gap 3 :y-expand-p t :x-expand-p t)) + ((list-view :accessor list-view-of)) + (:default-initargs :gap 3)) -(defmethod initialize-instance :after ((g list-box) &key items (item-height (get-m)) &allow-other-keys) +(defmethod initialize-instance :after ((g list-box) &key items (item-height (get-m)) (multip nil) &allow-other-keys) (let* ((w (truncate (get-m) 1.5)) - (list-view (make-instance 'list-view :items items :item-height item-height :parent g)) + (list-view (make-instance 'list-view + :multip multip + :items items + :item-height item-height + :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 (make-instance 'v-slider :width w @@ -326,6 +359,7 @@ (incf (scroll-of list-view) (* d item-height)) (setf (value-of slider) (scroll-of list-view)) nil))) + (setf (list-view-of g) list-view) (make-instance 'button :parent slider-box :x-expand-p nil @@ -343,23 +377,25 @@ :on-button-down (scroll-fn 1) :on-drag (scroll-fn 0.3))))) +(defmethod value-of ((g list-box)) + (convert-selected-of (list-view-of g))) +(defclass choice-box (v-box) + ((items :reader items-of :initarg :items :initform '()) + (item-height :reader item-height-of :initarg :item-height :initform (get-m)) + (multip :reader multip :initarg :multip :initform nil) + (selected :accessor selected-of :initform nil))) - - - - - -(defgeneric present (object gob width height)) - -(defmethod present :around (object (g widget) width height) - (let ((ap (absolute-pos-of g))) - (with-clipping ((1+ (vx ap)) (1+ (vy ap)) (- (width-of g) 2) (- (height-of g) 2)) - (call-next-method)))) - -(defmethod present (object (g widget) width height) - (with-blend (:color *text-color*) - (draw-text (format nil "~a" object) (get-text-offset)))) \ No newline at end of file +(defmethod repaint ((g choice-box)) + (with-accessors ((items items-of) (item-height item-height-of) (width width-of) (height height-of)) g + (let ((i/2 (truncate item-height 2))) + (with-transformation () + (dolist (i items) + (draw-circle (v i/2 i/2) 6 0 0 0 255 :smoothp t) + (draw-circle (v i/2 i/2) 4 255 255 255 255 :smoothp t) + (with-transformation (:pos (v (get-m) 0)) + (present i g width item-height)) + (translate (v 0 item-height))))))) \ No newline at end of file From tneste at common-lisp.net Thu Oct 25 14:10:16 2007 From: tneste at common-lisp.net (tneste) Date: Thu, 25 Oct 2007 10:10:16 -0400 (EDT) Subject: [pal-cvs] CVS pal-gui Message-ID: <20071025141016.DEE5760220@common-lisp.net> Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv23076 Added Files: present.lisp Log Message: Added present.lisp --- /project/pal/cvsroot/pal-gui/present.lisp 2007/10/25 14:10:16 NONE +++ /project/pal/cvsroot/pal-gui/present.lisp 2007/10/25 14:10:16 1.1 (in-package :pal-gui) (defgeneric present (object gob width height)) (defmethod present :around (object (g widget) width height) (let ((ap (absolute-pos-of g))) (with-clipping ((1+ (vx ap)) (1+ (vy ap)) (- (width-of g) 2) (- (height-of g) 2)) (call-next-method)))) (defmethod present (object (g widget) width height) (with-blend (:color *text-color*) (draw-text (format nil "~a" object) (get-text-offset)))) From tneste at common-lisp.net Mon Oct 29 20:04:20 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 29 Oct 2007 15:04:20 -0500 (EST) Subject: [pal-cvs] CVS pal Message-ID: <20071029200420.1D96C2E1BD@common-lisp.net> Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv492 Modified Files: pal.lisp todo.txt Log Message: KEYSYM-CHAR now returns NIL for characters out the range 1 - 255. --- /project/pal/cvsroot/pal/pal.lisp 2007/10/24 18:07:03 1.36 +++ /project/pal/cvsroot/pal/pal.lisp 2007/10/29 20:04:19 1.37 @@ -1,7 +1,7 @@ ;; Notes: -;; add start/end args to draw-circle, use triangle-fan for circles +;; add start/end args to draw-circle ;; check for redundant close-quads, optimise rotations/offsets etc. in draw-image -;; newline support for draw-text, optimise gl state handling +;; optimise gl state handling, fix clipping, structured color values (declaim (optimize (speed 3) @@ -185,7 +185,10 @@ (defunct keysym-char (keysym) (symbol keysym) - (code-char (cffi:foreign-enum-value 'pal-ffi:sdl-key keysym))) + (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 () @@ -818,7 +821,7 @@ (defun load-font (font) - (let ((glyphs (make-array 255 :initial-element (make-glyph :width 1 :height 1 :xoff 0) :element-type 'glyph)) + (let ((glyphs (make-array 256 :initial-element (make-glyph :width 1 :height 1 :xoff 0) :element-type 'glyph)) (lines (with-open-file (file (data-path (concatenate 'string font ".fnt"))) (loop repeat 4 do (read-line file)) (loop for i from 0 to 94 collecting --- /project/pal/cvsroot/pal/todo.txt 2007/09/07 07:55:16 1.18 +++ /project/pal/cvsroot/pal/todo.txt 2007/10/29 20:04:20 1.19 @@ -10,8 +10,6 @@ - I would really like to see it run on OS X. -- The problems with Linux and some gfx drivers should be somehow fixed. - - Documentation and tutorials. @@ -22,8 +20,6 @@ - TTF support -- GUI - - Some sort of sprite library? - Network code? From tneste at common-lisp.net Mon Oct 29 20:06:01 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 29 Oct 2007 15:06:01 -0500 (EST) Subject: [pal-cvs] CVS pal-gui/examples Message-ID: <20071029200601.89483340A5@common-lisp.net> Update of /project/pal/cvsroot/pal-gui/examples In directory clnet:/tmp/cvs-serv701/examples Modified Files: test.lisp Added Files: colors.lisp files.lisp packing.lisp Log Message: Added more examples. Numerous other improvements. Nearing v 0.1 --- /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/24 19:59:56 1.9 +++ /project/pal/cvsroot/pal-gui/examples/test.lisp 2007/10/29 20:06:01 1.10 @@ -1,25 +1,28 @@ ;; TODO: ;; -;; Exports, window sizing, box labels, dialogs, menus, tooltips, keyboard control, scrollwheel, fix pal's clipping -;; label, radio box, check box, joystick, scroll box, paragraph, text box, simple editor, drop box, tree view, gridbox +;; 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 -(in-package :pal-gui) +(defpackage :test + (:use :cl :pal :pal-gui)) +(in-package :test) -(define-tags plane (load-image "lego-plane.png") - tile (load-image "ground.png")) (defun test () - (with-gui (:fps 200 :paths (merge-pathnames "examples/" pal::*pal-directory*)) - (let* ((window (make-instance 'window :pos (v 200 200) :width 300 :height 350)) + (with-gui (:paths (merge-pathnames "examples/" pal::*pal-directory*)) + (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-2 (make-instance 'window :width 200 :height 300)) (box (make-instance 'h-box :parent window)) (left-box (make-instance 'v-box :parent box :label "RGBA")) (right-box (make-instance 'v-box :parent box :label "Current FPS")) - (bottom-box (make-instance 'v-box :parent window :label "Bar")) + (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)) + (meter (make-instance 'h-meter :parent right-box :max-value 100 :on-repaint (lambda (g) (setf (value-of g) (get-fps)) nil))) (rg (make-instance 'h-gauge :parent left-box :min-value 0 :max-value 255 :value 0)) (gg (make-instance 'h-gauge :parent left-box @@ -28,20 +31,24 @@ :min-value 0 :max-value 255 :value 0)) (ag (make-instance 'h-gauge :parent left-box :min-value 0 :max-value 255 :value 0)) - (list (make-instance 'list-box :parent window-2 :items (loop for i from 0 to 30 collect (format nil "FooBar ~a" i)) - :multip nil - :on-select (lambda (g) - (message (value-of g))))) - (button (make-instance 'button :value "FooBar!" :parent window-2 :on-select (lambda (g) (message 'foo) (setf (parent-of g) nil)))) - (choice (make-instance 'choice-box :label "Foo" :parent window-2 :items '(Foo Bar Bazzo)))) + (list (make-instance 'list-widget :parent window-2 + :item-height 64 + :items (loop for i from 0 to 50 collect (format nil "FooBar ~a" i)) + :multip nil + :on-select (lambda (g) + (message (selected-of g))))) + (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))) + (pin (make-instance 'pin :value "Plane" :pos (v 400 300) :a 128)) + (text (make-instance 'text-widget :text "Text" :parent bottom-box))) - (make-instance 'button :value "Button" :parent bottom-box) (gui-loop () - (setf (value-of meter) (get-fps)) - (draw-image* (tag 'tile) (v 0 0) (v 0 0) 800 600) + (draw-image* tile (v 0 0) (v 0 0) 800 600) (with-blend (:color '(0 0 0 64)) - (draw-image (tag 'plane) (v 320 220))) + (draw-image plane (pos-of pin))) (with-blend (:color (list (value-of rg) (value-of gg) (value-of bg) (value-of ag))) - (draw-image (tag 'plane) (v 300 200))))))) + (draw-image plane (v- (pos-of pin) (v 10 10)))))))) ;; (test) \ No newline at end of file --- /project/pal/cvsroot/pal-gui/examples/colors.lisp 2007/10/29 20:06:01 NONE +++ /project/pal/cvsroot/pal-gui/examples/colors.lisp 2007/10/29 20:06:01 1.1 (in-package :pal-gui) (defstruct color r g b) (defparameter *bg* (make-color :r 0 :g 0 :b 0)) (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)))) (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)) (defun test () (with-gui (: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)) (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)))))) (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*)))))) ;; (test)--- /project/pal/cvsroot/pal-gui/examples/files.lisp 2007/10/29 20:06:01 NONE +++ /project/pal/cvsroot/pal-gui/examples/files.lisp 2007/10/29 20:06:01 1.1 (in-package :pal-gui) (defclass file-list (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) (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))))) (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))) (update-view g)) (defmethod update-view ((g file-list)) (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 "*")))) (defun test () (with-gui () (let* ((window (make-instance 'window :pos (v 200 200) :width 300 :height 200)) (hbox (make-instance 'file-list :parent window :label "Choose"))) (gui-loop () (clear-screen 150 150 150))))) ;; (test)--- /project/pal/cvsroot/pal-gui/examples/packing.lisp 2007/10/29 20:06:01 NONE +++ /project/pal/cvsroot/pal-gui/examples/packing.lisp 2007/10/29 20:06:01 1.1 (in-package :pal-gui) (defun test () (with-gui () (let* ((window (make-instance 'window :pos (v 200 200) :width 300 :height 240)) (hbox (make-instance 'h-box :parent window)) (left-box (make-instance 'v-box :parent hbox :label "Left")) (right-box (make-instance 'v-box :parent hbox :label "Right")) (bottom-box (make-instance 'v-box :parent window :label "Bottom" :y-expand-p nil))) (let ((a (make-instance 'button :value "Button" :parent right-box)) (b (make-instance 'button :value "Button" :parent right-box)) (c (make-instance 'button :value "Button" :parent right-box)) (d (make-instance 'button :value "Button" :parent right-box)) (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)))))) ;; (test) (defun test () (with-gui () (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)))))) ;; (test) (defun test () (with-gui () (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))) (a (make-instance 'button :value "Button" :parent hbox)) (f (make-instance 'filler :parent hbox)) (b (make-instance 'button :value "Button" :parent hbox)) (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)))) (gui-loop () (clear-screen 50 50 255)))))) ;; (test) From tneste at common-lisp.net Mon Oct 29 20:06:01 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 29 Oct 2007 15:06:01 -0500 (EST) Subject: [pal-cvs] CVS pal-gui Message-ID: <20071029200601.DD0193D00B@common-lisp.net> Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv701 Modified Files: gob.lisp gui.lisp package.lisp present.lisp widgets.lisp Log Message: Added more examples. Numerous other improvements. Nearing v 0.1 --- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/24 19:59:56 1.10 +++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/29 20:06:01 1.11 @@ -80,6 +80,10 @@ (defmethod on-select ((gob gob)) nil) +(defgeneric on-key-down (gob char)) +(defmethod on-key-down ((gob gob) char) + nil) + (defgeneric on-drag (gob start-pos delta-pos)) (defmethod on-drag ((gob gob) start-pos delta) (declare (ignore start-pos delta)) @@ -89,6 +93,10 @@ (defmethod pointedp ((gob gob)) (eq *pointed-gob* gob)) +(defgeneric focusedp (gob)) +(defmethod focusedp ((gob gob)) + (eq *focused-gob* gob)) + (defgeneric armedp (gob)) (defmethod armedp ((gob gob)) (eq *armed-gob* gob)) @@ -181,10 +189,14 @@ (exp-size (- height (+ (* (1- (length (childs-of g))) (gap-of g)) (* 2 (y-pad-of g)) (loop for c in (remove-if 'y-expand-p (childs-of g)) summing (min-height-of c)))))) (dolist (c childs) - (when (y-expand-p c) - (setf (height-of c) (max (min-height-of c) (truncate exp-size exp-count)))) - (when (x-expand-p c) - (setf (width-of c) (max 1 (- width (* 2 x-pad))))))) + (setf (height-of c) + (if (y-expand-p c) + (max (min-height-of c) (truncate exp-size exp-count)) + (min-height-of c))) + (setf (width-of c) + (if (x-expand-p c) + (max 1 (- width (* 2 x-pad))) + (min-width-of c))))) (let ((cpos (v x-pad y-pad))) (dolist (c (reverse childs)) (setf (pos-of c) cpos) @@ -214,10 +226,14 @@ (exp-size (- width (+ (* (1- (length (childs-of g))) (gap-of g)) (* 2 (x-pad-of g)) (loop for c in (remove-if 'x-expand-p (childs-of g)) summing (min-width-of c)))))) (dolist (c childs) - (when (x-expand-p c) - (setf (width-of c) (max (min-width-of c) (truncate exp-size exp-count)))) - (when (y-expand-p c) - (setf (height-of c) (max 1 (- height (* 2 y-pad))))))) + (setf (width-of c) + (if (x-expand-p c) + (max (min-width-of c) (truncate exp-size exp-count)) + (min-width-of c))) + (setf (height-of c) + (if (y-expand-p c) + (max 1 (- height (* 2 y-pad))) + (min-height-of c))))) (let ((cpos (v x-pad y-pad))) (dolist (c (reverse childs)) (setf (pos-of c) cpos) --- /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/24 19:59:56 1.6 +++ /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/29 20:06:01 1.7 @@ -2,6 +2,7 @@ (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" (let ((event (gensym))) `(block event-loop (cffi:with-foreign-object (,event :char 500) @@ -19,12 +20,17 @@ (return-from event-loop))) (:key-mouse-1 (cond (*pointed-gob* - (setf *drag-start-pos* (get-mouse-pos)) - (setf *relative-drag-start-pos* (v- *drag-start-pos* (absolute-pos-of *pointed-gob*))) - (setf *armed-gob* *pointed-gob*) + (setf *drag-start-pos* (get-mouse-pos) + *relative-drag-start-pos* (v- *drag-start-pos* (absolute-pos-of *pointed-gob*)) + *focused-gob* *pointed-gob* + *armed-gob* *pointed-gob*) (on-button-down *pointed-gob* (v- (get-mouse-pos) (absolute-pos-of *pointed-gob*)))) - (t (pal::funcall? ,key-down-fn key)))) - (otherwise (pal::funcall? ,key-down-fn key)))))) + (t (setf *focused-gob* nil) + (pal::funcall? ,key-down-fn key)))) + (otherwise (if *focused-gob* + (let ((char (keysym-char key))) + (when (and char (graphic-char-p char)) (on-key-down *focused-gob* char))) + (pal::funcall? ,key-down-fn key))))))) (loop (pal::do-event ,event key-up key-down ,mouse-motion-fn ,quit-fn) @@ -39,8 +45,7 @@ (when *pointed-gob* (on-leave *pointed-gob*)) (on-enter g))))) - (update-gui) - (update-screen))))))) + (update-gui))))))) (defmacro with-gui (args &body body) @@ -73,4 +78,9 @@ *armed-gob* nil)) (defun update-gui () - (repaint *root*)) \ No newline at end of file + "Like PAL:UPDATE but also updates the GUI" + (pal::close-quads) + (reset-blend) + (pal-ffi:gl-load-identity) + (repaint *root*) + (update-screen)) \ No newline at end of file --- /project/pal/cvsroot/pal-gui/package.lisp 2007/10/15 19:14:36 1.1 +++ /project/pal/cvsroot/pal-gui/package.lisp 2007/10/29 20:06:01 1.2 @@ -1,2 +1,16 @@ (defpackage #:pal-gui - (:use :common-lisp :pal)) + (:use :common-lisp :pal) + (:export #:with-gui #:init-gui #:update-gui #:gui-loop + + #:present + + #:window #:button #:list-widget #:text-widget #:choice-widget #:pin #:label #:h-gauge #:v-slider #:h-meter + #:sliding #:clipping #:highlighted + #: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 + + #:pos-of #:width-of #:height-of #:childs-of #:parent-of #:min-width-of #:min-height-of #:x-expand-p #:y-expand-p + #:absolute-pos-of #:point-inside-p #:pointedp #:focusedp #:armedp #:activep + #:raise #:lower + #:label-of #:value-of #:text-of #:state-of #:min-value #:max-value #:page-size-of #:items-of #:item-height-of #:selected-of)) --- /project/pal/cvsroot/pal-gui/present.lisp 2007/10/25 14:10:16 1.1 +++ /project/pal/cvsroot/pal-gui/present.lisp 2007/10/29 20:06:01 1.2 @@ -3,11 +3,50 @@ (defgeneric present (object gob width height)) -(defmethod present :around (object (g widget) width height) - (let ((ap (absolute-pos-of g))) - (with-clipping ((1+ (vx ap)) (1+ (vy ap)) (- (width-of g) 2) (- (height-of g) 2)) - (call-next-method)))) (defmethod present (object (g widget) width height) (with-blend (:color *text-color*) - (draw-text (format nil "~a" object) (get-text-offset)))) \ No newline at end of file + (draw-text (format nil "~a" object) (v (vx (get-text-offset)) + (- (truncate height 2) (truncate (get-font-height *gui-font*) 2) 1))))) + + + +(defmethod present ((image image) (g widget) width height) + (draw-image image (v 0 0) :scale (min (/ height (image-height image)) (/ width (image-width image))))) + + + +(defmethod present ((s (eql :up-arrow)) (g widget) width height) + (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)) + + +(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)) + + +(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)) + + +(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)) + + +(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)) + + +(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)) --- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/24 19:59:56 1.10 +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/29 20:06:01 1.11 @@ -52,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)) (on-select :accessor on-select-of :initarg :on-select :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)) + (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))) @@ -66,6 +68,10 @@ (unless (funcall (on-select-of g) g) (call-next-method))) +(defmethod repaint :around ((g widget)) + (unless (funcall (on-repaint-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))) @@ -74,6 +80,10 @@ (unless (funcall (on-button-up-of g) g pos) (call-next-method))) +(defmethod on-key-down :around ((g widget) char) + (unless (funcall (on-key-down-of g) g char) + (call-next-method))) + (defmethod on-enter :around ((g widget)) (unless (funcall (on-enter-of g) g) (call-next-method))) @@ -92,16 +102,20 @@ ((label :accessor label-of :initform nil :initarg :label)) (:default-initargs :activep nil :x-expand-p t :y-expand-p t)) -(defmethod initialize-instance :after ((g box) &key label) - (when label - (setf (y-pad-of g) (truncate (get-m) 2) - (x-pad-of g) (truncate (get-m) 2)))) - (defmethod repaint ((g box)) (when (label-of g) - (draw-rectangle (v 0 0) (width-of g) (height-of g) 0 0 0 128 :fill nil) - (with-blend (:color *text-color*) - (draw-text (label-of g) (v- (get-text-offset) (v 0 (truncate (get-m) 2))))))) + (let ((text-offset (get-text-offset))) + (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 (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))))))))) @@ -109,13 +123,20 @@ () (:default-initargs :x-pad 0 :y-pad 0 :gap (truncate (get-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)))) (defclass h-box (box h-packing) () (:default-initargs :x-pad 0 :y-pad 0 :gap (truncate (get-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)))) @@ -158,36 +179,69 @@ +(defclass label (widget) + ((value :reader value-of :initform "" :initarg :value))) + +(defmethod initialize-instance :after ((g label) &key value &allow-other-keys) + (when (stringp value) + (setf (width-of g) (get-text-bounds value)))) + +(defmethod (setf value-of) (value (g label)) + (when (stringp value) + (setf (width-of g) (get-text-bounds value))) + (setf (slot-value g 'value) value)) + +(defmethod repaint ((g label)) + (present (value-of g) g (width-of g) (height-of g))) + + + +(defclass pin (label sliding highlighted) + ((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)) + (: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)) + + + (defclass button (widget highlighted) - ((value :accessor value-of :initform "" :initarg :value)) + ((value :accessor value-of :initform "" :initarg :value) + (stickyp :reader stickyp :initform nil :initarg :stickyp) + (state :accessor state-of :initform nil :initarg :state)) (:default-initargs :x-expand-p t)) (defmethod on-button-up ((g button) pos) (when (eq *armed-gob* g) - (on-select g))) + (on-select g) + (when (stickyp g) + (setf (state-of g) (not (state-of g)))))) (defmethod repaint ((g button)) (with-accessors ((width width-of) (height height-of) (value value-of)) g (cond - ((armedp g) + ((or (state-of g) (armedp g)) (draw-frame (v 0 0) width height *widget-color* :style :sunken) (with-transformation (:pos (v 1 1)) - (with-blend (:color *text-color*) - (present value g width height)))) + (present value g width height))) (t (draw-frame (v 0 0) width height *widget-color* :style :raised) - (with-blend (:color *text-color*) - (present value g width height)))))) + (present value g width height))))) (defclass h-gauge (widget highlighted) - ((value :reader value-of :initarg :value :initform 0) - (min-value :reader min-value-of :initarg :min-value :initform 0) - (max-value :reader max-value-of :initarg :max-value :initform 100)) + ((value :accessor value-of :initarg :value :initform 0) + (min-value :accessor min-value-of :initarg :min-value :initform 0) + (max-value :accessor max-value-of :initarg :max-value :initform 100)) (:default-initargs :x-expand-p t)) (defgeneric (setf value-of) (value g)) @@ -219,10 +273,10 @@ (defclass v-slider (widget highlighted) - ((value :reader value-of :initarg :value :initform 0) - (page-size :reader page-size-of :initarg :page-size :initform 1) - (min-value :reader min-value-of :initarg :min-value :initform 0) - (max-value :reader max-value-of :initarg :max-value :initform 100)) + ((value :accessor value-of :initarg :value :initform 0) + (page-size :accessor page-size-of :initarg :page-size :initform 1) + (min-value :accessor min-value-of :initarg :min-value :initform 0) + (max-value :accessor max-value-of :initarg :max-value :initform 100)) (:default-initargs :y-expand-p t)) (defmethod (setf value-of) (value (g v-slider)) @@ -278,7 +332,7 @@ (defclass list-view (widget) - ((items :reader items-of :initarg :items :initform '()) + ((items :accessor items-of :initarg :items :initform '()) (item-height :reader item-height-of :initarg :item-height :initform (get-m)) (multip :reader multip :initarg :multip :initform nil) (selected :accessor selected-of :initform nil) @@ -301,41 +355,41 @@ (with-accessors ((selected selected-of) (scroll scroll-of) (item-height item-height-of)) g (let* ((y (vy pos)) (item (truncate (+ y scroll) item-height))) - (if (multip g) - (if (find item selected :test '=) - (setf selected (remove item selected)) - (pushnew item selected)) - (if (and selected (= (first selected) item)) - (on-select g) - (setf selected (list item))))))) + (when (< item (length (items-of g))) + (if (multip g) + (if (find item selected :test '=) + (setf selected (remove item selected)) + (pushnew item selected)) + (if (and selected (= (first selected) item)) + (on-select g) + (setf selected (list item)))))))) (defmethod repaint ((g list-view)) (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-blend (:color *text-color*) - (with-transformation (:pos (v 0 (- (mod scroll item-height)))) - (let ((y 0)) - (dolist (i (items-of g)) - (when (and (> (* (1+ y) item-height) scroll) - (< (* y item-height) (+ scroll height))) - (cond - ((find y (selected-of g) :test '=) - (draw-rectangle (v 0 0) width item-height 0 0 0 160)) - ((oddp y) - (draw-rectangle (v 0 0) width item-height 0 0 0 32))) - (present i g width item-height) - (translate (v 0 item-height))) - (incf y)))))))) + (with-transformation (:pos (v 0 (- (mod scroll item-height)))) + (let ((y 0)) + (dolist (i (items-of g)) + (when (and (> (* (1+ y) item-height) scroll) + (< (* y item-height) (+ scroll height))) + (when (oddp y) + (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)) + (translate (v 0 item-height))) + (incf y))))))) -(defclass list-box (h-box) - ((list-view :accessor list-view-of)) +(defclass list-widget (h-box) + ((list-view :accessor list-view-of) + (slider :accessor slider-of)) (:default-initargs :gap 3)) -(defmethod initialize-instance :after ((g list-box) &key items (item-height (get-m)) (multip nil) &allow-other-keys) +(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)) (list-view (make-instance 'list-view :multip multip @@ -359,8 +413,10 @@ (incf (scroll-of list-view) (* d item-height)) (setf (value-of slider) (scroll-of list-view)) nil))) - (setf (list-view-of g) list-view) + (setf (list-view-of g) list-view + (slider-of g) slider) (make-instance 'button + :value :up-arrow :parent slider-box :x-expand-p nil :y-expand-p nil @@ -369,6 +425,7 @@ :on-button-down (scroll-fn -1) :on-drag (scroll-fn -0.3)) (make-instance 'button + :value :down-arrow :parent slider-box :x-expand-p nil :y-expand-p nil @@ -377,25 +434,66 @@ :on-button-down (scroll-fn 1) :on-drag (scroll-fn 0.3))))) -(defmethod value-of ((g list-box)) +(defmethod selected-of ((g list-widget)) (convert-selected-of (list-view-of g))) +(defmethod items-of ((g list-widget)) + (items-of (list-view-of g))) +(defmethod (setf items-of) (items (g list-widget)) + (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)))) + + + +(defclass choice-widget (v-box) + ((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))) + +(defmethod selected-of ((g choice-widget)) + (mapcar 'value-of (remove-if-not 'state-of (childs-of g)))) -(defclass choice-box (v-box) - ((items :reader items-of :initarg :items :initform '()) - (item-height :reader item-height-of :initarg :item-height :initform (get-m)) - (multip :reader multip :initarg :multip :initform nil) - (selected :accessor selected-of :initform nil))) -(defmethod repaint ((g choice-box)) - (with-accessors ((items items-of) (item-height item-height-of) (width width-of) (height height-of)) g - (let ((i/2 (truncate item-height 2))) - (with-transformation () - (dolist (i items) - (draw-circle (v i/2 i/2) 6 0 0 0 255 :smoothp t) - (draw-circle (v i/2 i/2) 4 255 255 255 255 :smoothp t) - (with-transformation (:pos (v (get-m) 0)) - (present i g width item-height)) - (translate (v 0 item-height))))))) \ No newline at end of file + +(defclass text-widget (widget) + ((point :accessor point-of :initform 0) + (text :accessor text-of :initarg :text :initform "")) + (:default-initargs :x-expand-p t)) + +(defmethod initialize-instance :after ((g text-widget) &key text &allow-other-keys) + (setf (point-of g) (length text))) + +(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))))) + (with-blend (:color *text-color*) + (draw-text text offset) + (when (focusedp g) + (draw-rectangle (v point-x (vy offset)) + 2 (- height (* 2 (vy offset))) + 0 0 0 255)))))) + +(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 From tneste at common-lisp.net Mon Oct 29 21:09:20 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 29 Oct 2007 16:09:20 -0500 (EST) Subject: [pal-cvs] CVS pal-gui/examples Message-ID: <20071029210920.C8B612E1CB@common-lisp.net> 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))) From tneste at common-lisp.net Mon Oct 29 21:09:21 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 29 Oct 2007 16:09:21 -0500 (EST) Subject: [pal-cvs] CVS pal-gui Message-ID: <20071029210921.3B44932047@common-lisp.net> 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)) From tneste at common-lisp.net Tue Oct 30 00:20:40 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 29 Oct 2007 19:20:40 -0500 (EST) Subject: [pal-cvs] CVS pal-gui/examples Message-ID: <20071030002040.D927249087@common-lisp.net> 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"))) From tneste at common-lisp.net Tue Oct 30 00:20:41 2007 From: tneste at common-lisp.net (tneste) Date: Mon, 29 Oct 2007 19:20:41 -0500 (EST) Subject: [pal-cvs] CVS pal-gui Message-ID: <20071030002041.A02C94B023@common-lisp.net> 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) , at 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 From tneste at common-lisp.net Tue Oct 30 20:43:11 2007 From: tneste at common-lisp.net (tneste) Date: Tue, 30 Oct 2007 15:43:11 -0500 (EST) Subject: [pal-cvs] CVS pal Message-ID: <20071030204311.9782C55356@common-lisp.net> 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) , at 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 , at 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))) From tneste at common-lisp.net Tue Oct 30 20:44:45 2007 From: tneste at common-lisp.net (tneste) Date: Tue, 30 Oct 2007 15:44:45 -0500 (EST) Subject: [pal-cvs] CVS pal-gui/examples Message-ID: <20071030204445.ECCFE55356@common-lisp.net> 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 From tneste at common-lisp.net Tue Oct 30 20:44:46 2007 From: tneste at common-lisp.net (tneste) Date: Tue, 30 Oct 2007 15:44:46 -0500 (EST) Subject: [pal-cvs] CVS pal-gui Message-ID: <20071030204446.4187D55395@common-lisp.net> 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 , at 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 From tneste at common-lisp.net Wed Oct 31 12:50:42 2007 From: tneste at common-lisp.net (tneste) Date: Wed, 31 Oct 2007 07:50:42 -0500 (EST) Subject: [pal-cvs] CVS pal-gui/examples Message-ID: <20071031125042.46C0A1B017@common-lisp.net> 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)) From tneste at common-lisp.net Wed Oct 31 12:51:23 2007 From: tneste at common-lisp.net (tneste) Date: Wed, 31 Oct 2007 07:51:23 -0500 (EST) Subject: [pal-cvs] CVS pal Message-ID: <20071031125123.257BE1B018@common-lisp.net> 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. From tneste at common-lisp.net Wed Oct 31 12:51:23 2007 From: tneste at common-lisp.net (tneste) Date: Wed, 31 Oct 2007 07:51:23 -0500 (EST) Subject: [pal-cvs] CVS pal/documentation Message-ID: <20071031125123.651071B017@common-lisp.net> 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 at 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] From tneste at common-lisp.net Wed Oct 31 12:51:23 2007 From: tneste at common-lisp.net (tneste) Date: Wed, 31 Oct 2007 07:51:23 -0500 (EST) Subject: [pal-cvs] CVS pal/examples Message-ID: <20071031125123.AEA041B018@common-lisp.net> Update of /project/pal/cvsroot/pal/examples In directory clnet:/tmp/cvs-serv6234/examples Modified Files: hello.lisp images.lisp swarm.lisp teddy.lisp Log Message: Some polishing. Version 1.1 --- /project/pal/cvsroot/pal/examples/hello.lisp 2007/07/27 21:25:40 1.9 +++ /project/pal/cvsroot/pal/examples/hello.lisp 2007/10/31 12:51:23 1.10 @@ -18,7 +18,7 @@ 2))))) (pal:set-blend-color 0 0 0 255) (pal:draw-text "Hello from PAL" (pal:v+ midpoint (pal:v 5 5)) font) - (pal:reset-blend-mode) + (pal:reset-blend) (pal:draw-text "Hello from PAL" midpoint font))) (pal:wait-keypress))) --- /project/pal/cvsroot/pal/examples/images.lisp 2007/09/07 07:55:15 1.8 +++ /project/pal/cvsroot/pal/examples/images.lisp 2007/10/31 12:51:23 1.9 @@ -57,7 +57,7 @@ ;; Press left mousebutton to capture part of the screen as a new cursor. ;; Note that altough the allocated images are released when PAL is closed we really should manually release - ;; the old cursor image with FREE-RESOURCE if we keep allocating lots of new images. + ;; the old cursor image with FREE-RESOURCE if we keep allocating lots of new images. (when (key-pressed-p :key-mouse-1) (set-cursor (image-from-array nil --- /project/pal/cvsroot/pal/examples/swarm.lisp 2007/07/21 16:34:16 1.5 +++ /project/pal/cvsroot/pal/examples/swarm.lisp 2007/10/31 12:51:23 1.6 @@ -1,5 +1,6 @@ ;; NOTE: the following example is intentionally slow and somewhat obfuscated + (defun swarm () (let ((vectors nil)) (pal:with-pal (:width 1024 :height 768) @@ -9,7 +10,7 @@ (setf vectors (append vectors (loop repeat 50 collecting (cons (pal:get-mouse-pos) (pal:v-random 5.0)))))))) (pal:draw-rectangle (pal:v 0 0) 1024 768 0 0 0 128) - (pal:with-blend (:color '(255 128 128 255)) + (pal:with-blend (:color (pal:color 255 128 128)) (pal:draw-text "Use left mousekey to add particles." (pal:v 0 0))) (let ((midpoint (pal:v/ (reduce 'pal:v+ vectors :initial-value (pal:v 0 0) :key 'car) --- /project/pal/cvsroot/pal/examples/teddy.lisp 2007/09/07 07:55:15 1.10 +++ /project/pal/cvsroot/pal/examples/teddy.lisp 2007/10/31 12:51:23 1.11 @@ -121,7 +121,7 @@ ;; then the sprites, first the shadows ;; sorting the sprites and their shadows according to their altitude is left as an exercise to the reader - (with-blend (:color '(0 0 0 128)) + (with-blend (:color (color 0 0 0 128)) (dolist (i *sprites*) (with-transformation (:pos (v (alt-of i) (alt-of i))) (draw i)))) @@ -148,6 +148,7 @@ (draw-fps) ;; Draw the frames/second counter to the top left corner. (draw-text "Press key to select blend-mode:" (v 200 (* 0 (get-font-height)))) - (draw-text "1=nil 2=:blend 3=:additive" (v 200 (* 1 (get-font-height))))))) + (draw-text "1=nil 2=:blend 3=:additive" (v 200 (* 1 (get-font-height)))) + (draw-text "Press F to fade out the music." (v 200 (* 2 (get-font-height))))))) ;; (example) \ No newline at end of file From tneste at common-lisp.net Wed Oct 31 22:38:22 2007 From: tneste at common-lisp.net (tneste) Date: Wed, 31 Oct 2007 17:38:22 -0500 (EST) Subject: [pal-cvs] CVS pal/documentation Message-ID: <20071031223822.33C7C2E183@common-lisp.net> Update of /project/pal/cvsroot/pal/documentation In directory clnet:/tmp/cvs-serv19301/documentation Modified Files: pal-manual.lyx Log Message: Fixed a bug in WITH-RESOURCE. Swapped the arguments of IMAGE-FROM-ARRAY. --- /project/pal/cvsroot/pal/documentation/pal-manual.lyx 2007/10/31 12:51:23 1.3 +++ /project/pal/cvsroot/pal/documentation/pal-manual.lyx 2007/10/31 22:38:22 1.4 @@ -1761,7 +1761,7 @@ \end_layout \begin_layout Subsection -SET-BLEND +SET-BLEND-MODE \end_layout \begin_layout Subsection From tneste at common-lisp.net Wed Oct 31 22:38:22 2007 From: tneste at common-lisp.net (tneste) Date: Wed, 31 Oct 2007 17:38:22 -0500 (EST) Subject: [pal-cvs] CVS pal Message-ID: <20071031223822.9A3DD2E183@common-lisp.net> Update of /project/pal/cvsroot/pal In directory clnet:/tmp/cvs-serv19301 Modified Files: package.lisp pal-macros.lisp pal.lisp Log Message: Fixed a bug in WITH-RESOURCE. Swapped the arguments of IMAGE-FROM-ARRAY. --- /project/pal/cvsroot/pal/package.lisp 2007/10/30 20:43:10 1.21 +++ /project/pal/cvsroot/pal/package.lisp 2007/10/31 22:38:22 1.22 @@ -358,7 +358,7 @@ (defpackage #:pal (:use :common-lisp) (:import-from :pal-ffi - #:free-resource #:register-resource #:load-foreign-libraries + #:register-resource #:load-foreign-libraries #:image-p #:image #:font #:font-p #:sample #:music #:sample-p #:music-p #:resource #:resource-p #:image-width #:image-height #:u8 #:u11 #:u16) @@ -452,7 +452,7 @@ #: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/30 20:43:10 1.16 +++ /project/pal/cvsroot/pal/pal-macros.lisp 2007/10/31 22:38:22 1.17 @@ -84,7 +84,7 @@ `(let ((,resource ,init-form)) (prog1 (progn , at body) - (free-resource ,resource)))) + (pal:free-resource ,resource)))) (defmacro with-default-settings (&body body) --- /project/pal/cvsroot/pal/pal.lisp 2007/10/31 12:51:22 1.39 +++ /project/pal/cvsroot/pal/pal.lisp 2007/10/31 22:38:22 1.40 @@ -115,6 +115,10 @@ (defun random-elt (sequence) (elt sequence (random (length sequence)))) +(defun free-resource (resource) + (close-quads) + (pal-ffi:free-resource resource)) + (defun free-all-resources () (reset-tags) (pal-ffi:halt-music) @@ -404,7 +408,7 @@ (cffi:mem-ref b :uint8) (cffi:mem-ref a :uint8))))) -(defun image-from-array (smoothp array) +(defun image-from-array (array smoothp) (image-from-fn (array-dimension array 0) (array-dimension array 1) smoothp From tneste at common-lisp.net Wed Oct 31 22:39:33 2007 From: tneste at common-lisp.net (tneste) Date: Wed, 31 Oct 2007 17:39:33 -0500 (EST) Subject: [pal-cvs] CVS pal/examples Message-ID: <20071031223933.6106B2E1B7@common-lisp.net> Update of /project/pal/cvsroot/pal/examples In directory clnet:/tmp/cvs-serv19546 Added Files: vecto.lisp Log Message: Added vecto.lisp. --- /project/pal/cvsroot/pal/examples/vecto.lisp 2007/10/31 22:39:33 NONE +++ /project/pal/cvsroot/pal/examples/vecto.lisp 2007/10/31 22:39:33 1.1 ;;; Few utility functions and examples of using PAL with Vecto (http://www.xach.com/lisp/vecto/) (defpackage :pal-vecto (:use :cl) (:export state-to-image)) (in-package :pal-vecto) (defun state-to-image (smoothp) "Convert current Vecto graphics state to PAL image." (let* ((data (vecto::image-data vecto::*graphics-state*)) (width (vecto::width vecto::*graphics-state*)) (height (vecto::height vecto::*graphics-state*)) (image (make-array (list width height)))) (pal:do-n (x width y height) (let ((pixel (+ (* x 4) (* y width 4)))) (setf (aref image x y) (list (aref data pixel) (aref data (+ pixel 1)) (aref data (+ pixel 2)) (aref data (+ pixel 3)))))) (pal:image-from-array image smoothp)))