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))