[plt-scheme] Help with unfinished multi-column listbox

I'm stuck with a multi-column listbox and would appreciate any help.  
I've put the sample code below as text, it should run in the module  
language if pasted into DrScheme. Note how the box dynamically  
resizes nicely. The headers will be improved later and I intend to  
add automatic sorting and lots of fancy options.

Right now, I can't figure out  how to visually display the selection  
of a whole line when one embedded editor is selected in display mode.  
The main classes are multi-list-box-cell% for a cell in the listbox  
that can be inline edited by alt-clicking into it, multi-list-box- 
heading% for the heading cells, and multi-list-box% for the listbox  
embedding and managing these. Look for (display 'selection) in the  
selection-callback at the end of the definition of multi-list-box%.  
Based on a multi-list-cell% given to the selection callback, I need  
to find all editors in the same line and color them or use some way  
how to highlight the *whole line* including all editors in it--not  
just the text in the editors, and also without scrolling the list.

I'm totally lost in the MrEd jungle. Does anyone have a suggestion?

Best regards,

Erich

---------- sample code below, run with (test)   
-------------------------------------------------------------
---------- ignore redundant lets, etc., as I've stripped away some  
code ----------------------------

(module guisample mzscheme
   (provide get-main-frame main-frame% test)
   (require (lib "etc.ss")
            (lib "class.ss")
            (lib "mred.ss" "mred")
            (prefix srfi43- (lib "43.ss" "srfi")))

   ;;; a few helper functions (originally from other modules)

   (define-syntax dotimes
     (syntax-rules ()
       ((_ (var n res) . body)
        (do ((limit n)
             (var 0 (+ var 1)))
          ((>= var limit) res)
          . body))
       ((_ (var n) . body)
        (do ((limit n)
             (var 0 (+ var 1)))
          ((>= var limit))
          . body))))

     (define-syntax repeat-times
     (syntax-rules ()
       ((_ number expr ...)
        (let loop ([i number])
          (when (> i 0)
            (begin
              expr ...
              (loop (- i 1))))))))

   (define-syntax with
     (syntax-rules ()
       ((_ name bind expr ...)
        (let ((name bind))
          expr ...))))

   (define (raise-empty-vector-error s v)
     (raise-mismatch-error s "expected-non-empty-vector-of-numbers,  
given empty vector " v))

   (define (vector-sum v)
     (if (srfi43-vector-empty? v)
         (raise-empty-vector-error 'vector-sum v)
         (srfi43-vector-fold
          (lambda (idx sum elem) (+ sum elem))
          0 v)))

   (define (vector-min v)
     (let ((result
            (srfi43-vector-fold
             (lambda (idx minimum elem)
               (if minimum
                   (if (< elem minimum)
                       elem
                       minimum)
                   elem))
             #f v)))
       (if result
           result
           (raise-empty-vector-error 'vector-min v))))

   (define (vector-max v)
     (let ((result
            (srfi43-vector-fold
             (lambda (idx minimum elem)
               (if minimum
                   (if (> elem minimum)
                       elem
                       minimum)
                   elem))
             #f v)))
       (if result
           result
           (raise-empty-vector-error 'vector-max v))))

   ;;; HELPER CLASSES

   (define display/edit-text%
     (class* text% ()
       (define mode 'display)

       (init-field (parent #f))

       (init-field (selection-callback void))
       (inherit select-all)

       (define private-lock? #f)

       (define/augment (after-set-position)
         (unless (send this has-private-lock?)
           (begin (send this private-lock #t)
                  (selection-callback this)))
         (send this private-lock #f))

       (define/public (set-selection-callback proc)
         (set! selection-callback proc))

       (define/public (get-parent)
         parent)

       (define/public (display-init)
         (display-update))


       (define/public private-lock
         (case-lambda
           [() (send this has-private-lock?)]
           [(bool) (set! private-lock? bool)]))

       (define/public (has-private-lock?)
         private-lock?)

       (define/public (display-update)
         (send this begin-edit-sequence)
         (set-suitable-cursor)
         (set-suitable-caret)
         (set-suitable-selection)
         (send this end-edit-sequence)
         )

       (define/override (on-focus on?)
         (unless on?
           (display-mode 'display)))

       (define/overment (on-default-event evt)
         (cond ((send evt get-left-down)
                (cond ((send evt get-alt-down)
                       (send this display-mode 'edit)
                       (super on-default-event evt))
                      (else (when (send this has-display-mode? 'display)
                              (let ((parent (get-parent))) (when  
parent (send parent on-display-mode-event evt this)))))))
               (else
                (when (send this has-display-mode? 'display)
                  (let ((parent (get-parent))) (when parent (send  
parent on-display-mode-event evt this)))))))

       (define (set-suitable-cursor)
         (case mode
           ((display) (send this set-cursor (make-object cursor%  
'arrow)))
           ((edit) (send this set-cursor (make-object cursor%  
'ibeam)))))

       (define (set-suitable-caret)
         (case mode
           ((display) (send this hide-caret #t))
           ((edit) (send this hide-caret #f))))

       (define (set-suitable-selection)
         (case mode
           ((display) (send this flash-off))
           ((edit) (send this flash-on 0 (send this last-position) #f  
0))))

       (define/public display-mode
         (case-lambda
           ([] mode)
           ([mod] (unless (member mod '(display edit))
                    (raise-mismatch-error 'set-mode "expected symbol  
in '(display edit), given " mod))
                  (set! mode mod)
                  (display-update))))

       (define/public (has-display-mode? sym)
         (equal? mode sym))

       (super-new)
       (display-init)))

   ;;; GUI CLASSES
   (define search-field%
     (class* text-field% ()
       (super-new)))

   (define multi-list-box-cell%
     (class* display/edit-text% ()


       (define/augment (after-insert s l)
         (let ((start (send this get-start-position))
               (end (send this get-end-position)))
           (cond ((and (not (send this has-private-lock?))
                       (= start (send this last-position)))
                  (send this private-lock #t)
                  (send this begin-edit-sequence)
                  (send this set-position (send this last-position)  
'same #f #f 'local)
                  (send this insert #\NEWLINE)
                  (send this set-position start end)
                  (send this end-edit-sequence))
                 (else (send this private-lock #f)))))

       (super-new)))

   (define multi-list-box-heading%
     (class* text% ()

       (inherit find-line)

       (define has-focus? #f)

       (define (adjust-display)
         (send this lock #f)
         (if has-focus?
             (send this change-style (make-object style-delta%  
'change-underline #t) 0 'end #f)
             (send this change-style (make-object style-delta%  
'change-underline #f) 0 'end #f))
         (send this lock #t))

       (define/override (on-focus on?)
         (set! has-focus? on?)
         (adjust-display))

       (define/public (set-label lab)
         (send this lock #f)
         (send this begin-edit-sequence)
         (send this change-style (make-object style-delta% 'change- 
bold) 'start 'end #f)
         (send this erase)
         (send this insert lab)
         (send this end-edit-sequence)
         (send this lock #t))

       (super-new)
       (send this lock #t)
       (send this hide-caret #t)))

   (define multi-list-box%
     (class* display/edit-text% ()

       (field (column-count 0))
       (field (column-headings #f))
       (field (column-min-widths #f))
       (field (column-rel-widths #f))


       (define (new-row)
         (send this insert "\n"))

       (define (cursor-to-end)
         (send this set-position (send this last-position)))

       (define (select-line n)
         (let* ((start (send this line-start-position n))
                (end (send this line-end-position n)))
           (send this set-position start end #f #f 'default)))

       ;; returns minimum width of all of the canvases displaying the  
list
       (define (get-display-width)
         (let ((w (box 0)))
           (send this get-view-size w #f)
           (unbox w))) ; CHECK CHANGE (size not correct?)

       ;; compute the current size of column idx based on its  
relative width
       (define (compute-width idx)
         (max
          (- (floor (* (/ (get-display-width) 100) (vector-ref column- 
rel-widths idx)))
             (/ 6 column-count)) ;arbitrary adjustement CHECK CHANGE
          (vector-ref column-min-widths idx)))

       (define (add-cell idx cell)
         (let* ((cell-editor (new multi-list-box-cell%
                                  (parent this)))
                (the-width (compute-width idx))
                (cell-editor-snip (new editor-snip%
                                       (editor cell-editor)
                                       (with-border? #f)
                                       (min-width (compute-width idx))
                                       (max-width (compute-width  
idx)))))
           (send cell-editor insert cell)
           (send this insert cell-editor-snip))
         )

       ;;; adjust the display after listbox has been resized
       ;;; recomputes and sets the widths of each cell
       (define/public (do-resize-adjustments)
         (send this begin-edit-sequence)
         ; (send this get-line-spacing)
         (for-each-cell
          (lambda (row col cell)
            (send cell resize (compute-width col) 26))) ; CHECK  
CHANGE hard-coded height! (how to get the real one??)
         (send this end-edit-sequence))

       (define/augment (on-display-size)
         (do-resize-adjustments))

       ;;; last-row
       ;;; returns the number of the last row
       ;;; the first row starts at 0 and so the
       ;;; value returned is the number of rows - 1
       (define/public (last-row)
         (send this last-line))

       ;;; iterate thunk over all cells in order row, cells
       ;;; thunk is a procedure taking two arguments: row, and cell  
number
       ;;; if changes-visible? is #t, the operation is not wrapped  
into an edit-sequence
       ;;; default is #f
       (define loop-over-cells
         (opt-lambda (thunk [changes-visible? #f])
           (with lines (last-row)
                 (unless changes-visible? (send this begin-edit- 
sequence))
                 (dotimes (row lines)
                          (dotimes (col column-count)
                                   (thunk row col)))
                 (unless changes-visible? (send this end-edit- 
sequence)))))

       ;;; get-cell row col
       ;;; get the cell at row <row> and column <col>
       ;;; returns an instance of class multi-listbox-cell%
       ;;; col and row are 0-indexed
       (define/public (get-cell row col)
         (send this find-snip (+ (send this line-start-position row  
#f) col) 'after #f))

       ;;; for-each-cell
       ;;; apply <proc> to each cell of type multi-listbox-cell%
       ;;; where <proc> is a procedure taking row number, column  
number, and cell as argument
       ;;; doesn't display changes until <proc> has been applied to  
all changes
       ;;; i.e. implicitly wrapped into begin-edit-sequence
       (define/public (for-each-cell thunk)
         (loop-over-cells
          (lambda (row col)
            (thunk row col (get-cell row col)))
          #f))

       ;;; display heading idx
       (define (display-heading idx text)
         (let* ((heading-editor (new multi-list-box-heading%))
                (the-width (compute-width idx))
                (heading-editor-snip (new editor-snip%
                                          (editor heading-editor)
                                          (with-border? #f)
                                          (min-width (compute-width  
idx))
                                          (max-width (compute-width  
idx)))))
           (send heading-editor-snip show-border #f)
           (send heading-editor set-label text)
           (send this insert heading-editor-snip))
         )
       ;;; display the column headings
       (define (display-headings)
         (srfi43-vector-for-each
          (lambda (idx heading) (display-heading idx heading))
          column-headings)
         (new-row))

       ;;; set-columns
       ;;;    <col-headings>: list of n strings
       ;;;    <col-specs>: list of n lists (rel-width min-width)
       (define/public (set-columns col-headings col-specs)
         ;; error checks
         (when (not (= (length col-headings) (length col-specs)))
           (raise-mismatch-error
            'set-columns
            (format "excpected value of type <column-specification>  
as second argument matching ~s, given " col-headings)
            col-specs))
         (let ((crel (list->vector (map car col-specs)))
               (cmin (list->vector (map cadr col-specs))))
           (when (<= (vector-min crel) 0)
             (raise-mismatch-error
              'set-columns
              "expected value of type <column-specification> as  
second argument, but the relative widths contain a value that is 0 or  
smaller, given "
              col-specs))
           (when (> (vector-sum crel) 100)
             (raise-mismatch-error
              'set-columns
              "expected value of type <column-specification> as  
second argument, but the sum of the relative widths given is above  
100 percent, given "
              col-specs))
           (when (< (vector-min cmin) 0)
             (raise-mismatch-error
              'set-columns
              "expected value of type <column-specification> as  
second argument, but one or more mimimum widths are not a positive  
integer, given "
              col-specs))
           ;; mutate
           (set! column-headings (list->vector col-headings))
           (set! column-count (vector-length crel))
           (set! column-rel-widths crel)
           (set! column-min-widths cmin)
           ;; display
           (display-headings)))

       (define/public (add-row row)
         (when (= column-count 0)
           (error 'add-row "the list-box has to be initialized using  
set-columns first"))
         (when (not (= (length row) column-count))
           (raise-mismatch-error
            'add-row
            (format "expected list of ~s strings, but given " column- 
count)
            row))
         (cursor-to-end)
         (srfi43-vector-for-each
          (lambda (idx min-width)
            (add-cell idx (list-ref row idx)))
          column-min-widths)
         (new-row))

       (define/public (on-display-mode-event evt snip)
         (when (eq? (send evt get-event-type) 'left-up)
           (select-line (send this find-line (send evt get-y) #f))))

       (super-new)
       (send this set-selection-callback
             (lambda (editor)
               (display 'selection) (newline)))))

   (define main-frame%
     (class* frame% ()

       (field (main-list #f))
       (field (status-panel #f))
       (field (v-panel #f))

       (define (make-layout)
         (set! v-panel (new vertical-panel% (parent this)))
         (set! status-panel (new horizontal-panel% (parent v-panel)))
         (let* ((status-text (new message%
                                  (label "Sample Header")
                                  (parent status-panel)
                                  (font small-control-font)
                                  (min-height 14)
                                  (min-width 40)
                                  ))

                (right-panel (new horizontal-panel%
                                  (parent status-panel)
                                  (min-width 80)
                                  (stretchable-width #t)
                                  (alignment '(right center))))
                (search-field (new search-field%
                                   (label #f)
                                   (parent right-panel)
                                   (font small-control-font)
                                   (min-width 20)
                                   (stretchable-width #f)
                                   (min-height 14)))
                (cat-choice (new choice%
                                 (label #f)
                                 (choices '("First Choice" "Second  
Choice" "Third Choice"))
                                 (parent right-panel)
                                 (font small-control-font)
                                 (min-width 20)
                                 ))
                (spacer1 (new horizontal-panel% (parent right-panel)  
(min-width 12) (stretchable-width #f) (stretchable-height #f)))
                (main-list-canvas (new editor-canvas%
                                       (parent v-panel)
                                       (horizontal-inset 0)
                                       (vertical-inset 0)))
                )
           (set! main-list (new multi-list-box%))
           (send main-list-canvas set-editor main-list)
           (send status-panel stretchable-height #f)))

       (define/override (on-toolbar-button-click)
         (send v-panel show (not (send v-panel is-shown?)))
         )

       (define/public (test)
         (send main-list begin-edit-sequence)
         (send main-list set-columns '("Column 1" "Column 2" "Column  
3" "Column 4") '((30 120) (30 120) (20 80) (20 80)))
         (repeat-times
          100
          (send main-list add-row `(,(symbol->string (gensym))
                                     ,(symbol->string (gensym))
                                     ,(symbol->string (gensym))
                                     ,(symbol->string (gensym)) )))
         (send main-list on-display-size)
         (send main-list for-each-cell (lambda (row col cell)  
(display (send cell get-text 0 200 #t))(newline)))
         (send main-list end-edit-sequence))


       (super-new
        (label "Untitled")
        (style '(toolbar-button))
        (height 450)
        (width 600))
       (make-layout)
       ))

   (define (get-main-frame)
     (let ((frame (new main-frame%)))
       frame))


   ;;; DEBUGGING
   (define (test)
     (define b (get-main-frame))
     (send b show #t)
     (send b test))
   )