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