Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv22666
Modified Files: gob.lisp gui.lisp pal-gui.asd widgets.lisp Log Message:
--- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/22 19:25:24 1.9 +++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/24 19:59:56 1.10 @@ -76,8 +76,8 @@ (defmethod on-button-up ((gob gob) pos) nil)
-(defgeneric on-select (gob pos)) -(defmethod on-select ((gob gob) pos) +(defgeneric on-select (gob)) +(defmethod on-select ((gob gob)) nil)
(defgeneric on-drag (gob start-pos delta-pos)) @@ -262,7 +262,7 @@ (defgeneric highlight (g))
(defmethod repaint :after ((g highlighted)) - (when (or (armedp g) (and (activep g) (pointedp g))) + (when (and (or (not *armed-gob*) (eq g *armed-gob*)) (and (activep g) (pointedp g))) (highlight g)))
--- /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/22 19:25:24 1.5 +++ /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/24 19:59:56 1.6 @@ -9,8 +9,6 @@ (case key (:key-mouse-1 (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))) (setf *armed-gob* nil)) @@ -32,14 +30,15 @@ (pal::do-event ,event key-up key-down ,mouse-motion-fn ,quit-fn) ,@redraw (let ((g (first (last (active-gobs-at-point (get-mouse-pos) *root*))))) + (setf *pointed-gob* g) (cond (*armed-gob* (on-drag *armed-gob* *relative-drag-start-pos* (v- *drag-start-pos* (get-mouse-pos)))) - (t (setf *pointed-gob* g) - (when (and g (not (activep g))) - (when *pointed-gob* - (on-leave *pointed-gob*)) - (on-enter g))))) + (t + (when (and g (not (activep g))) + (when *pointed-gob* + (on-leave *pointed-gob*)) + (on-enter g))))) (update-gui) (update-screen)))))))
@@ -66,7 +65,12 @@
(defun init-gui () (setf *root* (make-instance 'root :parent nil) - *gui-font* (tag 'pal::default-font))) + *gui-font* (tag 'pal::default-font) + *drag-start-pos* nil + *relative-drag-start-pos* nil + *focused-gob* nil + *pointed-gob* nil + *armed-gob* nil))
(defun update-gui () (repaint *root*)) \ No newline at end of file --- /project/pal/cvsroot/pal-gui/pal-gui.asd 2007/10/15 19:14:36 1.1 +++ /project/pal/cvsroot/pal-gui/pal-gui.asd 2007/10/24 19:59:56 1.2 @@ -12,6 +12,8 @@ :depends-on ("gob")) (:file "gui" :depends-on ("gob" "widgets")) + (:file "present" + :depends-on ("widgets")) (:file "package")) :depends-on ("pal"))
--- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/22 19:25:24 1.9 +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/24 19:59:56 1.10 @@ -51,7 +51,7 @@
(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 pos) (declare (ignore widget pos)) nil)) + (on-select :accessor on-select-of :initarg :on-select :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-enter :accessor on-enter-of :initarg :on-enter :initform (lambda (widget) (declare (ignore widget)) nil)) @@ -62,8 +62,8 @@ (unless (funcall (on-drag-of g) g pos d) (call-next-method)))
-(defmethod on-select :around ((g widget) pos) - (unless (funcall (on-select-of g) g pos) +(defmethod on-select :around ((g widget)) + (unless (funcall (on-select-of g) g) (call-next-method)))
(defmethod on-button-down :around ((g widget) pos) @@ -163,6 +163,10 @@ ((value :accessor value-of :initform "" :initarg :value)) (:default-initargs :x-expand-p t))
+(defmethod on-button-up ((g button) pos) + (when (eq *armed-gob* g) + (on-select g))) + (defmethod repaint ((g button)) (with-accessors ((width width-of) (height height-of) (value value-of)) g (cond @@ -276,6 +280,8 @@ (defclass list-view (widget) ((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) (scroll :reader scroll-of :initform 0)) (:default-initargs :x-expand-p t :y-expand-p t))
@@ -285,6 +291,24 @@ (setf (slot-value g 'scroll) (clamp 0 value (- (* (length (items-of g)) (item-height-of g)) (height-of g)))))
+(defmethod convert-selected-of ((g list-view)) + (let ((selected (mapcar (lambda (i) (nth i (items-of g))) (selected-of g)))) + (if (multip g) + selected + (first selected)))) + +(defmethod on-button-down ((g list-view) pos) + (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))))))) + (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) @@ -295,8 +319,11 @@ (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)) + (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)))))))) @@ -305,12 +332,18 @@
(defclass list-box (h-box) - () - (:default-initargs :gap 3 :y-expand-p t :x-expand-p t)) + ((list-view :accessor list-view-of)) + (:default-initargs :gap 3))
-(defmethod initialize-instance :after ((g list-box) &key items (item-height (get-m)) &allow-other-keys) +(defmethod initialize-instance :after ((g list-box) &key items (item-height (get-m)) (multip nil) &allow-other-keys) (let* ((w (truncate (get-m) 1.5)) - (list-view (make-instance 'list-view :items items :item-height item-height :parent g)) + (list-view (make-instance 'list-view + :multip multip + :items items + :item-height item-height + :parent g + :on-select (lambda (g) + (on-select (parent-of g))))) (slider-box (make-instance 'v-box :parent g :gap 0 :x-expand-p nil :width w)) (slider (make-instance 'v-slider :width w @@ -326,6 +359,7 @@ (incf (scroll-of list-view) (* d item-height)) (setf (value-of slider) (scroll-of list-view)) nil))) + (setf (list-view-of g) list-view) (make-instance 'button :parent slider-box :x-expand-p nil @@ -343,23 +377,25 @@ :on-button-down (scroll-fn 1) :on-drag (scroll-fn 0.3)))))
+(defmethod value-of ((g list-box)) + (convert-selected-of (list-view-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)))
- - - - - -(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 +(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