Re: Scrolling views

[Alan Ruttenberg <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)