[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: limited number of items in table-sequence ????
- To: david.bright@NIST.GOV (David S. Bright)
- Subject: Re: limited number of items in table-sequence ????
- From: tkunze@ccrma.Stanford.EDU (Tobias Kunze)
- Date: Mon, 10 Apr 95 14:01:20 -0700
- Cc: info-mcl@digitool.com
- Sender: owner-info-mcl@digitool.com
[Mathieu Lafourcade: forget the code i sent to you yesterday! I went
trough the trouble of making it self-contained--here it is:]
> > We ended up defining our own class that caches lines in a hashtable
> >and does all the vertical drawing on its own, but relies on the standard
> >set-view-scroll-position mechanism for horizontal scrolling, since
> >we only needed one-dimensional lists. It is quite zippy (way faster
> >
> >than table-dialog-item) now while adhering as much as possible to the
> >standard protocol.
> >
> >i can send you the code, if you are interested.
>
> I'd be interested too.
>
> Thanks very much
>
> --Dave
>
Hope this helps. there is a little example at the bottom of the file.
;;; **********************************************************************
;;; Copyright (c) 1995 Heinrich Taube and Tobias Kunze. All rights
;;; reserved. Use and copying of this software and preparation of
;;; derivative works based upon this software are permitted and may be
;;; copied as long as no fees or compensation are charged for use,
;;; copying, or accessing this software and all copies of this software
;;; include this copyright notice.
;;; **********************************************************************
;;; Note:
;;;
;;; this is code designed to be part of the ``CommonMusic'' composition
;;; environment, written by Rick Taube. i made it into a stand-alone
;;; package for demonstrational purposes only.
;;; and, yes: don't expect bug-free code!
(defpackage test (:use :common-lisp))
(in-package :test)
(ccl:require 'scrollers)
;;;
;;; various definitions used by sequence-view
(defmacro xy (x y) `(ccl:make-point ,x ,y))
(defmacro xy-x (xy) `(ccl:point-h ,xy))
(defmacro xy-y (xy) `(ccl:point-v ,xy))
(defmacro xy+ (xy1 xy2) `(ccl:add-points ,xy1 ,xy2))
(defmacro xy- (xy1 xy2) `(ccl:subtract-points ,xy1 ,xy2))
(defmacro xyinc (xy dx dy)
`(ccl:add-points ,xy (ccl:make-point ,dx ,dy)))
(defmacro xy= (xy1 xy2) `(= ,xy1 ,xy2))
(defmacro view-height (view)
`(ccl:point-v (ccl:view-size ,view)))
(defun make-font (&key name size face mode
(defaults '( "Geneva" 10 :plain :srcor)))
(let ((new (or (copy-list defaults) (make-list 4))))
(when name (setf (first new) name))
(when size (setf (second new) size))
(when mode (setf (third new) mode))
(when face (setf (fourth new) face))
new))
(defparameter *listing-font* (make-font :name "Courier" :size 10))
(defun font-height (&optional font)
;; why dont they define this?
(multiple-value-bind (a d m l) (ccl:font-info font)
(values (+ a d l) a d l m)))
(defun string-extent (string font &optional extra)
(let ((w (ccl:string-width string font))
(h (font-height font)))
(if extra (xy+ (xy w h) extra) (xy w h))))
(defun canonicalize-point-args (prefer &optional h v)
(ecase prefer
(:point (if (and h v)
(xy h v)
h))
(:values (when (and h (not v))
(setf v (xy-y h)
h (xy-x h)))
(values h v))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;
;;; sequence-view
;;;
;;;
;;; sequence-view allows for arbitrary vertical scrolling.
;;; - visible is a cons cell holding the index of the first and
;;; and last visible entry
;;; - view-size is maintained by mcl and equals the view size
;;; minus scroll bars
;;; - view-area is the actual used size of the pane, that is,
;;; view-size + (xy-x scroll-position)
;;; - cell-size is (xy maximum-estimated-width font-height)
;;; Actual drawing takes place within cells and is clipped to
;;; call-size _and_ frame-size; highlighting, however, always
;;; extends horizontally to the vertical scroll bar.
;;; Horizontal scrolling operates as expected (ie, by shifting
;;; the image); vertical scrolling passes control and responsibility
;;; of drawing to the program. The vertical scroll bar is set to
;;; the maximum resolution of #x7fff--<current-position>/#x7fff then
;;; translates to the a number x/(<nr-of-cells> - <displayable-cells>)
(defconstant +scroll-bar-max+ #x7fff)
(defclass sequence-view (ccl::scroller)
((length :initform 0 :accessor sequence-length)
(sequence :initform nil :initarg :table-sequence
:accessor table-sequence)
(selected :accessor listing-selected :accessor sequence-selected)
(nselected :initform 0 :accessor sequence-nselected)
(visible :accessor sequence-visible)
(cell-size :initarg :cell-size :initform nil
:accessor sequence-cell-size)
(view-area :initform 0)
(last-selected-cell :initform nil :accessor last-selected-cell)))
(defmacro key-arg (key arglist)
`(cadr (member ,key ,arglist)))
(defmethod initialize-instance :after ((view sequence-view) &rest args)
(let ((vs (or (key-arg :view-size args)
(ccl:view-size view)
(ccl:view-default-size view))))
(setf (slot-value view 'cell-size)
(xy (- (xy-x vs) 15)
(font-height *listing-font*)))
(setf (slot-value view 'view-area) vs)
;; call set-table-sequence with slot visible still unbound ...
(set-table-sequence view (slot-value view 'sequence))
;; ... then bind it.
(setf (slot-value view 'visible) (cons 0 0))
(setf (ccl:scroll-bar-scroll-size (ccl::v-scroller view))
(let ((invisible (- (sequence-length view)
(displayable-lines view #'floor))))
(if (> invisible 0)
(floor (/ +scroll-bar-max+ invisible))
0)))
(setf (ccl:scroll-bar-scroll-size (ccl::h-scroller view))
(xy-x (string-extent "M" (ccl:view-font view))))
(ccl::update-scroll-bar-limits view)))
(defmethod set-table-sequence ((view sequence-view) sequence)
(let ((length (length sequence)))
(setf (slot-value view 'sequence) sequence)
(setf (slot-value view 'length) length)
(setf (slot-value view 'selected)
(make-array length :element-type 'bit
:initial-element 0))
(when (slot-boundp view 'visible)
(update-sequence-visible view))
(ccl::update-scroll-bar-limits view)))
(defmacro sequence-first-visible (view)
`(car (sequence-visible ,view)))
(defmacro sequence-last-visible (view)
`(cdr (sequence-visible ,view)))
(defun update-sequence-visible (view)
(let ((lines (ceiling (view-height view)
(xy-y (sequence-cell-size view)))))
(setf (sequence-last-visible view)
(min (1- (+ (sequence-first-visible view) lines))
(1- (sequence-length view))))))
;;
;; helper function; i use (sequence-cell-size view) just as a matter of
;; style--if it's not yet set, font-height jumps in
(defun displayable-lines (view round-fn)
(let ((cell-size (sequence-cell-size view)))
(funcall round-fn
(view-height view) (if cell-size
(xy-y cell-size)
(font-height *listing-font*)))))
;;
;; scroll-bar limits
;; - horizontally limits are 0 and (- (xy-x cell-size) (xy-x view-area)),
;; but at least the current horizontal scroll position
;; - vertical limits are either both 0 or 0 and +scroll-bar-max+
(defmethod ccl::scroll-bar-limits ((view sequence-view))
;; make sure cell-size is valid during initialization
(let ((cell-size (or (slot-value view 'cell-size) 0)))
(ccl::normal-scroll-bar-limits view (xy-x cell-size))))
(defmethod ccl::normal-scroll-bar-limits ((view sequence-view)
max-h &optional max-v)
(declare (ignore max-v))
(let* ((size (ccl:view-size view))
(h-size (xy-x size))
(x-pos (xy-x (ccl:view-scroll-position view))))
(setf (slot-value view 'view-area) (xy (+ x-pos h-size) (xy-y size)))
(values (xy 0 (+ x-pos (max 0 (- max-h h-size))))
(xy 0 (if (> (slot-value view 'length)
(displayable-lines view #'floor))
+scroll-bar-max+
0)))))
;;;
;;; gets called by ccl:scroll-bar-changed with arg h bound to a point
(defmethod ccl::set-view-scroll-position ((view sequence-view) h
&optional v visibly?)
(declare (ignore visibly?))
(multiple-value-setq (h v) (canonicalize-point-args :values h v))
(let ((pos (ccl::view-scroll-position view))
(invalidate? nil)
(new-index (floor (* (- (sequence-length view)
(displayable-lines view #'floor))
(/ (ccl::scroll-bar-setting
(slot-value view 'ccl::v-scroller))
+scroll-bar-max+))))
(old-index (sequence-first-visible view)))
(unless (= (xy-x pos) h)
(setf (slot-value view 'ccl:view-scroll-position) (xy h 0))
(setf (slot-value view 'view-area)
(+ (ccl:view-size view) h))
(call-next-method)
(setf invalidate? t))
(unless (= new-index old-index)
(setf (sequence-first-visible view) new-index)
(setf invalidate? t)
(update-sequence-visible view))
(when invalidate?
(ccl::invalidate-view view))
;(ccl:view-draw-contents view)
;(format t "~& svsp: (~a ~a) ~a" h v invalidate?)
(values)))
;;
;; pass 0 as the vertical scroll bar setting instead of the vertical
;; scroll position (which is always 0 for scrolling views) when
;; scrolling horizontally
(defun %scroll-sequence-view (view int direction &optional (min 0))
(ccl::set-view-scroll-position
view
(if (eq direction :vertical)
(logior (logand #xffff (ccl::view-scroll-position view))
(ash int 16))
int))
(when (eql int min)
(ccl::update-scroll-bar-limits view))
(ccl::window-update-event-handler (ccl::view-window view)))
(defmethod ccl::scroll-bar-changed ((view sequence-view) scroll-bar)
(let ((new-value (ccl::scroll-bar-setting scroll-bar)))
(%scroll-sequence-view view new-value
(slot-value scroll-bar 'ccl::direction)
(ccl::scroll-bar-min scroll-bar))))
;;
;; ccl::set-view-scroll-position on ccl::scroller-mixin calls
;; this after calling the next method--so we need to invalidate
;; it for sequence-views
(defmethod ccl::update-thumbs ((view sequence-view))
(declare (ignore view)))
;;
;; page size
;; horizontal value is the view area vertical value the displayable
;; lines over the total lines scaled up to +scroll-bar-max+
(defmethod ccl::scroll-bar-page-size ((view sequence-view))
(xy (xy-x (slot-value view 'view-area))
(floor (* +scroll-bar-max+
(min 1
(/ (displayable-lines view #'floor)
(max 1 (sequence-length view))))))))
;;;
;;; sequence drawing.
;;;
(defun font-base-line (font)
(multiple-value-bind (a d m l) (ccl:font-info font)
(declare (ignore d m))
(+ a l)))
(defmethod ccl:view-draw-contents ((view sequence-view))
(let ((area (slot-value view 'view-area)))
(ccl:without-interrupts
(ccl:with-font-focused-view view
(ccl:rlet ((rect :rect :left 0 :right (xy-x area)))
(#_eraserect rect)
(loop with h = (xy-y (slot-value view 'cell-size))
with height = (xy-y area)
with baseline = (font-base-line *listing-font*)
for i from (sequence-first-visible view)
to (sequence-last-visible view)
for y = 0 then b
for b = (+ y h)
do
(setf (ccl:rref rect rect.top) y)
(setf (ccl:rref rect rect.bottom) (min b height))
(draw-table-cell view 0 i rect baseline
(cell-selected-p view 0 i))))))))
(defmethod draw-table-cell ((view sequence-view)
col row rect baseline selected?)
(ccl:with-clip-rect rect
(#_EraseRect rect)
(#_MoveTo (+ (ccl:rref rect rect.left) 3)
(+ (ccl:rref rect rect.top) baseline))
(draw-cell-contents view col row)
(when selected? (highlight-table-cell view nil rect t))))
;;;
;;; col is ignored here; row may be a single row or a list.
;;; the calling pattern is just to comply with ccl's protocol.
(defmethod redraw-cell ((view sequence-view) col &optional row)
(unless row
(setf row (xy-y col)))
(ccl:with-font-focused-view view
(let* ((area (slot-value view 'view-area))
(width (xy-x area))
(height (xy-y area))
(csize (slot-value view 'cell-size))
;(cwidth (xy-x csize))
(cheight (xy-y csize))
(baseline (font-base-line *listing-font*))
(nr-of-elements (slot-value view 'length)))
(ccl:rlet ((rect :rect :left 0 :right width))
(flet ((maprow (r)
(when (< r nr-of-elements)
(let ((top (* (- r (sequence-first-visible view)) cheight)))
(setf (ccl:rref rect rect.top) top
(ccl:rref rect rect.bottom) (min height
(+ top cheight)))
(draw-table-cell view 0 r rect baseline
(cell-selected-p view 0 r))))))
(if (consp row)
(dolist (r row) (maprow r))
(maprow row)))))))
(defmethod highlight-table-cell ((view sequence-view) cell
rect selectedp)
(declare (ignore selectedp cell))
(#_InvertRect rect))
;;;
;;; mouse selection:
;;;
;;; - normal click: toggle selected-p
;;; - command-click: adds or removes single (or multiple, if dragged)
;;; elements to the current selection
;;; - shift-click: select all elements from the last clicked one to the
;;; current element
;;; all modifier keys allow for drag-selection/deselection. if the drag
;;; speed is too fast, the code catches up with the current mouse position.
(defmethod ccl:view-click-event-handler ((view sequence-view) pos)
(let ((index (point-to-cell view pos))
(range (sequence-visible view))
(length (sequence-length view))
(redraw '())
(selected? nil))
(flet ((track-selection (init fun)
(declare (integer init) (function fun)
(optimize (speed 3) (safety 0)))
(let* ((lh (xy-y (slot-value view 'cell-size)))
(dl (displayable-lines view #'floor))
(vh (* dl lh))
(len (sequence-length view))
(hl (- len dl))
(vscr (slot-value view 'ccl::v-scroller))
(inc (if (= hl 0)
0
(floor (/ +scroll-bar-max+ (- len dl)))))
(i-1 init))
(declare (integer lh dl vh len inc i-1))
(loop for y = (the integer (xy-y (ccl:view-mouse-position
view)))
for i = (the integer (point-to-cell
view 0 (min vh (max y 0))))
while (ccl:mouse-down-p)
do
;; scroll line by line as long as the mouse is outside
(unless (<= 0 y vh)
(%scroll-sequence-view view lh :vertical 0)
(ccl::set-scroll-bar-setting
vscr (funcall (if (< y 0) #'- #'+)
(ccl:scroll-bar-setting vscr) inc)))
(unless (or (= i i-1) (>= i len))
(funcall fun view 0 i)
(setf (last-selected-cell view) i)
(when (> (abs (- i i-1)) 1)
(let* ((diff (- i i-1))
(by (signum diff))
(rep (+ (abs diff) by)))
(declare (integer diff by rep))
(loop for j from (+ i-1 by) by by
repeat rep
do (funcall fun view 0 j)))))
(setf i-1 i)
finally (unless (>= i len)
(setf (last-selected-cell view) i))))))
(when (< index length)
(setf selected? (cell-selected-p view 0 index)))
(cond ((ccl:command-key-p)
(when (< index length)
(let ((fun (if selected? #'cell-deselect #'cell-select)))
(funcall fun view 0 index)
(track-selection index fun))))
((ccl:shift-key-p)
(setf index (min (1- (sequence-length view))
(max index 0)))
(let* ((last (or (last-selected-cell view) index))
(s (min index last))
(e (max index last)))
(setf redraw
(loop for i from (car range) to (cdr range)
for p = (cell-selected-p view 0 i)
when (if (<= s i e)
(not p)
p)
collect i))
(loop for i from s to e
unless (cell-selected-p view 0 i)
do (%cell-select view 0 i))
(funcall #'redraw-cell view 0 redraw)
(track-selection index #'cell-select)))
(t
(when (not selected?)
(when (> (sequence-nselected view) 0)
(setf redraw
(loop for i from (car range) to (cdr range)
when (cell-selected-p view 0 i)
collect i))
(%deselect-all-cells view))
(when (< index (sequence-length view))
(%cell-select view 0 index)
(pushnew index redraw))
(funcall #'redraw-cell view 0 redraw))
(track-selection index #'cell-select))))))
;;
;; point2cell
;; Since we never scroll the view vertically, vertical coords are always 0.
;; Thus, add (sequence-first-visible view) to get the actual cell.
(defmethod point-to-cell ((view sequence-view) xy &optional y)
(+ (sequence-first-visible view)
(floor (or y (xy-y xy)) (xy-y (slot-value view 'cell-size)))))
;; unused
;;
;(defmethod table-dimensions ((view sequence-view))
; (xy 0 (sequence-length view)))
(defmethod cell-selected-p ((view sequence-view) col &optional row)
(= (the bit
(aref (the simple-bit-vector (slot-value view 'selected))
(the integer (or row (xy-y col)))))
1))
(defmacro %%set-cell-selection (array row value)
`(setf (aref (the simple-bit-vector ,array)
(the integer ,row))
(the bit ,value)))
(defmethod cell-select ((view sequence-view) col &optional row)
(unless (cell-selected-p view col row)
(%cell-select view col row)
(redraw-cell view col row)))
(defmethod cell-deselect ((view sequence-view) col &optional row)
(when (cell-selected-p view col row)
(%cell-deselect view col row)
(redraw-cell view col row)))
(defmethod %cell-select ((view sequence-view) col &optional row)
(%%set-cell-selection (slot-value view 'selected)
(or row (xy-y col))
1)
(incf (slot-value view 'nselected)))
(defmethod %cell-deselect ((view sequence-view) col &optional row)
(%%set-cell-selection (slot-value view 'selected)
(or row (xy-y col))
0)
(decf (slot-value view 'nselected)))
(defmethod selected-cells ((view sequence-view))
(let ((v (slot-value view 'selected))
(s (slot-value view 'nselected))
(c 0))
(declare (simple-bit-vector v))
(loop for i below (sequence-length view)
while (< c s)
when (= (the bit (aref v i)) 1)
collect i and do (incf c))))
(defmethod map-selected-cells (fn (view sequence-view))
(let ((v (sequence-selected view))
(l (sequence-length view))
(s (sequence-nselected view))
(c 0))
(declare (simple-bit-vector v) (integer l s c))
(loop for i below l
while (< c s)
when (= (the bit (aref v i)) 1)
do
(funcall fn i)
(incf c))
(values)))
(defmethod map-selected-objects (fn (view sequence-view))
(let ((v (sequence-selected view))
(s (table-sequence view))
(n (sequence-nselected view))
(c 0)
(i 0))
(declare (simple-bit-vector v) (integer n c i) (list s)
;(optimize (speed 3 safety 0))
)
(loop while (< c n)
do
(when (= (the bit (aref v i)) 1)
(funcall fn (car s))
(incf c))
(incf i)
(setf s (cdr s)))
(values)))
(defun selected-objects (sequence)
(let ((l '()))
(map-selected-objects #'(lambda (o) (push o l)) sequence)
(nreverse l)))
(defmethod map-sequence-cells (fn (view sequence-view))
(loop for i below (sequence-length view) do (funcall fn i)))
(defmethod map-sequence-objects (fn (view sequence-view))
(loop for o in (table-sequence view) do (funcall fn o)))
(defmethod select-all-cells ((view sequence-view))
(%select-all-cells view)
(ccl:invalidate-view view))
(defmethod deselect-all-cells ((view sequence-view))
(%deselect-all-cells view)
(ccl:invalidate-view view))
(defmethod %select-all-cells (view)
(let ((v (sequence-selected view)))
(loop for i below (sequence-length view)
do
(%%set-cell-selection v i 1))
(setf (slot-value view 'nselected) (sequence-length view))))
(defun %deselect-all-cells (view)
(let ((v (sequence-selected view))
(l (sequence-length view))
(c 0))
(declare (simple-bit-vector v) (integer l s c))
(loop for i below l
do
(%%set-cell-selection v i 0)
(incf c))
(setf (slot-value view 'nselected) 0)))
(defun first-selected-cell (view &optional from-end)
(and (> (sequence-nselected view) 0)
(position 1 (sequence-selected view) :from-end from-end)))
;;;
;;; default cell functions.
;;;
(defmethod draw-cell-contents ((view sequence-view) col &optional row)
(declare (ignore col))
(ccl:with-pstrs ((s (prin1-to-string (cell-contents view 0 row))))
(#_DrawString s)))
(defmethod cell-contents ((view sequence-view) col &optional row)
;; default cell contents funtion
(declare (ignore col))
(elt (table-sequence view) row))
#|
;;; simple test window
(setf w (make-instance 'ccl:window
:window-type :document
:view-subviews
(list (make-instance 'sequence-view
:table-sequence (loop for i below 10000 collect i)))))
|#
;;;
;;; -*- EOF -*-