[pal-cvs] CVS pal-gui/examples
tneste
tneste at common-lisp.net
Mon Oct 29 20:06:01 UTC 2007
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)
More information about the Pal-cvs
mailing list