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) ,@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 ,@args)) (init-gui) (unwind-protect (progn ,@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]