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