[pal-cvs] CVS pal-gui
tneste
tneste at common-lisp.net
Wed Oct 24 19:59:56 UTC 2007
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)
, at 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
More information about the Pal-cvs
mailing list