[pal-cvs] CVS pal-gui
tneste
tneste at common-lisp.net
Mon Oct 15 21:55:55 UTC 2007
Update of /project/pal/cvsroot/pal-gui
In directory clnet:/tmp/cvs-serv18131
Modified Files:
gob.lisp gui.lisp widgets.lisp
Log Message:
Getting off the ground.
--- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/15 19:14:36 1.1
+++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/15 21:55:55 1.2
@@ -21,24 +21,28 @@
(setf (parent-of g) parent)
(push g *gobs*))
-(defmethod draw ((g gob))
- (declare (ignore g))
- nil)
+(defgeneric repaint (gob))
+(defgeneric absolute-pos-of (gob))
(defmethod absolute-pos-of ((g gob))
(if (parent-of g)
(v+ (pos-of g) (absolute-pos-of (parent-of g)))
(pos-of g)))
+(defgeneric (setf absolute-pos-of) (pos gob))
(defmethod (setf absolute-pos-of) (pos (g gob))
(setf (pos-of g) (v+ (v- pos (absolute-pos-of g)) (pos-of g))))
+(defgeneric point-inside-p (gob point))
(defmethod point-inside-p ((g gob) point)
(point-inside-rectangle-p (absolute-pos-of g) (width-of g) (height-of g) point))
+
+(defgeneric on-enter (gob))
(defmethod on-enter ((gob gob))
nil)
+(defgeneric on-leave (gob))
(defmethod on-leave ((gob gob))
nil)
@@ -76,14 +80,15 @@
(:default-initargs :activep nil))
-(defmethod draw :around ((g containing))
+(defmethod repaint :around ((g containing))
(call-next-method)
- (draw-childs g))
+ (repaint-childs g))
-(defmethod draw-childs ((g containing))
+(defgeneric repaint-childs (container))
+(defmethod repaint-childs ((g containing))
(with-transformation (:pos (pos-of g))
(dolist (c (childs-of g))
- (draw c))))
+ (repaint c))))
(defgeneric adopt (parent child))
(defmethod adopt ((parent containing) (child gob))
@@ -96,11 +101,19 @@
(setf (slot-value (parent-of child) 'childs) (remove child (slot-value (parent-of child) 'childs))
(parent-of child) nil)))
+(defgeneric (setf parent-of) (parent child))
(defmethod (setf parent-of) ((parent containing) (child gob))
(abandon child)
(adopt parent child))
+(defclass v-packing (containing)
+ ())
+
+
+
+
+
@@ -128,6 +141,9 @@
()
(:default-initargs :width (get-screen-width) :height (get-screen-height) :pos (v 0 0) :parent nil))
+(defmethod repaint ((g root))
+ (declare (ignore g))
+ nil)
(defmethod (setf parent-of) (parent (root root))
(declare (ignore parent))
--- /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/15 19:14:36 1.1
+++ /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/15 21:55:55 1.2
@@ -8,13 +8,13 @@
(let ((key-up (lambda (key)
(case key
- (:key-mouse-1 (setf *armed-gob* nil)
- (cond
+ (: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))))
+ (t (pal::funcall? ,key-up-fn key)))
+ (setf *armed-gob* nil))
(otherwise (pal::funcall? ,key-up-fn key)))))
(key-down (lambda (key)
(case key
@@ -60,7 +60,7 @@
*root* (make-instance 'root)))
(defun update-gui ()
- (draw *root*))
+ (repaint *root*))
(defun gob-at-point (point)
(find-if (lambda (g) (and (activep g) (point-inside-p g point))) *gobs*))
--- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/15 19:14:36 1.1
+++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/15 21:55:55 1.2
@@ -4,6 +4,7 @@
(defparameter *window-color* '(160 160 160 160))
(defparameter *widget-color* '(180 180 180 255))
(defparameter *text-color* '(0 0 0 255))
+(defparameter *paper-color* '(255 255 200 255))
(defun get-text-bounds (string &optional font)
@@ -19,7 +20,10 @@
(truncate (* (get-font-height font) 1.5)))
(defun draw-frame (pos width height color &key style (border 1))
- (let ((r (first color))
+ (let ((pos (v-floor pos))
+ (width (truncate width))
+ (height (truncate height))
+ (r (first color))
(g (second color))
(b (third color))
(a (fourth color)))
@@ -37,16 +41,33 @@
(draw-line (v+ pos (v (- width 1) (- height 1))) (v+ pos (v width 0)) 255 255 255 128)
(draw-line (v+ pos (v width (- height 1))) (v+ pos (v 0 height)) 255 255 255 128)))))
+(defun display-value (widget &optional value)
+ (funcall (display-fn-of widget) (or value (value-of widget))))
+(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)))
+ (:default-initargs :width (get-m) :height (get-m)))
+(defmethod on-drag :around ((g widget) pos d)
+ (unless (funcall (on-drag-of g) g pos d)
+ (call-next-method)))
-(defclass window (gob containing sliding)
+(defmethod on-select :around ((g widget) pos)
+ (unless (funcall (on-select-of g) g pos)
+ (call-next-method)))
+
+
+
+
+
+(defclass window (widget containing sliding)
((color :accessor color-of :initform *window-color* :initarg :color))
(:default-initargs :activep t))
-(defmethod draw ((g window))
+(defmethod repaint ((g window))
(draw-rectangle (v+ (v 6 6) (pos-of g)) (width-of g) (height-of g) 0 0 0 64)
(draw-frame (pos-of g) (width-of g) (height-of g) (color-of g) :style :raised))
@@ -58,9 +79,9 @@
-(defclass button (gob)
+(defclass button (widget)
((color :accessor color-of :initform *widget-color* :initarg :color)
- (display-fn :accessor display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))
+ (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v)))
(value :accessor value-of :initform "" :initarg :value)))
(defmethod initialize-instance :after ((g button) &key width &allow-other-keys)
@@ -69,7 +90,7 @@
(setf (width-of g) w))
(setf (height-of g) h)))
-(defmethod draw ((g button))
+(defmethod repaint ((g button))
(let ((color (color-of g))
(value (funcall (display-fn-of g) (value-of g)))
(fpos (v+ (pos-of g) (get-text-offset))))
@@ -93,11 +114,11 @@
-(defclass h-gauge (gob)
+(defclass h-gauge (widget)
((value :reader 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)
- (display-fn :accessor display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v))))
+ (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v))))
(:default-initargs :height (get-m)))
(defmethod (setf value-of) (value (g h-gauge))
@@ -108,7 +129,7 @@
(let ((x (vx (v- start-pos delta))))
(setf (value-of g) (+ (truncate x (/ (width-of g) (abs (- (min-value-of g) (max-value-of g))))) (min-value-of g)))))
-(defmethod draw ((g h-gauge))
+(defmethod repaint ((g h-gauge))
(let* ((vt (funcall (display-fn-of g) (value-of g)))
(sw (get-text-bounds vt))
(m (get-m))
@@ -131,7 +152,7 @@
-(defclass v-slider (gob)
+(defclass v-slider (widget)
((value :reader 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)
@@ -146,13 +167,16 @@
(let ((y (vy (v- start-pos delta))))
(setf (value-of g) (+ (truncate y (/ (height-of g) (abs (- (min-value-of g) (max-value-of g))))) (min-value-of g)))))
-(defmethod draw ((g v-slider))
+(defmethod repaint ((g v-slider))
(let* ((units (abs (- (min-value-of g) (max-value-of g))))
(usize (/ (height-of g) units))
(k (truncate (* usize (- (value-of g) (min-value-of g)))))
(kpos (v+ (pos-of g) (v 0 k))))
(draw-frame (pos-of g) (width-of g) (height-of g) *window-color* :style :sunken)
- (draw-frame kpos (width-of g) (* (- units (page-size-of g)) usize) *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1))))
+ (draw-frame kpos
+ (width-of g)
+ (min (height-of g) (- (height-of g) (* (- units (page-size-of g)) usize)))
+ *widget-color* :style :raised :border (if (or (armedp g) (pointedp g)) 2 1))))
@@ -161,17 +185,17 @@
-(defclass h-meter (gob)
+(defclass h-meter (widget)
((value :reader 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)
- (display-fn :accessor display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v))))
+ (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v))))
(:default-initargs :activep nil :height (get-m)))
(defmethod (setf value-of) (value (g h-meter))
(setf (slot-value g 'value) (clamp (min-value-of g) value (max-value-of g))))
-(defmethod draw ((g h-meter))
+(defmethod repaint ((g h-meter))
(let* ((m (get-m))
(k (truncate (* (/ (width-of g) (abs (- (min-value-of g) (max-value-of g)))) (- (value-of g) (min-value-of g))))) )
(draw-frame (pos-of g) (width-of g) (height-of g) *window-color* :style :sunken)
@@ -183,12 +207,45 @@
-(defclass v-list (gob)
+(defclass list-view (widget)
((items :accessor items-of :initarg :items :initform '())
(scroll :accessor scroll-of :initform 0)
- (display-fn :accessor display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v))))
- (:default-initargs :width (* 10 (get-m)) :height (* 5 (get-m))))
+ (display-fn :reader display-fn-of :initarg :display-fn :initform (lambda (v) (princ-to-string v))))
+ (:default-initargs :width (* 6 (get-m)) :height (* 5 (get-m))))
+
+
+(defmethod repaint ((g list-view))
+ (with-accessors ((width width-of) (height height-of) (pos pos-of) (ap absolute-pos-of)) g
+ (draw-frame pos width height *paper-color* :style :sunken)
+ (with-clipping ((vx ap) (vy ap) width height)
+ (with-blend (:color *text-color*)
+ (let ((pos (v+ pos (get-text-offset)))
+ (y 0))
+ (dolist (i (items-of g))
+ (when (oddp y)
+ (draw-rectangle (v- (v+ pos (v 0 (- (* y (get-m)) (scroll-of g)))) (get-text-offset)) width (get-m) 0 0 0 32))
+ (draw-text (display-value g i) (v+ pos (v 0 (- (* y (get-m)) (scroll-of g)))))
+ (incf y)))))))
+
+
-(defmethod draw ((g v-list))
- ())
\ No newline at end of file
+(defclass list-box (widget containing)
+ ()
+ (:default-initargs :height (* 6 (get-m)) :width (* 5 (get-m))))
+
+(defmethod initialize-instance :after ((g list-box) &key pos items &allow-other-keys)
+ (let* ((lv (make-instance 'list-view :items items :pos pos :parent g :height (height-of g) :width (width-of g)))
+ (sl (make-instance 'v-slider :pos (v+ pos (v (+ (width-of lv) 3) 0))
+ :parent g
+ :max-value (* (get-m) (length items))
+ :height (height-of g)
+ :page-size (height-of lv)
+ :on-drag (lambda (g pos d)
+ (declare (ignore pos d))
+ (setf (scroll-of lv) (value-of g))
+ nil))))))
+
+(defmethod repaint ((g list-box))
+ (declare (ignore g))
+ nil)
\ No newline at end of file
More information about the Pal-cvs
mailing list