Update of /project/pal/cvsroot/pal-gui In directory clnet:/tmp/cvs-serv701

Modified Files: gob.lisp gui.lisp package.lisp present.lisp widgets.lisp Log Message: Added more examples. Numerous other improvements. Nearing v 0.1

--- /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/24 19:59:56 1.10 +++ /project/pal/cvsroot/pal-gui/gob.lisp 2007/10/29 20:06:01 1.11 @@ -80,6 +80,10 @@ (defmethod on-select ((gob gob)) nil)

+(defgeneric on-key-down (gob char)) +(defmethod on-key-down ((gob gob) char) + nil) + (defgeneric on-drag (gob start-pos delta-pos)) (defmethod on-drag ((gob gob) start-pos delta) (declare (ignore start-pos delta)) @@ -89,6 +93,10 @@ (defmethod pointedp ((gob gob)) (eq *pointed-gob* gob))

+(defgeneric focusedp (gob)) +(defmethod focusedp ((gob gob)) + (eq *focused-gob* gob)) + (defgeneric armedp (gob)) (defmethod armedp ((gob gob)) (eq *armed-gob* gob)) @@ -181,10 +189,14 @@ (exp-size (- height (+ (* (1- (length (childs-of g))) (gap-of g)) (* 2 (y-pad-of g)) (loop for c in (remove-if 'y-expand-p (childs-of g)) summing (min-height-of c)))))) (dolist (c childs) - (when (y-expand-p c) - (setf (height-of c) (max (min-height-of c) (truncate exp-size exp-count)))) - (when (x-expand-p c) - (setf (width-of c) (max 1 (- width (* 2 x-pad))))))) + (setf (height-of c) + (if (y-expand-p c) + (max (min-height-of c) (truncate exp-size exp-count)) + (min-height-of c))) + (setf (width-of c) + (if (x-expand-p c) + (max 1 (- width (* 2 x-pad))) + (min-width-of c))))) (let ((cpos (v x-pad y-pad))) (dolist (c (reverse childs)) (setf (pos-of c) cpos) @@ -214,10 +226,14 @@ (exp-size (- width (+ (* (1- (length (childs-of g))) (gap-of g)) (* 2 (x-pad-of g)) (loop for c in (remove-if 'x-expand-p (childs-of g)) summing (min-width-of c)))))) (dolist (c childs) - (when (x-expand-p c) - (setf (width-of c) (max (min-width-of c) (truncate exp-size exp-count)))) - (when (y-expand-p c) - (setf (height-of c) (max 1 (- height (* 2 y-pad))))))) + (setf (width-of c) + (if (x-expand-p c) + (max (min-width-of c) (truncate exp-size exp-count)) + (min-width-of c))) + (setf (height-of c) + (if (y-expand-p c) + (max 1 (- height (* 2 y-pad))) + (min-height-of c))))) (let ((cpos (v x-pad y-pad))) (dolist (c (reverse childs)) (setf (pos-of c) cpos) --- /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/24 19:59:56 1.6 +++ /project/pal/cvsroot/pal-gui/gui.lisp 2007/10/29 20:06:01 1.7 @@ -2,6 +2,7 @@

(defmacro gui-loop ((&key key-up-fn key-down-fn mouse-motion-fn quit-fn) &body redraw) + "Same as PAL:EVENT-LOOP but with added GUI event handling" (let ((event (gensym))) `(block event-loop (cffi:with-foreign-object (,event :char 500) @@ -19,12 +20,17 @@ (return-from event-loop))) (:key-mouse-1 (cond (*pointed-gob* - (setf *drag-start-pos* (get-mouse-pos)) - (setf *relative-drag-start-pos* (v- *drag-start-pos* (absolute-pos-of *pointed-gob*))) - (setf *armed-gob* *pointed-gob*) + (setf *drag-start-pos* (get-mouse-pos) + *relative-drag-start-pos* (v- *drag-start-pos* (absolute-pos-of *pointed-gob*)) + *focused-gob* *pointed-gob* + *armed-gob* *pointed-gob*) (on-button-down *pointed-gob* (v- (get-mouse-pos) (absolute-pos-of *pointed-gob*)))) - (t (pal::funcall? ,key-down-fn key)))) - (otherwise (pal::funcall? ,key-down-fn key)))))) + (t (setf *focused-gob* nil) + (pal::funcall? ,key-down-fn key)))) + (otherwise (if *focused-gob* + (let ((char (keysym-char key))) + (when (and char (graphic-char-p char)) (on-key-down *focused-gob* char))) + (pal::funcall? ,key-down-fn key)))))))

(loop (pal::do-event ,event key-up key-down ,mouse-motion-fn ,quit-fn) @@ -39,8 +45,7 @@ (when *pointed-gob* (on-leave *pointed-gob*)) (on-enter g))))) - (update-gui) - (update-screen))))))) + (update-gui)))))))

(defmacro with-gui (args &body body) @@ -73,4 +78,9 @@ *armed-gob* nil))

(defun update-gui () - (repaint *root*)) \ No newline at end of file + "Like PAL:UPDATE but also updates the GUI" + (pal::close-quads) + (reset-blend) + (pal-ffi:gl-load-identity) + (repaint *root*) + (update-screen)) \ No newline at end of file --- /project/pal/cvsroot/pal-gui/package.lisp 2007/10/15 19:14:36 1.1 +++ /project/pal/cvsroot/pal-gui/package.lisp 2007/10/29 20:06:01 1.2 @@ -1,2 +1,16 @@ (defpackage #:pal-gui - (:use :common-lisp :pal)) + (:use :common-lisp :pal) + (:export #:with-gui #:init-gui #:update-gui #:gui-loop + + #:present + + #:window #:button #:list-widget #:text-widget #:choice-widget #:pin #:label #:h-gauge #:v-slider #:h-meter + #:sliding #:clipping #:highlighted + #: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 + + #:pos-of #:width-of #:height-of #:childs-of #:parent-of #:min-width-of #:min-height-of #:x-expand-p #:y-expand-p + #:absolute-pos-of #:point-inside-p #:pointedp #:focusedp #:armedp #:activep + #:raise #:lower + #:label-of #:value-of #:text-of #:state-of #:min-value #:max-value #:page-size-of #:items-of #:item-height-of #:selected-of)) --- /project/pal/cvsroot/pal-gui/present.lisp 2007/10/25 14:10:16 1.1 +++ /project/pal/cvsroot/pal-gui/present.lisp 2007/10/29 20:06:01 1.2 @@ -3,11 +3,50 @@

(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 + (draw-text (format nil "~a" object) (v (vx (get-text-offset)) + (- (truncate height 2) (truncate (get-font-height *gui-font*) 2) 1))))) + + + +(defmethod present ((image image) (g widget) width height) + (draw-image image (v 0 0) :scale (min (/ height (image-height image)) (/ width (image-width image))))) + + + +(defmethod present ((s (eql :up-arrow)) (g widget) width height) + (draw-polygon (list (v 3 (- height 3)) + (v (/ width 2) 3) + (v (- width 3) (- height 3))) + (first *text-color*) (second *text-color*) (third *text-color*)(fourth *text-color*) :smoothp t)) + + +(defmethod present ((s (eql :down-arrow)) (g widget) width height) + (draw-polygon (list (v 3 3) + (v (/ width 2) (- height 3)) + (v (- width 3) 3)) + (first *text-color*) (second *text-color*) (third *text-color*)(fourth *text-color*) :smoothp t)) + + +(defmethod present ((s (eql :right-arrow)) (g widget) width height) + (draw-polygon (list (v 3 3) + (v (- width 3) (/ height 2)) + (v 3 (- height 3))) + (first *text-color*) (second *text-color*) (third *text-color*)(fourth *text-color*) :smoothp t)) + + +(defmethod present ((s (eql :left-arrow)) (g widget) width height) + (draw-polygon (list (v (- width 3) 3) + (v 3 (/ height 2)) + (v (- width 3) (- height 3))) + (first *text-color*) (second *text-color*) (third *text-color*)(fourth *text-color*) :smoothp t)) + + +(defmethod present ((s (eql :box)) (g widget) width height) + (draw-rectangle (v 3 3) (- width 6) (- height 6) (first *text-color*) (second *text-color*) (third *text-color*)(fourth *text-color*) :smoothp t)) + + +(defmethod present ((s (eql :circle)) (g widget) width height) + (draw-circle (v (/ width 2) (/ height 2)) (/ (min width height) pi) (first *text-color*) (second *text-color*) (third *text-color*)(fourth *text-color*) :smoothp t)) --- /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/24 19:59:56 1.10 +++ /project/pal/cvsroot/pal-gui/widgets.lisp 2007/10/29 20:06:01 1.11 @@ -52,8 +52,10 @@ (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) (declare (ignore widget)) nil)) + (on-repaint :accessor on-repaint-of :initarg :on-repaint :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-key-down :accessor on-key-down-of :initarg :on-key-down :initform (lambda (widget char) (declare (ignore widget char)) nil)) (on-enter :accessor on-enter-of :initarg :on-enter :initform (lambda (widget) (declare (ignore widget)) nil)) (on-leave :accessor on-leave-of :initarg :on-leave :initform (lambda (widget) (declare (ignore widget)) nil))) (:default-initargs :width (get-m) :height (get-m))) @@ -66,6 +68,10 @@ (unless (funcall (on-select-of g) g) (call-next-method)))

+(defmethod repaint :around ((g widget)) + (unless (funcall (on-repaint-of g) g) + (call-next-method))) + (defmethod on-button-down :around ((g widget) pos) (unless (funcall (on-button-down-of g) g pos) (call-next-method))) @@ -74,6 +80,10 @@ (unless (funcall (on-button-up-of g) g pos) (call-next-method)))

+(defmethod on-key-down :around ((g widget) char) + (unless (funcall (on-key-down-of g) g char) + (call-next-method))) + (defmethod on-enter :around ((g widget)) (unless (funcall (on-enter-of g) g) (call-next-method))) @@ -92,16 +102,20 @@ ((label :accessor label-of :initform nil :initarg :label)) (:default-initargs :activep nil :x-expand-p t :y-expand-p t))

-(defmethod initialize-instance :after ((g box) &key label) - (when label - (setf (y-pad-of g) (truncate (get-m) 2) - (x-pad-of g) (truncate (get-m) 2)))) - (defmethod repaint ((g box)) (when (label-of g) - (draw-rectangle (v 0 0) (width-of g) (height-of g) 0 0 0 128 :fill nil) - (with-blend (:color *text-color*) - (draw-text (label-of g) (v- (get-text-offset) (v 0 (truncate (get-m) 2))))))) + (let ((text-offset (get-text-offset))) + (with-accessors ((width width-of) (height height-of) (label label-of)) g + + (draw-line (v 0 0) (v 0 height) 0 0 0 160) + (draw-line (v width 0) (v width height) 0 0 0 160) + (draw-line (v 0 height) (v width height) 0 0 0 160) + + (draw-line (v 0 0) (v (vx text-offset) 0) 0 0 0 160) + (draw-line (v (- (get-text-bounds label) (vx text-offset)) 0) (v width 0) 0 0 0 160) + + (with-blend (:color *text-color*) + (draw-text label (v- text-offset (v 0 (truncate (get-m) 2)))))))))

@@ -109,13 +123,20 @@ () (:default-initargs :x-pad 0 :y-pad 0 :gap (truncate (get-m) 3)))

+(defmethod initialize-instance :after ((g v-box) &key label) + (when label + (setf (y-pad-of g) (truncate (get-m) 2) + (x-pad-of g) (truncate (get-m) 2))))

(defclass h-box (box h-packing) () (:default-initargs :x-pad 0 :y-pad 0 :gap (truncate (get-m) 2)))

- +(defmethod initialize-instance :after ((g h-box) &key label) + (when label + (setf (y-pad-of g) (truncate (get-m) 2) + (x-pad-of g) (truncate (get-m) 2))))

@@ -158,36 +179,69 @@

+(defclass label (widget) + ((value :reader value-of :initform "" :initarg :value))) + +(defmethod initialize-instance :after ((g label) &key value &allow-other-keys) + (when (stringp value) + (setf (width-of g) (get-text-bounds value)))) + +(defmethod (setf value-of) (value (g label)) + (when (stringp value) + (setf (width-of g) (get-text-bounds value))) + (setf (slot-value g 'value) value)) + +(defmethod repaint ((g label)) + (present (value-of g) g (width-of g) (height-of g))) + + + +(defclass pin (label sliding highlighted) + ((r :accessor r-of :initarg :r :initform 255) + (g :accessor g-of :initarg :g :initform 255) + (b :accessor b-of :initarg :b :initform 255) + (a :accessor a-of :initarg :a :initform 255)) + (:default-initargs :activep t)) + +(defmethod repaint ((g pin)) + (draw-rectangle (v 0 0) (width-of g) (height-of g) (r-of g) (g-of g) (b-of g) (a-of g)) + (call-next-method) + (draw-rectangle (v 0 0) (width-of g) (height-of g) 0 0 0 (a-of g) :fill nil)) + + +

(defclass button (widget highlighted) - ((value :accessor value-of :initform "" :initarg :value)) + ((value :accessor value-of :initform "" :initarg :value) + (stickyp :reader stickyp :initform nil :initarg :stickyp) + (state :accessor state-of :initform nil :initarg :state)) (:default-initargs :x-expand-p t))

(defmethod on-button-up ((g button) pos) (when (eq *armed-gob* g) - (on-select g))) + (on-select g) + (when (stickyp g) + (setf (state-of g) (not (state-of g))))))

(defmethod repaint ((g button)) (with-accessors ((width width-of) (height height-of) (value value-of)) g (cond - ((armedp g) + ((or (state-of g) (armedp g)) (draw-frame (v 0 0) width height *widget-color* :style :sunken) (with-transformation (:pos (v 1 1)) - (with-blend (:color *text-color*) - (present value g width height)))) + (present value g width height))) (t (draw-frame (v 0 0) width height *widget-color* :style :raised) - (with-blend (:color *text-color*) - (present value g width height)))))) + (present value g width height)))))

(defclass h-gauge (widget highlighted) - ((value :reader value-of :initarg :value :initform 0) - (min-value :reader min-value-of :initarg :min-value :initform 0) - (max-value :reader max-value-of :initarg :max-value :initform 100)) + ((value :accessor 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)) (:default-initargs :x-expand-p t))

(defgeneric (setf value-of) (value g)) @@ -219,10 +273,10 @@

(defclass v-slider (widget highlighted) - ((value :reader value-of :initarg :value :initform 0) - (page-size :reader page-size-of :initarg :page-size :initform 1) - (min-value :reader min-value-of :initarg :min-value :initform 0) - (max-value :reader max-value-of :initarg :max-value :initform 100)) + ((value :accessor 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) + (max-value :accessor max-value-of :initarg :max-value :initform 100)) (:default-initargs :y-expand-p t))

(defmethod (setf value-of) (value (g v-slider)) @@ -278,7 +332,7 @@

(defclass list-view (widget) - ((items :reader items-of :initarg :items :initform '()) + ((items :accessor 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) @@ -301,41 +355,41 @@ (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))))))) + (when (< item (length (items-of g))) + (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) (with-clipping ((vx ap) (vy ap) width height) - (with-blend (:color *text-color*) - (with-transformation (:pos (v 0 (- (mod scroll item-height)))) - (let ((y 0)) - (dolist (i (items-of g)) - (when (and (> (* (1+ y) item-height) scroll) - (< (* y item-height) (+ scroll height))) - (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)))))))) + (with-transformation (:pos (v 0 (- (mod scroll item-height)))) + (let ((y 0)) + (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)) + (present i g width item-height) + (when (find y (selected-of g) :test '=) + (draw-rectangle (v 1 0) width item-height 0 0 0 128)) + (translate (v 0 item-height))) + (incf y)))))))

-(defclass list-box (h-box) - ((list-view :accessor list-view-of)) +(defclass list-widget (h-box) + ((list-view :accessor list-view-of) + (slider :accessor slider-of)) (:default-initargs :gap 3))

-(defmethod initialize-instance :after ((g list-box) &key items (item-height (get-m)) (multip nil) &allow-other-keys) +(defmethod initialize-instance :after ((g list-widget) &key items (item-height (get-m)) (multip nil) &allow-other-keys) (let* ((w (truncate (get-m) 1.5)) (list-view (make-instance 'list-view :multip multip @@ -359,8 +413,10 @@ (incf (scroll-of list-view) (* d item-height)) (setf (value-of slider) (scroll-of list-view)) nil))) - (setf (list-view-of g) list-view) + (setf (list-view-of g) list-view + (slider-of g) slider) (make-instance 'button + :value :up-arrow :parent slider-box :x-expand-p nil :y-expand-p nil @@ -369,6 +425,7 @@ :on-button-down (scroll-fn -1) :on-drag (scroll-fn -0.3)) (make-instance 'button + :value :down-arrow :parent slider-box :x-expand-p nil :y-expand-p nil @@ -377,25 +434,66 @@ :on-button-down (scroll-fn 1) :on-drag (scroll-fn 0.3)))))

-(defmethod value-of ((g list-box)) +(defmethod selected-of ((g list-widget)) (convert-selected-of (list-view-of g)))

+(defmethod items-of ((g list-widget)) + (items-of (list-view-of g)))

+(defmethod (setf items-of) (items (g list-widget)) + (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)))) + + + +(defclass choice-widget (v-box) + ((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))) + +(defmethod selected-of ((g choice-widget)) + (mapcar 'value-of (remove-if-not 'state-of (childs-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)))

-(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 + +(defclass text-widget (widget) + ((point :accessor point-of :initform 0) + (text :accessor text-of :initarg :text :initform "")) + (:default-initargs :x-expand-p t)) + +(defmethod initialize-instance :after ((g text-widget) &key text &allow-other-keys) + (setf (point-of g) (length text))) + +(defmethod repaint ((g text-widget)) + (with-accessors ((width width-of) (height height-of) (text text-of) (point point-of)) g + (draw-frame (v 0 0) width height *widget-color* :fill nil :style :raised) + (draw-rectangle (v 1 1) (1- width) (1- height) (first *paper-color*) (second *paper-color*) (third *paper-color*) (fourth *paper-color*)) + (let* ((offset (get-text-offset)) + (point-x (+ (vx offset) (get-text-size (subseq text 0 point))))) + (with-blend (:color *text-color*) + (draw-text text offset) + (when (focusedp g) + (draw-rectangle (v point-x (vy offset)) + 2 (- height (* 2 (vy offset))) + 0 0 0 255)))))) + +(defmethod on-key-down ((g text-widget) char) + (setf (text-of g) (concatenate 'string (text-of g) (string char))) + (incf (point-of g))) \ No newline at end of file