this is the way I'm going to manage big lists
The last few days I had the time to work on my problem regarding big
listboxes. The following is a preliminary writing. Don't take it as
a definitive solution.
The <Scroll-generic-listbox> is a rewriting of the well known
<Scroll-listbox> with some hooks added to let extend this class in my
direction.
The <Scroll-ra-listbox> is nothing more than a suggestion on how to
manage big random access list of items in a listbox. In this class
you lose many features of the original <Scroll-listbox> but I belive
some of them don't make much sense in this context.
I hope the necessary hooks are all there. If you don't think so,
please let me know.
Bad news. In order to be able to use this code you have to apply the
following patch to tkListbox.c.
*** Tk/generic/tkListbox.c~ Sat Jan 3 13:46:25 1998
--- Tk/generic/tkListbox.c Mon Jun 29 21:45:22 1998
***************
*** 662,667 ****
--- 662,678 ----
goto error;
}
sprintf(interp->result, "%d", index);
+ } else if ((c == 'l') && (strncmp(argv[1], "lines", length) == 0) &&
+ (length >= 2)) {
+ /* -wcp6/29/98. */
+ if (argc != 2)
+ {
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ argv[0], " lines\"",
+ (char *) NULL);
+ goto error;
+ }
+ sprintf(interp->result, "%d", listPtr->fullLines);
} else if ((c == 'i') && (strncmp(argv[1], "insert", length) == 0)
&& (length >= 3)) {
int index;
Here is ScrollBbox.stklos:
--------------------8<--------------------8<--------------------
;;; ScrollBbox.stklos --- Scroll-listbox to manage big lists
;;; _at_(#)$Id$
;;; Copyright (C) 1998 by Walter C. Pelissero
;;; Author: Walter C. Pelissero <wcp_at_lpds.sublink.org>
;;; Permission to use, copy, and/or distribute this software and its
;;; documentation for any purpose and without fee is hereby granted,
;;; provided that both the above copyright notice and this permission
;;; notice appear in all copies and derived works. Fees for
;;; distribution or use of this software or derived works may only be
;;; charged with express written permission of the copyright holder.
;;; This software is provided ``as is'' without express or implied
;;; warranty.
(require "Basics")
(select-module STklos+Tk)
(define-class <Scroll-generic-listbox> (<Tk-composite-widget> <Listbox>)
((class :init-keyword :class
:init-form "ScrollListbox")
(listbox :accessor listbox-of)
(h-scrollbar :accessor h-scrollbar-of)
(v-scrollbar :accessor v-scrollbar-of)
(h-scroll-side :accessor h-scroll-side
:allocation :virtual
:init-keyword :h-scroll-side
:slot-ref (lambda (o)
(STk:h-scroll-side
(slot-ref o 'h-scrollbar)))
:slot-set! (lambda (o v)
(STk:h-scroll-side-set!
(slot-ref o 'h-scrollbar) v)))
(v-scroll-side :accessor v-scroll-side
:allocation :virtual
:init-keyword :v-scroll-side
:slot-ref (lambda (o)
(STk:v-scroll-side
(slot-ref o 'v-scrollbar)))
:slot-set! (lambda (o v)
(STk:v-scroll-side-set!
(slot-ref o 'v-scrollbar) v)))
;; This function is called whenever listbox changes its view. It
;; normally notifies vertical scroll bar to change its position.
(lb-scroll-command :accessor lb-scroll-command
:init-keyword :lb-scroll-command
:init-form
(lambda (lb sb args)
(apply (slot-ref sb 'Id) 'set args)))
;; This function is called whenever vertical scroll bar changes its
;; position. It normally notifies listbox to change its view.
(vsb-position-command :accessor vsb-position-command
:init-keyword :vsb-position-command
:init-form
(lambda (lb sb args)
(apply (slot-ref lb 'Id) 'yview args)))
;; Non allocated slots
(background :accessor background
:init-keyword :background
:allocation :propagated
:propagate-to (frame listbox h-scrollbar v-scrollbar))
(border-width :accessor border-width
:allocation :propagated
:init-keyword :border-width
:propagate-to (frame))
(relief :accessor relief
:init-keyword :relief
:allocation :propagated
:propagate-to (frame))))
;;;;
;;;; <Scroll-generic-listbox> methods
;;;;
(define-method initialize-composite-widget ((self <Scroll-generic-listbox>) initargs parent)
(let* ((hs (make <Scrollbar> :parent parent :orientation "horizontal"))
(vs (make <Scrollbar> :parent parent :orientation "vertical"))
(l (make <Listbox> :parent parent)))
;; Set internal true slots
(slot-set! self 'Id (slot-ref l 'Id))
(slot-set! self 'listbox l)
(slot-set! self 'h-scrollbar hs)
(slot-set! self 'v-scrollbar vs)
;; Place internal widgets
(grid hs :row 0 :column 1 :sticky "we") (grid 'remove hs)
(grid l :row 1 :column 1 :sticky "nswe")
(grid vs :row 1 :column 2 :sticky "ns")
(grid 'rowconf parent 1 :weight 1)
(grid 'columnconf parent 1 :weight 1)
;; Attach command to scrollbar and listbox
(slot-set! l 'x-scroll-command (lambda l (apply (slot-ref hs 'Id) 'set l)))
(slot-set! l 'y-scroll-command
(lambda args
((slot-ref self 'lb-scroll-command) l vs args)))
(slot-set! hs 'command (lambda args (apply (slot-ref l 'Id) 'xview args)))
(slot-set! vs 'command
(lambda args
((slot-ref self 'vsb-position-command) l vs args)))))
(define-class <Scroll-ra-listbox> (<Scroll-generic-listbox>)
((listbox :accessor listbox-of)
(list-size :accessor list-size
:init-keyword :list-size
:init-form (lambda () 0))
(get-lines :accessor get-lines
:init-keyword :get-lines
:init-form (lambda (offset nlines) '()))
(position)))
(define-method initialize ((self <Scroll-ra-listbox>) args)
(next-method)
(slot-set! self 'position 0)
(slot-set! self 'lb-scroll-command
(lambda (lb sb args)
(let ((size ((slot-ref self 'list-size)))
(pos (slot-ref self 'position))
(getl (slot-ref self 'get-lines)))
(slot-set! lb 'value (getl pos (listbox-lines lb)))
;; (apply (slot-ref sb 'Id) 'set args)
((slot-ref sb 'Id) 'set (/ pos size)
(/ (+ pos (listbox-lines lb) size))))))
(slot-set! self 'vsb-position-command
(lambda (lb sb args)
(let* ((size ((slot-ref self 'list-size)))
(pos (slot-ref self 'position))
(getl (slot-ref self 'get-lines))
(new-pos
(min (- size 1)
(max 0
(case (car args)
((moveto)
(inexact->exact
(* (cadr args) size)))
((scroll)
(let ((n (cadr args))
(unit (caddr args)))
(+ pos
(* n
(if (eq? unit 'units)
1
(listbox-lines lb))))))
(else pos))))))
(if (not (= new-pos pos))
(begin
(slot-set! self 'position new-pos)
(slot-set! lb 'value
(getl new-pos
(listbox-lines lb)))))))))
(define-method current-selection ((self <Scroll-ra-listbox>))
(let ((sel (next-method))
(pos (slot-ref self 'position)))
(if sel
(map (lambda (x) (+ x pos)) sel)
sel)))
(define-method size ((self <Scroll-ra-listbox>))
((slot-ref self 'list-size)))
;;; Please note that many inherited methods make no sense for
;;; <Scroll-ra-listbox> class.
(provide "ScrollBbox")
--------------------8<--------------------8<--------------------
Here is a simple test program:
--------------------8<--------------------8<--------------------
;;; tslb.stk --- Test code for new Scroll-listbox
;;; _at_(#)$Id$
;;; Copyright (C) 1998 by Walter C. Pelissero
;;; Author: Walter C. Pelissero <wcp_at_lpds.sublink.org>
;;; Code:
(require "Tk-classes")
(require "ScrollBbox")
(define lines (list->vector (exec-string-list "ls /dev")))
(define l1 (make <Scroll-generic-listbox> :h-scroll-side "bottom"
:relief "ridge" :border-width 2
:value (vector->list lines)))
(pack l1 :expand #t :fill 'both)
(define (sublist position items)
(let ((e (min (+ position items) (vector-length lines))))
(let loop ((i position))
(if (< i e)
(cons (vector-ref lines i) (loop (+ i 1)))
'()))))
(define l2
(let ((pos 0)) ; current position
(make <Scroll-generic-listbox> :h-scroll-side "bottom"
:relief "ridge" :border-width 2
:lb-scroll-command
(lambda (lb sb args)
(slot-set! lb 'value
(sublist pos (listbox-lines lb)))
;; (apply (slot-ref sb 'Id) 'set args)
((slot-ref sb 'Id) 'set (/ pos (vector-length lines))
(/ (+ pos (listbox-lines lb)
(vector-length lines)))))
:vsb-position-command
(lambda (lb sb args)
(let ((new-pos
(min (- (vector-length lines) 1)
(max 0
(let ((command (car args)))
(cond ((eq? 'moveto command)
(inexact->exact (* (cadr args)
(vector-length lines))))
((eq? 'scroll command)
(let ((n (cadr args))
(unit (caddr args)))
(+ pos (* n
(cond ((eq? unit 'units)
1)
((eq? unit 'pages)
(listbox-lines lb)))))))
(else pos)))))))
(if (not (= new-pos pos))
(begin
(set! pos new-pos)
;; Uncomment only one of the following two lines
;; ((slot-ref lb 'y-scroll-command) 0 1)
(slot-set! lb 'value (sublist pos (listbox-lines lb))))))))))
(pack l2 :expand #t :fill 'both)
(define l3 (make <Scroll-ra-listbox>
:list-size (let ((size (vector-length lines)))
(lambda () size))
:get-lines sublist))
(pack l3 :expand #t :fill 'both)
;;; tslb.stk ends here
Received on Thu Jul 02 1998 - 05:05:18 CEST
This archive was generated by hypermail 2.3.0
: Mon Jul 21 2014 - 19:38:59 CEST