[pal-cvs] CVS pal-gui
tneste
tneste at common-lisp.net
Mon Oct 15 19:14:36 UTC 2007
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]
More information about the Pal-cvs
mailing list