Author: junrue Date: Wed Oct 11 13:01:23 2006 New Revision: 297 Modified: trunk/src/demos/unblocked/scoreboard-panel.lisp trunk/src/tests/uitoolkit/scroll-grid-panel.lisp trunk/src/tests/uitoolkit/scroll-tester.lisp trunk/src/tests/uitoolkit/scroll-text-panel.lisp trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp Log: implemented integral scrolling Modified: trunk/src/demos/unblocked/scoreboard-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/scoreboard-panel.lisp (original) +++ trunk/src/demos/unblocked/scoreboard-panel.lisp Wed Oct 11 13:01:23 2006 @@ -85,12 +85,9 @@ (defmethod initialize-instance :after ((self scoreboard-panel-events) &key buffer-size) (declare (ignorable buffer-size)) - (let ((gc (make-instance 'gfg:graphics-context))) - (unwind-protect - (progn - (setf (label-font-of self) (make-instance 'gfg:font :gc gc :data *scoreboard-label-font-data*)) - (setf (value-font-of self) (make-instance 'gfg:font :gc gc :data *scoreboard-value-font-data*))) - (gfs:dispose gc)))) + (gfw:with-graphics-context (gc) + (setf (label-font-of self) (make-instance 'gfg:font :gc gc :data *scoreboard-label-font-data*)) + (setf (value-font-of self) (make-instance 'gfg:font :gc gc :data *scoreboard-value-font-data*)))) (defmethod draw-scoreboard-row (gc row image-size label-font label-text value-font value) (let* ((metrics (gfg:metrics gc label-font)) Modified: trunk/src/tests/uitoolkit/scroll-grid-panel.lisp ============================================================================== --- trunk/src/tests/uitoolkit/scroll-grid-panel.lisp (original) +++ trunk/src/tests/uitoolkit/scroll-grid-panel.lisp Wed Oct 11 13:01:23 2006 @@ -53,29 +53,26 @@ (setf (gfw:maximum-size panel) panel-size (gfw:minimum-size panel) panel-size) (assert (gfs:equal-size-p panel-size (slot-value panel 'gfw::max-size))) - (let ((scrollbar (gfw:obtain-horizontal-scrollbar parent))) - (setf (gfw:outer-limits scrollbar) (gfs:make-span :end (gfs:size-width panel-size)) - (gfw:thumb-position scrollbar) 0) - (gfs:dispose scrollbar)) - (let ((scrollbar (gfw:obtain-vertical-scrollbar parent))) - (setf (gfw:outer-limits scrollbar) (gfs:make-span :end (gfs:size-height panel-size)) - (gfw:thumb-position scrollbar) 0) - (gfs:dispose scrollbar)) -#| - (let* ((gc (make-instance 'gfg:graphics-context :widget panel)) - (font (make-instance 'gfg:font :gc gc))) - (unwind-protect - (let ((metrics (gfg:metrics gc font))) - (setf (gfs:size-width *grid-char-size*) (gfg:maximum-char-width metrics) - (gfs:size-height *grid-char-size*) (+ (gfg:ascent metrics) - (gfg:descent metrics)))) - (gfs:dispose font) - (gfs:dispose gc))) -|# (setf (gfs:size-width *grid-char-size*) (floor +grid-half-extent+ 2) (gfs:size-height *grid-char-size*) (floor +grid-half-extent+ 2)) panel)) +(defun set-grid-scroll-params (window) + (let* ((disp (gfw:dispatcher window)) + (panel (gfw::obtain-top-child window)) + (panel-size (gfw:size panel)) + (scrollbar (gfw:obtain-horizontal-scrollbar window))) + (setf (gfw:outer-limits scrollbar) + (gfs:make-span :end (gfs:size-width panel-size))) + (setf (gfw:thumb-position scrollbar) 0) + (setf scrollbar (gfw:obtain-vertical-scrollbar window)) + (setf (gfw:outer-limits scrollbar) + (gfs:make-span :end (gfs:size-height panel-size))) + (setf (gfw:step-increments disp) (gfs:make-size :width 1 :height 1)) + (setf (gfw:thumb-position scrollbar) 0) + (setf (slot-value disp 'gfw::viewport-origin) (gfs:make-point)) + (gfw:event-resize disp window (gfw:size window) :restored))) + (defmethod gfw:event-paint ((disp scroll-grid-panel-events) window gc rect) (declare (ignore window)) (let ((color (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+)))) Modified: trunk/src/tests/uitoolkit/scroll-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/scroll-tester.lisp (original) +++ trunk/src/tests/uitoolkit/scroll-tester.lisp Wed Oct 11 13:01:23 2006 @@ -61,11 +61,13 @@ (select-grid (lambda (disp item) (declare (ignore disp item)) (setf (gfw:top-child-of layout) grid-panel) - (gfw:layout *scroll-tester-win*))) + (gfw:layout *scroll-tester-win*) + (set-grid-scroll-params *scroll-tester-win*))) (select-text (lambda (disp item) (declare (ignore disp item)) (setf (gfw:top-child-of layout) text-panel) - (gfw:layout *scroll-tester-win*))) + (gfw:layout *scroll-tester-win*) + (set-text-scroll-params *scroll-tester-win*))) (manage-tests-menu (lambda (disp menu) (declare (ignore disp)) (let ((top (gfw::obtain-top-child *scroll-tester-win*)) @@ -79,6 +81,7 @@ (:item "&Text" :callback select-text))))))) (setf (gfw:menu-bar *scroll-tester-win*) menubar (gfw:top-child-of layout) grid-panel)) + (set-grid-scroll-params *scroll-tester-win*) (setf (gfw:text *scroll-tester-win*) "Scroll Tester" (gfw:size *scroll-tester-win*) (gfs:make-size :width 300 :height 275)) (gfw:show *scroll-tester-win* t))) Modified: trunk/src/tests/uitoolkit/scroll-text-panel.lisp ============================================================================== --- trunk/src/tests/uitoolkit/scroll-text-panel.lisp (original) +++ trunk/src/tests/uitoolkit/scroll-text-panel.lisp Wed Oct 11 13:01:23 2006 @@ -33,14 +33,96 @@ (in-package #:graphic-forms.uitoolkit.tests) -(defclass scroll-text-panel-events (gfw:event-dispatcher) ()) +(defvar *text-to-draw* "ABCDEFGHIJKLMNOPQRSTUVWXYZ[]0123456789{}") + +(defvar *text-model-size* (gfs:make-size :width 100 :height 100)) ; character cells + +(defvar *text-panel-font-data* (gfg:make-font-data :face-name "Lucida Console" + :point-size 10)) + +(defclass scroll-text-panel-events (gfw:event-dispatcher) + ((font + :accessor font-of + :initform nil))) + +(defun draw-text-chunk (gc metrics row first-col last-col) + (let* ((col-diff (1+ (- last-col first-col))) + (text-len (length *text-to-draw*)) + (text-start (mod first-col text-len)) + (text-end (mod last-col text-len)) + (ch-width (gfg:average-char-width metrics)) + (ch-height (gfg:height metrics)) + (pnt (gfs:make-point :x (* ch-width first-col) + :y (* ch-height row)))) + (cond + ((and (<= col-diff text-len) (<= text-start text-end)) + (gfg:draw-text gc (subseq *text-to-draw* text-start (1+ text-end)) pnt)) + ((or (> col-diff text-len) (> text-start text-end)) + (gfg:draw-text gc (subseq *text-to-draw* text-start text-len) pnt) + (incf (gfs:point-x pnt) (* (- text-len text-start) ch-width)) + (dotimes (i (floor col-diff text-len)) + (gfg:draw-text gc *text-to-draw* pnt) + (incf (gfs:point-x pnt) (* text-len ch-width))) + (gfg:draw-text gc (subseq *text-to-draw* 0 (1+ text-end)) pnt))))) (defun make-scroll-text-panel (parent) - (let ((panel (make-instance 'gfw:panel :dispatcher 'scroll-text-panel-events - :parent parent))) - (let* ((font (gfg:font panel)) ; we don't own font, so don't dispose it - (gc (make-instance 'gfg:graphics-context :widget panel)) - (metrics (gfg:metrics gc font))) - (print metrics) - (gfs:dispose gc)) + (let* ((disp (make-instance 'scroll-text-panel-events)) + (panel (make-instance 'gfw:panel :dispatcher disp :parent parent))) + (gfw:with-graphics-context (gc panel) + (let* ((metrics (gfg:metrics gc (font-of disp))) + (panel-size (gfs:make-size :width (* (gfs:size-width *text-model-size*) + (gfg:average-char-width metrics)) + :height (* (gfs:size-height *text-model-size*) + (gfg:height metrics))))) + (setf (gfw:maximum-size panel) panel-size + (gfw:minimum-size panel) panel-size))) panel)) + +(defun set-text-scroll-params (window) + (let ((disp (gfw:dispatcher window)) + (panel (gfw::obtain-top-child window))) + (gfw:with-graphics-context (gc panel) + (let ((metrics (gfg:metrics gc (font-of (gfw:dispatcher panel)))) + (scrollbar (gfw:obtain-horizontal-scrollbar window))) + (setf (gfw:outer-limits scrollbar) + (gfs:make-span :end (* (gfs:size-width *text-model-size*) + (gfg:average-char-width metrics)))) + (setf (gfw:thumb-position scrollbar) 0) + (setf scrollbar (gfw:obtain-vertical-scrollbar window)) + (setf (gfw:outer-limits scrollbar) + (gfs:make-span :end (* (gfs:size-height *text-model-size*) + (gfg:height metrics)))) + (setf (gfw:thumb-position scrollbar) 0) + (setf (gfw:step-increments disp) (gfs:make-size :width (gfg:average-char-width metrics) + :height (gfg:height metrics))))) + (setf (slot-value disp 'gfw::viewport-origin) (gfs:make-point)) + (gfw:event-resize disp window (gfw:size window) :restored))) + +(defmethod initialize-instance ((self scroll-text-panel-events) &key) + (gfw:with-graphics-context (gc) + (setf (font-of self) (make-instance 'gfg:font :gc gc :data *text-panel-font-data*)))) + +(defmethod gfw:event-dispose ((disp scroll-text-panel-events) (panel gfw:panel)) + (let ((font (font-of disp))) + (if font + (gfs:dispose font)) + (setf (font-of disp) nil))) + +(defmethod gfw:event-paint ((disp scroll-text-panel-events) window gc rect) + (declare (ignore window)) + (setf (gfg:background-color gc) gfg:*color-white* + (gfg:foreground-color gc) gfg:*color-white*) + (gfg:draw-filled-rectangle gc rect) + (setf (gfg:foreground-color gc) gfg:*color-black* + (gfg:font gc) (font-of disp)) + (let* ((metrics (gfg:metrics gc (font-of disp))) + (pnt (gfs:location rect)) + (size (gfs:size rect)) + (first-row (floor (gfs:point-y pnt) (gfg:height metrics))) + (last-row (floor (+ (gfs:point-y pnt) (gfs:size-height size)) (gfg:height metrics))) + (first-col (floor (gfs:point-x pnt) (gfg:average-char-width metrics))) + (last-col (floor (+ (gfs:point-x pnt) (gfs:size-width size)) (gfg:average-char-width metrics)))) + (setf (gfs:point-x pnt) (* first-col (gfg:average-char-width metrics))) + (loop for row from first-row upto last-row + do (draw-text-chunk gc metrics row first-col last-col)))) + Modified: trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp (original) +++ trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp Wed Oct 11 13:01:23 2006 @@ -41,7 +41,7 @@ (setf pos (min pos (1+ (- total-steps page-size)))) (max pos 0)) -(defun compute-scrolling-delta (scrollbar step-size detail) +(defun update-scrollbar (scrollbar step-size detail) (let ((page-size (page-increment scrollbar)) (limits (outer-limits scrollbar)) (curr-pos (thumb-position scrollbar))) @@ -59,7 +59,7 @@ (- (gfs:span-end limits) (gfs:span-start limits)) page-size)) (setf (thumb-position scrollbar) new-pos) - (- curr-pos new-pos)))) + new-pos))) (defun update-scrolling-state (window &optional axis detail) (unless axis @@ -68,19 +68,20 @@ (setf detail :thumb-position)) (let ((disp (dispatcher window))) (let ((child (obtain-top-child window)) - (step-incs (step-increments disp)) - (delta-x 0) - (delta-y 0)) + (h-step (gfs:size-width (step-increments disp))) + (v-step (gfs:size-height (step-increments disp))) + (new-hpos 0) + (new-vpos 0)) (cond ((or (eql axis :horizontal) (eql axis :both)) (let ((scrollbar (obtain-horizontal-scrollbar window))) - (setf delta-x (compute-scrolling-delta scrollbar (gfs:size-width step-incs) detail)) - (gfs:dispose scrollbar))) + (setf new-hpos (update-scrollbar scrollbar h-step detail)))) ((or (eql axis :vertical) (eql axis :both)) (let ((scrollbar (obtain-vertical-scrollbar window))) - (setf delta-y (compute-scrolling-delta scrollbar (gfs:size-height step-incs) detail)) - (gfs:dispose scrollbar)))) - (let ((origin (slot-value disp 'viewport-origin))) + (setf new-vpos (update-scrollbar scrollbar v-step detail))))) + (let* ((origin (slot-value disp 'viewport-origin)) + (delta-x (* (floor (- (gfs:point-x origin) new-hpos) h-step) h-step)) + (delta-y (* (floor (- (gfs:point-y origin) new-vpos) v-step) v-step))) (decf (gfs:point-x origin) delta-x) (decf (gfs:point-y origin) delta-y) (scroll child delta-x delta-y nil 0)))) @@ -90,27 +91,22 @@ (if (or (<= (gfs:size-width amounts) 0) (<= (gfs:size-height amounts) 0)) (error 'gfs:toolkit-error :detail "invalid step increment"))) -(defun update-scrollbar-page-size (scrollbar viewport-width top-width step-size) +(defun update-scrollbar-page-size (scrollbar viewport-dim top-dim) (if scrollbar - (setf (page-increment scrollbar) (* (1+ (min viewport-width top-width)) - step-size))) + (setf (page-increment scrollbar) (1+ (min viewport-dim top-dim)))) scrollbar) (defun update-scrollbar-page-sizes (window) - (let ((disp (dispatcher window)) - (viewport-size (client-size window)) + (let ((viewport-size (client-size window)) (top (obtain-top-child window))) - (let ((step-incs (step-increments disp)) - (top-size (if top (size top) viewport-size))) + (let ((top-size (if top (size top) viewport-size))) (update-scrollbar-page-size (obtain-vertical-scrollbar window) (gfs:size-height viewport-size) - (gfs:size-height top-size) - (gfs:size-height step-incs)) + (gfs:size-height top-size)) (setf viewport-size (client-size window)) (update-scrollbar-page-size (obtain-horizontal-scrollbar window) (gfs:size-width viewport-size) - (gfs:size-width top-size) - (gfs:size-width step-incs))))) + (gfs:size-width top-size))))) (defun update-viewport-origin-for-resize (window) (let* ((top (obtain-top-child window))