[graphic-forms-cvs] r297 - in trunk/src: demos/unblocked tests/uitoolkit uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Wed Oct 11 17:01:24 UTC 2006
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))
More information about the Graphic-forms-cvs
mailing list