[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

*To*: info-mcl@cambridge.apple.com*Subject*: Re: Scrolling views*From*: Alan Ruttenberg <alanr@media.mit.edu>*Date*: Thu, 11 Jun 92 00:24:05 EDT*Cc*: bill@cambridge.apple.com (Bill St. Clair)*In-reply-to*: Your message of Wed, 10 Jun 92 23:25:54 -0500. <9206110312.AA02680@cambridge.apple.com>*Reply-to*: alanr@media.mit.edu

>Date: Wed, 10 Jun 92 21:17:01 CST >From: ST7990@SIUCVMB.SIU.EDU >To: info-mcl@cambridge.apple.com >Subject: Scrolling views > >I'm using the scrollers in the library folder in MCL2.0b1 to scroll a window >in which editable-text-dialog-items are drawn. There are several (approx 200) >of these editabletext-dialog-items of varying sizes and containing text. As >is to be expected scrolling becomes horribly slow as the number of these >items increase; and deactivation/activation time when switching to/from >other windows is also slow. Does anyone have any suggestions how I might >speed things up? > >Thanks in advance. > >Chris Ryan >(SIUC) Here is some code I wrote a while ago. It worked on an earlier version of the lisp, and I figure that it should still work. Anyways let me know if it does, or if I can help you fix it, if it doesn't. Hope this helps, -alan (in-package :ccl) ;;The deal is that you (make-instance 'quad-view :initial-view some-view :field-size complete-size) ;;The subviews of that view are put into a quad tree of quad views, the top ;; of which gets its view container set to initial view. ;; Presto, if you had a lot of views then redisplay and mouse sensitivity speed increases substantially. (defclass basic-quad (view) ((subquads :initform nil :accessor subquads) (coordinates :initarg :coordinates :accessor quad-global-coordinates))) ; aspect ratio ; is the typical ration of the width of a view to it's height. The ; quad tree uses this when deciding how to construct the bins, using more bins ; say vertically for something which is typically longer than high. Default ; computes this by itself ; maximum-aspect-ratio ; The largest aspect ratio the window will use. The greater the aspect ratio ; the greater the branching ratio, and so the overhead at each level of the tree. ; maximum-branch-ratio ; An aspect ratio of 6 to 4 gives a branching ratio of 24. Use this to limit that. ; contained-field-size ; How big should the total size of the view be. ; alternate-divide-direction ; The quad tree alternates division is each direction. Use this to override. ; initial-view ; A view with a lot of subviews, pass this in, and it's subviews get quadified, and ; the quad view gets places in it. (defclass quad-view (basic-quad) ((initial-view :initarg :initial-view) initial-subviews (maximum-aspect-ratio :initform 6 :allocation :class) (maximum-branch-ratio :initform 12 :allocation :class) (contained-field-size :accessor view-field-size :initarg :field-size) (aspect-ratio :initform nil :initarg :aspect-ratio) (alternate-divide-direction :initform t :initarg :alternate-divide-direction)) (:default-initargs :view-nick-name 'top-quad)) ; Don't say anything about these. (defmethod view-help-string ((v basic-quad)) nil) (defmethod initialize-instance ((v quad-view) &rest args) (declare (dynamic-extent args) (ignore args)) (with-slots (initial-view coordinates) v ; create the window (call-next-method) (calculate-aspect-ratio v (view-subviews initial-view)) (let* ((view-size (add-points (slot-value v 'contained-field-size) #@(4 4))) (number-of-subviews (length (view-subviews initial-view))) (aspect-ratio (slot-value v 'aspect-ratio)) (number-of-levels (floor (log number-of-subviews (* (car aspect-ratio) (cdr aspect-ratio)))))) (set-view-size v view-size) (setq coordinates (cons (make-point 0 0) view-size)) (setf (slot-value v 'initial-subviews) (view-subviews initial-view)) ; create the quad tree (self-divide v number-of-levels view-size aspect-ratio) (map nil #'(lambda (new) (install-into-quad v new)) (remove-view-subviews initial-view)) ; install the quad tree in the initial view (set-view-container v initial-view) v))) (defun remove-view-subviews (view) (prog1 (view-subviews view) (setf (slot-value view 'view-subviews) (make-array 1 :adjustable t :fill-pointer 0)))) ; average the aspect ratio of all the views, and compensate for the fact that the ; tree would have an aspect ratio due to the view size being not square. (defmethod calculate-aspect-ratio ((v quad-view) views) (setf (slot-value v 'aspect-ratio) (rationalize-aspect-ratio v (* (or (slot-value v 'aspect-ratio) (round (/ (let ((sum 0.0)) (map nil #'(lambda(v) (incf sum (/ (point-h (view-size v)) (point-v (view-size v))))) views) sum) (length views)))) (point-v (view-size v)) (/ (point-h (view-size v)))) ))) ; return a list of small ratios as conses, ignoreing ones with a "1", or ones in which the ; product is more than branch (defun valid-aspect-ratios (max branch) (remove-duplicates (loop for i from 2 to max append (loop for j from 2 to max when (<= (* i j) branch) collect (cons i j))) :test #'(lambda(a b) (= (/ (car a) (cdr a)) (/ (car b) (cdr b)))) :from-end t)) ; given a fraction find an aspect ratio which is closest. Do this by looping ; through the aspect ratios and comapring to each. (defun closest-aspect-ratio (fraction ratios) (loop with dist = most-positive-fixnum with min = nil for r in ratios for this-dist = (abs (- (/ (car r) (cdr r)) fraction)) do (when (< this-dist dist) (setq dist this-dist) (setq min r)) finally (return min))) ; given a fraction, return a close aspect ratio as a cons numerator denominator (defmethod rationalize-aspect-ratio ((v quad-view) aspect-ratio) (let ((valid-aspect-ratios (valid-aspect-ratios (slot-value v 'maximum-aspect-ratio) (slot-value v 'maximum-branch-ratio)))) (let ((closest (closest-aspect-ratio aspect-ratio valid-aspect-ratios))) closest))) ; to construct the quad tree we recursively divide ourselves to a certain level ; Divide first in the direction which will have less of a chance to have an intersection with ; views intersections kill us since they get stuck high in the tree and we pay for them ; at every operation. (defmethod self-divide ((v basic-quad) count view-size aspect-ratio) (destructuring-bind (v-divide . h-divide) aspect-ratio (if (and (slot-value v 'alternate-divide-direction) (not (= v-divide h-divide))) (if (> h-divide v-divide) (self-divide-h v count view-size aspect-ratio) (self-divide-v v count view-size aspect-ratio)) (if (slot-value v 'alternate-divide-direction) (self-divide-h v count view-size aspect-ratio) (self-divide-both v count view-size aspect-ratio))))) ; this does a simultaneous divide of the view in both directions. (defmethod self-divide-both ((v basic-quad) count view-size aspect-ratio) (destructuring-bind (v-divide . h-divide) aspect-ratio (let* ((hsize (round (point-h view-size) h-divide)) (vsize (round (point-v view-size) v-divide)) (size (make-point hsize vsize)) (my-global-position (car (quad-global-coordinates v))) (sub (loop for i below h-divide appending (loop for j below v-divide for position = (make-point (* i hsize) (* j vsize)) for global-position = (add-points position my-global-position) collecting (make-instance 'basic-quad :view-position position :view-size size :coordinates (cons global-position (add-points global-position size))) )))) (setf (slot-value v 'subquads) sub) (dolist (v^ sub) (set-view-container v^ v) (when (plusp (1- count)) (self-divide v^ (1- count) size aspect-ratio)))))) (defmethod self-divide-h ((v basic-quad) count view-size aspect-ratio) (destructuring-bind (ignore . h-divide) aspect-ratio (declare (ignore ignore)) (let* ((hsize (round (point-h view-size) h-divide)) (size (make-point hsize (point-v (view-size v)))) (my-global-position (car (quad-global-coordinates v))) (sub (loop for i below h-divide for position = (make-point (* i hsize) 0) for global-position = (add-points position my-global-position) collecting (make-instance 'basic-quad :view-position (make-point (* i hsize) 0) :view-size size :coordinates (cons global-position (add-points global-position size)))))) (setf (slot-value v 'subquads) sub) (dolist (v^ sub) (set-view-container v^ v) (when (plusp (- count 1/2)) (self-divide-v v^ (- count 1/2) size aspect-ratio)))))) (defmethod self-divide-v ((v basic-quad) count view-size aspect-ratio) (destructuring-bind (v-divide . ignore) aspect-ratio (declare (ignore ignore)) (let* ((vsize (round (point-v view-size) v-divide)) (size (make-point (point-h (view-size v)) vsize)) (my-global-position (car (quad-global-coordinates v))) (sub (loop for i below v-divide for position = (make-point 0 (* i vsize)) for global-position = (add-points position my-global-position) collecting (make-instance 'basic-quad :view-position (make-point 0 (* i vsize)) :view-size size :coordinates (cons global-position (add-points global-position size)))))) (setf (slot-value v 'subquads) sub) (dolist (v^ sub) (set-view-container v^ v) (when (plusp (- count 1/2)) (self-divide-h v^ (- count 1/2) size aspect-ratio)))))) (defmethod view-field-size ((v basic-quad)) (view-size v)) ; compare two rectangles and see if one is completely contained in the other. ; macrology is so that the function that uses it isn't as ugly (which it is anyways) (defmacro wholly-contained (what in-what) (labels ((symcat (s string) (intern (concatenate 'string (string s) string))) (l (v) (symcat v "LEFT")) (r (v) (symcat v "RIGHT")) (t (v) (symcat v "TOP")) (b (v) (symcat v "BOTTOM"))) `(and (ccl::%i<= ,(l in-what) ,(l what)) (ccl::%i<= ,(l what) ,(r in-what)) (ccl::%i<= ,(l in-what) ,(r what)) (ccl::%i<= ,(r what) ,(r in-what)) (ccl::%i<= ,(t in-what) ,(t what) ) (ccl::%i<= ,(t what) ,(b in-what)) (ccl::%i<= ,(t in-what) ,(b what)) (ccl::%i<= ,(b what) ,(b in-what))))) ; Install a view into a quad. This is still too slow!! Recurse down the tree ; only stopping if we can't be completely contained in one of the subviews, ; or there aren't any (defmethod install-into-quad ((topv quad-view) v^) ;install v^; v. is current view (declare (optimize (speed 3) (safety 0))) (let* ((v^position (view-position v^)) (v^top (point-v v^position)) (v^left (point-h v^position)) (v^size (view-size v^)) (v^right (+ (point-h v^size) v^left)) (v^bottom (+ (point-v v^size) v^top))) (declare (type fixnum v^top v^left v^right v^bottom)) (labels ((install-into (v &aux (subquads (subquads v))) (declare (downward-function)) (when subquads (loop for v. in subquads for v.coordinates = (quad-global-coordinates v.) for v.bottomright = (cdr v.coordinates) for v.position = (car v.coordinates) for v.top fixnum = (point-v v.position) for v.left fixnum = (point-h v.position) for v.right fixnum = (point-h v.bottomright) for v.bottom fixnum = (point-v v.bottomright) do (when (wholly-contained v^ v.) (return-from install-into-quad (install-into v.))))) (set-view-position v^ (subtract-points v^position (car (quad-global-coordinates v)))) (set-view-container v^ v) v)) (install-into topv) ))) ;; modified from the original. If we find a view which is not of type subquad, the ;; return *it*, since it was one of the overlapping views. (defmethod find-view-containing-point ((view basic-quad) h &optional v (direct-subviews-only nil)) (declare (ignore direct-subviews-only)) (let* ((point (make-point h v)) (subviews (view-subviews view))) (do ((i (%i- (length subviews) 1) (%i- i 1))) ((%i< i 0)) (let ((subview (aref subviews i))) (when (view-contains-point-p subview point) (return-from find-view-containing-point (if (typep subview 'basic-quad) (find-view-containing-point subview (convert-coordinates point view subview) nil nil) subview)))))) view) (defun map-quads (quad fn) (funcall fn quad) (dolist (q (subquads quad)) (map-quads q fn))) ; return a list of (number-of-subviews example number-of-times-occurring) to get an idea of ; how the subquad is working. The special case is empty quads, we only want to see leaf quads ; which are empty, as they signify wasted space. Higher level empty ones are good. (defmethod subquad-stats ((q basic-quad)) (let ((bins nil)) (map-quads q #'(lambda(q) (let ((num (- (length (view-subviews q)) (length (subquads q))))) (unless (and (= num 0) (= (length (subquads q)) 0)) (let ((bin (assoc num bins :test #'=))) (if bin (incf (third bin)) (push (list num q 1) bins))))))) (sort bins '> :key 'car))) (defmethod subquad-stats ((w window)) (and (view-named 'top-quad w) (subquad-stats (view-named 'top-quad w)))) (provide :quad-views)

- Prev by Date:
**Re: LSIZ question...** - Next by Date:
**Re: foreign function blues** - Previous by thread:
**Scrolling views** - Next by thread:
**(defclass method ...) crashes** - Index(es):