suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

multi-column support in list-box%

Browse Source
This commit is contained in:
Matthew Flatt 2011-02-20 19:36:21 -07:00
parent a01b7434b1
commit 137d96c089
22 changed files with 1300 additions and 217 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/mred/mred-sig.rkt
View File

@ -32,6 +32,7 @@ clipboard<%>
color%
color-database<%>
combo-field%
column-control-event%
control-event%
control<%>
current-eventspace

1
collects/mred/private/mred.rkt
View File

@ -107,6 +107,7 @@
clipboard<%>
clipboard-client%
control-event%
column-control-event%
current-eventspace
cursor%
get-display-depth

204
collects/mred/private/mritem.rkt
View File

@ -1,8 +1,8 @@
(module mritem mzscheme
(module mritem racket/base
(require mzlib/class
mzlib/class100
mzlib/list
(prefix wx: "kernel.ss")
(prefix-in wx: "kernel.ss")
"lock.ss"
"const.ss"
"kw.ss"
@ -16,8 +16,8 @@
"mrcontainer.ss")
(provide control<%>
(protect control%-keywords
basic-control%)
(protect-out control%-keywords
basic-control%)
message%
button%
check-box%
@ -29,13 +29,13 @@
choice%
list-box%
(protect wrap-callback
check-list-control-args
check-list-control-selection
;; Local methods:
hidden-child?
label-checker))
(protect-out wrap-callback
check-list-control-args
check-list-control-selection
;; Local methods:
hidden-child?
label-checker))
(define control<%>
(interface (subwindow<%>)
@ -555,26 +555,138 @@
(define list-box%
(class100*/kw basic-list-control% ()
[(label choices parent [callback (lambda (b e) (void))] [style '(single)] [selection #f] [font no-val] [label-font no-val])
control%-nofont-keywords]
control%-nofont-keywords
[columns (list "Column")]
[column-order #f]]
(sequence
(let ([cwho '(constructor list-box)])
(check-list-control-args cwho label choices parent callback)
(check-style cwho '(single multiple extended) '(vertical-label horizontal-label deleted) style)
(check-style cwho '(single multiple extended)
'(vertical-label horizontal-label deleted variable-columns
column-headers clickable-headers reorderable-headers)
style)
(check-non-negative-integer/false cwho selection)
(check-font cwho font)
(check-font cwho label-font)))
(check-font cwho label-font)
(unless (and (list? columns)
(not (null? columns))
(andmap label-string? columns))
(raise-type-error (who->name cwho) "non-empty list of strings (up to 200 characters)" columns))
(when column-order
(check-column-order cwho column-order (length columns)))))
(private
[check-column-order
(lambda (cwho column-order count)
(unless (and (list? column-order)
(andmap exact-integer? column-order)
(equal? (sort column-order <)
(for/list ([i (in-range (length column-order))]) i)))
(raise-type-error (who->name cwho)
"#f or list of distinct exact integers from 0 to one less than the list length"
column-order))
(unless (= (length column-order) count)
(raise-mismatch-error (who->name cwho)
(format "column count ~a does not match length of column-order list: "
count)
column-order)))]
[check-column-number
(lambda (who i)
(unless (exact-nonnegative-integer? i)
(raise-type-error (who->name who) "exact nonnegative integer" i))
(unless (i . < . num-columns)
(raise-mismatch-error (who->name who)
(format
"index is too large for ~a-column list box: "
num-columns)
i)))])
(private-field
[column-labels (map string->immutable-string columns)]
[num-columns (length columns)]
[variable-columns? (memq 'variable-columns style)])
(rename [super-append append])
(override
[append (entry-point
(case-lambda
[(i)
(super-append i)]
[(i d)
(check-label-string '(method list-control<%> append) i)
(send this -append-list-string i)
(send wx append i d)]))])
[(-append append)
(entry-point
(case-lambda
[(i)
(super-append i)]
[(i d)
(check-label-string '(method list-control<%> append) i)
(send this -append-list-string i)
(send wx append i d)]))])
(public
[delete (entry-point (lambda (n)
[get-column-labels (lambda () column-labels)]
[get-column-order (lambda () (send wx get-column-order))]
[set-column-order (lambda (co)
(check-column-order '(method list-box% set-column-order) co num-columns)
(send wx set-column-order co))]
[set-column-label (lambda (i str)
(let ([who '(method list-box% set-column-label)])
(check-column-number who i)
(check-label-string who str))
(let ([str (string->immutable-string str)])
(set! column-labels (let loop ([i i] [l column-labels])
(cond
[(zero? i) (cons str (cdr l))]
[else (cons (car l) (loop (sub1 i) (cdr l)))])))
(send wx set-column-label i str)))]
[set-column-size (lambda (i w min-size max-size)
(let ([who '(method list-box% set-column-size)])
(check-column-number who i)
(check-dimension who w)
(check-dimension who min-size)
(check-dimension who max-size)
(unless (<= min-size w)
(raise-mismatch-error (who->name who)
(format
"size ~a is less than mininum size: "
w)
min-size))
(unless (>= max-size w)
(raise-mismatch-error (who->name who)
(format
"size ~a is less than maximum size: "
w)
max-size)))
(send wx set-column-size i w min-size max-size))]
[get-column-size (lambda (i)
(check-column-number '(method list-box% get-column-size) i)
(send wx get-column-size i))]
[delete-column (lambda (i)
(let ([who '(method list-box% delete-column)])
(check-column-number who i)
(unless variable-columns?
(raise-mismatch-error
(who->name who)
"list box without 'variable-columns style cannot delete column: "
i))
(unless (num-columns . > . 1)
(raise-mismatch-error (who->name who)
"cannot delete only column: "
i)))
(as-entry
(lambda ()
(set! num-columns (sub1 num-columns))
(set! column-labels (let loop ([i i] [l column-labels])
(cond
[(zero? i) (cdr l)]
[else (cons (car l) (loop (sub1 i) (cdr l)))])))
(send wx delete-column i))))]
[append-column (lambda (label)
(let ([who '(method list-box% append-column)])
(check-label-string who label)
(unless variable-columns?
(raise-mismatch-error
(who->name who)
"list box without 'variable-columns style cannot add column: "
label)))
(as-entry
(lambda ()
(set! num-columns (add1 num-columns))
(set! column-labels (append column-labels (list label)))
(send wx append-column label))))]
[delete (entry-point (lambda (n)
(check-item 'delete n)
(send this -delete-list-item n)
(send wx delete n)))]
@ -583,19 +695,43 @@
[get-selections (entry-point (lambda () (send wx get-selections)))]
[number-of-visible-items (entry-point (lambda () (send wx number-of-visible-items)))]
[is-selected? (entry-point (lambda (n) (check-item 'is-selected? n) (send wx selected? n)))]
[set (entry-point (lambda (l)
(unless (and (list? l) (andmap label-string? l))
(raise-type-error (who->name '(method list-box% set))
"list of strings (up to 200 characters)" l))
[set (entry-point (lambda (l . more)
(let ([cwho '(method list-box% set)])
(unless (= num-columns (+ 1 (length more)))
(raise-mismatch-error (who->name cwho)
(format
"column count ~a doesn't match number of arguments: "
num-columns)
(add1 (length more))))
(for ([l (in-list (cons l more))])
(unless (and (list? l) (andmap label-string? l))
(raise-type-error (who->name cwho)
"list of strings (up to 200 characters)" l)))
(for ([more-l (in-list more)])
(unless (= (length more-l) (length l))
(raise-mismatch-error
(who->name cwho)
(format "first list length ~a does not match length of later argument: "
(length l))
more-l))))
(send this -set-list-strings l)
(send wx set l)))]
(send wx set l . more)))]
[set-string (entry-point
(lambda (n d)
(check-non-negative-integer '(method list-box% set-string) n) ; int error before string
(check-label-string '(method list-box% set-string) d) ; string error before range mismatch
(lambda (n d [col 0])
(let ([cwho '(method list-box% set-string)])
(check-non-negative-integer cwho n) ; int error before string
(check-label-string cwho d) ; string error before range mismatch
(unless (exact-nonnegative-integer? col)
(raise-type-error (who->name cwho) "exact nonnegative integer" col))
(unless (< -1 col num-columns)
(raise-mismatch-error (who->name cwho)
(format
"column number is not in the list box's allowed range [0, ~a]: "
(sub1 num-columns))
col)))
(check-item 'set-string n)
(send this -set-list-string n d)
(send wx set-string n d)))]
(send wx set-string n d col)))]
[set-data (entry-point (lambda (n d) (check-item 'set-data n) (send wx set-data n d)))]
[get-first-visible-item (entry-point (lambda () (send wx get-first-item)))]
[set-first-visible-item (entry-point (lambda (n)
@ -631,7 +767,9 @@
(mred->wx-container parent) (wrap-callback callback)
label kind
-1 -1 -1 -1 choices style
(no-val->#f font) (no-val->#f label-font))))
(no-val->#f font) (no-val->#f label-font)
column-labels
column-order)))
wx)
(lambda ()
(let ([cwho '(constructor list-box)])

207
collects/mred/private/wx/cocoa/list-box.rkt
View File

@ -28,7 +28,7 @@
(let ([wx (->wx wxb)])
(tell
(let ([c (tell (tell NSCell alloc) initTextCell: #:type _NSString
(if wx (send wx get-row row) "???"))]
(if wx (send wx get-cell column row) "???"))]
[font (and wx (send wx get-cell-font))])
(when font
(tellv c setFont: font))
@ -37,7 +37,12 @@
[-a _void (doubleClicked: [_id sender])
(queue-window*-event wxb (lambda (wx) (send wx clicked 'list-box-dclick)))]
[-a _void (tableViewSelectionDidChange: [_id aNotification])
(queue-window*-event wxb (lambda (wx) (send wx clicked 'list-box)))])
(queue-window*-event wxb (lambda (wx) (send wx clicked 'list-box)))]
[-a _void (tableView: [_id view] didClickTableColumn: [_id col])
(queue-window*-event wxb (lambda (wx) (send wx clicked-column col)))]
[-a _void (tableViewColumnDidMove: [_id view])
(let ([wx (->wx wxb)])
(when wx (send wx reset-column-order)))])
(define-objc-class MyDataSource NSObject
#:protocols (NSTableViewDataSource)
@ -50,7 +55,7 @@
row: [_NSInteger rowIndex])
(let ([wx (->wx wxb)])
(if wx
(send wx get-row rowIndex)
(send wx get-cell aTableColumn rowIndex)
"???"))])
(define (remove-nth data i)
@ -62,7 +67,8 @@
(init parent cb
label kind x y w h
choices style
font label-font)
font label-font
columns column-order)
(inherit set-size init-font
register-as-child)
@ -70,30 +76,74 @@
(tell (tell MyDataSource alloc) init)))
(set-ivar! source wxb (->wxb this))
(define items choices)
(define itemss (cons choices
(for/list ([i (in-list (cdr columns))])
(for/list ([i choices])
""))))
(define num-columns (length columns))
(define data (map (lambda (x) (box #f)) choices))
(define count (length choices))
(define cocoa (as-objc-allocation
(tell (tell NSScrollView alloc) init)))
(define content-cocoa (let ([content-cocoa
(as-objc-allocation
(tell (tell MyTableView alloc) init))])
(tellv content-cocoa setDelegate: content-cocoa)
(tellv content-cocoa setDataSource: source)
(tellv content-cocoa addTableColumn:
(as-objc-allocation
(tell (tell NSTableColumn alloc) initWithIdentifier: content-cocoa)))
(init-font content-cocoa font)
content-cocoa))
(define-values (content-cocoa column-cocoas)
(let ([content-cocoa
(as-objc-allocation
(tell (tell MyTableView alloc) init))])
(tellv content-cocoa setDelegate: content-cocoa)
(tellv content-cocoa setDataSource: source)
(define cols
(for/list ([title (in-list columns)])
(let ([col (as-objc-allocation
(tell (tell NSTableColumn alloc) initWithIdentifier: content-cocoa))])
(tellv content-cocoa addTableColumn: col)
(tellv (tell col headerCell) setStringValue: #:type _NSString title)
col)))
(init-font content-cocoa font)
(values content-cocoa cols)))
(set-ivar! content-cocoa wxb (->wxb this))
(tellv cocoa setDocumentView: content-cocoa)
(tellv cocoa setHasVerticalScroller: #:type _BOOL #t)
(tellv content-cocoa setHeaderView: #f)
(unless (memq 'column-headers style)
(tellv content-cocoa setHeaderView: #f))
(define allow-multi? (not (eq? kind 'single)))
(when allow-multi?
(tellv content-cocoa setAllowsMultipleSelection: #:type _BOOL #t))
(unless (memq 'reorderable-headers style)
(tellv content-cocoa setAllowsColumnReordering: #:type _BOOL #f))
(when column-order
(set-column-order column-order))
(define/public (set-column-order column-order)
(atomically
(for ([c (in-list column-cocoas)])
(tellv c retain)
(tellv content-cocoa removeTableColumn: c))
(for ([pos (in-list column-order)])
(let ([c (list-ref column-cocoas pos)])
(tellv content-cocoa addTableColumn: c)
(tellv c release)))
(reset-column-order)))
(define/public (set-column-label i s)
(let ([col (list-ref column-cocoas i)])
(tellv (tell col headerCell) setStringValue: #:type _NSString s)
(reset)))
(define/public (set-column-size i w min-w max-w)
(let ([col (list-ref column-cocoas i)])
(tellv col setMinWidth: #:type _CGFloat min-w)
(tellv col setMaxWidth: #:type _CGFloat max-w)
(tellv col setWidth: #:type _CGFloat w)))
(define/public (get-column-size i)
(let ([col (list-ref column-cocoas i)]
[int (lambda (v) (inexact->exact (round v)))])
(values
(int (tell #:type _CGFloat col width))
(int (tell #:type _CGFloat col minWidth))
(int (tell #:type _CGFloat col maxWidth)))))
(define/override (get-cocoa-content) content-cocoa)
(define/override (get-cocoa-control) content-cocoa)
@ -145,19 +195,87 @@
;; FIXME: visble doesn't mean at top:
(tellv content-cocoa scrollRowToVisible: #:type _NSInteger i))
(define/public (set-string i s)
(set! items
(append (take items i)
(list s)
(drop items (add1 i))))
(define/private (replace items i s)
(append (take items i)
(list s)
(drop items (add1 i))))
(define/public (set-string i s [col 0])
(let ([new-itemss (replace
itemss
col
(replace (list-ref itemss col)
i
s))])
(set! itemss new-itemss))
(reset))
(define/public (number)
;; Can be called by event-handling thread
count)
(define/public (get-row n)
(define/public (get-cell col n)
;; Can be called by event-handling thread
(list-ref items n))
(let ([col (if (number? col)
(order->number col)
(col->number col))])
(if (col . > . num-columns) ; can happen as column is deleted
""
(list-ref (list-ref itemss col) n))))
(define/private (col->number col)
(let loop ([l column-cocoas] [pos 0])
(cond
[(null? l) #f]
[(ptr-equal? (car l) col) pos]
[else (loop (cdr l) (add1 pos))])))
;; When columns are rearranged, we have to be able to map
;; from current column numbers to original column numbers
(define order-vector #f)
(define/private (order->number col)
(prep-order-vector)
(vector-ref order-vector col))
(define/private (prep-order-vector)
(unless order-vector
(let ([vec (make-vector (length column-cocoas))])
(let ([array (tell content-cocoa tableColumns)])
(for/list ([i (in-range (tell #:type _NSUInteger array count))])
(let ([col (tell array objectAtIndex: #:type _NSUInteger i)])
(vector-set! vec i (col->number col)))))
(set! order-vector vec))))
(define/public (reset-column-order)
(set! order-vector #f))
(define/public (get-column-order)
(prep-order-vector)
(vector->list order-vector))
(define/public (append-column title)
(atomically
(let ([col (as-objc-allocation
(tell (tell NSTableColumn alloc) initWithIdentifier: content-cocoa))])
(tellv content-cocoa addTableColumn: col)
(tellv (tell col headerCell) setStringValue: #:type _NSString title)
(set! column-cocoas (append column-cocoas (list col)))
(set! itemss (append itemss
(list (for/list ([i (in-list (car itemss))])
""))))
(set! num-columns (add1 num-columns))
(reset-column-order)))
(reset))
(define/public (delete-column i)
(atomically
(let ([c (list-ref column-cocoas i)])
(define (drop-nth l i)
(cond
[(zero? i) (cdr l)]
[else (cons (car l) (drop-nth (cdr l) (sub1 i)))]))
(set! num-columns (sub1 num-columns))
(tellv content-cocoa removeTableColumn: c)
(set! column-cocoas (drop-nth column-cocoas i))
(set! itemss (drop-nth itemss i))))
(reset))
(define callback cb)
(define/public (clicked event-type)
@ -166,6 +284,15 @@
[event-type event-type]
[time-stamp (current-milliseconds)]))))
(define can-click-column? (memq 'clickable-headers style))
(define/public (clicked-column col)
(when can-click-column?
(let ([pos (col->number col)])
(callback this (new column-control-event%
[event-type 'list-box-column]
[time-stamp (current-milliseconds)]
[column pos])))))
(define/public (set-data i v) (set-box! (list-ref data i) v))
(define/public (get-data i) (unbox (list-ref data i)))
@ -185,26 +312,34 @@
(select i #t #f))
(define/public (delete i)
(set! count (sub1 count))
(set! items (remove-nth items i))
(set! data (remove-nth data i))
(atomically
(set! count (sub1 count))
(set! itemss (for/list ([items (in-list itemss)])
(remove-nth items i)))
(set! data (remove-nth data i)))
(reset))
(define/public (clear)
(set! count 0)
(set! items null)
(set! data null)
(atomically
(set! count 0)
(set! itemss (for/list ([items (in-list itemss)])
null))
(set! data null))
(reset))
(define/public (set choices)
(set! items choices)
(set! data (map (lambda (x) (box #f)) choices))
(set! count (length choices))
(define/public (set choices . more-choices)
(atomically
(set! itemss (cons choices more-choices))
(set! data (map (lambda (x) (box #f)) choices))
(set! count (length choices)))
(reset))
(public [append* append])
(define (append* s [v #f])
(set! count (add1 count))
(set! items (append items (list s)))
(set! data (append data (list (box v))))
(atomically
(set! count (add1 count))
(set! itemss (cons (append (car itemss) (list s))
(for/list ([items (in-list (cdr itemss))])
(append items (list "")))))
(set! data (append data (list (box v)))))
(reset))
(define/public (reset)

14
collects/mred/private/wx/common/event.rkt
View File

@ -6,6 +6,7 @@
mouse-event%
key-event%
control-event%
column-control-event%
scroll-event%
popup-event%)
@ -90,13 +91,24 @@
(defclass control-event% event%
(init-properties [[(symbol-in button check-box choice
list-box list-box-dclick text-field
list-box list-box-dclick list-box-column text-field
text-field-enter slider radio-box
menu-popdown menu-popdown-none tab-panel)
event-type]])
(init [time-stamp 0])
(super-new [time-stamp time-stamp]))
(defclass column-control-event% control-event%
(init-properties [[exact-nonnegative-integer? column]])
(init event-type
[time-stamp 0])
(unless (eq? event-type 'list-box-column)
(raise-type-error (init-name 'column-control-event%)
"'list-box-column"
event-type))
(super-new [event-type event-type]
[time-stamp time-stamp]))
(defclass popup-event% control-event%
(properties [[any? menu-id] 0])
(super-new))

244
collects/mred/private/wx/gtk/list-box.rkt
View File

@ -29,23 +29,42 @@
(define GTK_SELECTION_SINGLE 1)
(define GTK_SELECTION_MULTIPLE 3)
(define GTK_TREE_VIEW_COLUMN_AUTOSIZE 1)
(define GTK_TREE_VIEW_COLUMN_FIXED 2)
(define-gtk gtk_scrolled_window_new (_fun _pointer _pointer -> _GtkWidget))
(define-gtk gtk_scrolled_window_set_policy (_fun _GtkWidget _int _int -> _void))
(define-gtk gtk_list_store_new (_fun _int _int -> _GtkListStore))
(define-gtk gtk_list_store_newv (_fun _int (_list i _long) -> _GtkListStore))
(define-gtk gtk_list_store_clear (_fun _GtkListStore -> _void))
(define-gtk gtk_list_store_append (_fun _GtkListStore _GtkTreeIter-pointer _pointer -> _void))
(define-gtk gtk_list_store_set (_fun _GtkListStore _GtkTreeIter-pointer _int _string _int -> _void))
(define-gtk gtk_tree_view_new_with_model (_fun _GtkListStore -> _GtkWidget))
(define-gtk gtk_tree_view_set_model (_fun _GtkWidget _GtkListStore -> _void))
(define-gtk gtk_tree_view_set_headers_visible (_fun _GtkWidget _gboolean -> _void))
(define-gtk gtk_cell_renderer_text_new (_fun -> _GtkCellRenderer))
(define-gtk gtk_tree_view_column_new_with_attributes (_fun _string _GtkCellRenderer _string _int _pointer -> _GtkTreeViewColumn))
(define-gtk gtk_tree_view_column_set_attributes (_fun _GtkTreeViewColumn _GtkCellRenderer _string _int _pointer -> _void))
(define-gtk gtk_tree_view_column_set_resizable (_fun _GtkTreeViewColumn _gboolean -> _void))
(define-gtk gtk_tree_view_column_set_clickable (_fun _GtkTreeViewColumn _gboolean -> _void))
(define-gtk gtk_tree_view_column_set_reorderable (_fun _GtkTreeViewColumn _gboolean -> _void))
(define-gtk gtk_tree_view_append_column (_fun _GtkWidget _GtkTreeViewColumn -> _void))
(define-gtk gtk_tree_view_remove_column (_fun _GtkWidget _GtkTreeViewColumn -> _void))
(define-gtk gtk_tree_view_get_selection (_fun _GtkWidget -> _GtkWidget))
(define-gtk gtk_tree_selection_set_mode (_fun _GtkWidget _int -> _void))
(define-gtk gtk_list_store_remove (_fun _GtkListStore _GtkTreeIter-pointer -> _gboolean))
(define-gtk gtk_tree_model_get_iter (_fun _GtkListStore _GtkTreeIter-pointer _pointer -> _gboolean))
(define-gtk gtk_tree_view_scroll_to_cell (_fun _GtkWidget _pointer _pointer _gboolean _gfloat _gfloat -> _void))
(define-gtk gtk_tree_view_get_column (_fun _GtkWidget _int -> _GtkTreeViewColumn))
(define-gtk gtk_tree_view_move_column_after (_fun _GtkWidget _GtkTreeViewColumn (_or-null _GtkTreeViewColumn) -> _void))
(define-gtk gtk_tree_view_column_set_title (_fun _GtkTreeViewColumn _string -> _void))
(define-gtk gtk_tree_view_column_set_sizing (_fun _GtkTreeViewColumn _int -> _void))
(define-gtk gtk_tree_view_column_get_width (_fun _GtkTreeViewColumn -> _int))
(define-gtk gtk_tree_view_column_get_min_width (_fun _GtkTreeViewColumn -> _int))
(define-gtk gtk_tree_view_column_get_max_width (_fun _GtkTreeViewColumn -> _int))
(define-gtk gtk_tree_view_column_set_fixed_width (_fun _GtkTreeViewColumn _int -> _int))
(define-gtk gtk_tree_view_column_set_min_width (_fun _GtkTreeViewColumn _int -> _int))
(define-gtk gtk_tree_view_column_set_max_width (_fun _GtkTreeViewColumn _int -> _int))
(define _GList (_cpointer 'List))
(define-glib g_list_foreach (_fun _GList (_fun _pointer -> _void) _pointer -> _void))
@ -70,6 +89,13 @@
(when wx
(send wx queue-changed)))))
(define-signal-handler connect-clicked "clicked"
(_fun _GtkWidget -> _void)
(lambda (gtk)
(let ([wx (gtk->wx gtk)])
(when wx
(send wx column-clicked gtk)))))
(define-signal-handler connect-activated "row-activated"
(_fun _GtkWidget _pointer _pointer -> _void)
(lambda (gtk path column)
@ -81,18 +107,33 @@
(init parent cb
label kind x y w h
choices style
font label-font)
font label-font
columns
column-order)
(inherit get-gtk set-auto-size is-window-enabled?)
(define items choices)
(define empty-columns (for/list ([l (in-list (cdr columns))])
""))
(define itemss (for/list ([i (in-list choices)])
(cons i empty-columns)))
(define data (map (lambda (c) (box #f)) choices))
(define store (as-gobject-allocation (gtk_list_store_new 1 G_TYPE_STRING)))
(define (make-store count)
(as-gobject-allocation
(gtk_list_store_newv count
(for/list ([i (in-range count)])
G_TYPE_STRING))))
(define store (make-store (length columns)))
(define (reset-content)
(let ([iter (make-GtkTreeIter 0 #f #f #f)])
(for ([s (in-list items)])
(for ([items (in-list itemss)])
(gtk_list_store_append store iter #f)
(gtk_list_store_set store iter 0 s -1)))
(for ([item (in-list items)]
[col (in-naturals 0)])
(gtk_list_store_set store iter col item -1))))
(maybe-init-select))
(define/private (maybe-init-select)
@ -103,20 +144,51 @@
(define gtk (as-gtk-allocation (gtk_scrolled_window_new #f #f)))
(gtk_scrolled_window_set_policy gtk GTK_POLICY_NEVER GTK_POLICY_ALWAYS)
(define client-gtk
(define headers? (memq 'column-headers style))
(define click-headers? (and headers?
(memq 'clickable-headers style)))
(define reorder-headers? (and headers?
(memq 'reorderable-headers style)))
(define renderer (gtk_cell_renderer_text_new))
(define/private (make-column label col)
(let* ([column
(gtk_tree_view_column_new_with_attributes
label
renderer
"text"
col
#f)])
(when headers?
(gtk_tree_view_column_set_resizable column #t)
(when click-headers?
(gtk_tree_view_column_set_clickable column #t))
(when reorder-headers?
(gtk_tree_view_column_set_reorderable column #t)))
column))
(define-values (client-gtk column-gtks)
(atomically
(let* ([client-gtk (gtk_tree_view_new_with_model store)]
[column (let ([renderer (gtk_cell_renderer_text_new)])
(gtk_tree_view_column_new_with_attributes
"column"
renderer
"text"
0
#f))])
[columns (for/list ([label (in-list columns)]
[col (in-naturals)])
(make-column label col))])
(gobject-unref store)
(gtk_tree_view_set_headers_visible client-gtk #f)
(gtk_tree_view_append_column client-gtk column)
client-gtk)))
(unless headers?
(gtk_tree_view_set_headers_visible client-gtk #f))
(for ([column (in-list columns)])
(gtk_tree_view_append_column client-gtk column))
(values client-gtk columns))))
(when column-order
(set-column-order column-order))
(define/public (set-column-order column-order)
(let loop ([prev #f] [l column-order])
(unless (null? l)
(let ([column-gtk (list-ref column-gtks (car l))])
(gtk_tree_view_move_column_after client-gtk column-gtk prev)
(loop column-gtk (cdr l))))))
(gtk_container_add gtk client-gtk)
(gtk_widget_show client-gtk)
@ -131,7 +203,10 @@
(super-new [parent parent]
[gtk gtk]
[extra-gtks (list client-gtk selection)]
[extra-gtks (list* client-gtk selection
(if (memq 'clickable-headers style)
column-gtks
null))]
[callback cb]
[font font]
[no-show? (memq 'deleted style)])
@ -140,6 +215,14 @@
(connect-changed selection)
(connect-activated client-gtk)
(for ([column (in-list column-gtks)])
(column-finish column))
(define/private (column-finish column)
(connect-clicked column)
(let ([w (gtk_tree_view_column_get_width column)])
(gtk_tree_view_column_set_sizing column GTK_TREE_VIEW_COLUMN_FIXED)
(gtk_tree_view_column_set_fixed_width column (max 50 w))))
(define/override (get-client-gtk) client-gtk)
@ -151,7 +234,7 @@
(queue-window-event
this
(lambda ()
(unless (null? items)
(unless (null? itemss)
(callback this (new control-event%
[event-type type]
[time-stamp (current-milliseconds)])))))))
@ -162,6 +245,29 @@
(define/public (queue-activated)
(do-queue-changed 'list-box-dclick))
(define/private (column->pos col)
(let loop ([l column-gtks]
[pos 0])
(cond
[(null? l) #f]
[(ptr-equal? (car l) col) pos]
[else (loop (cdr l) (add1 pos))])))
(define/public (column-clicked col)
(let ([pos (column->pos col)])
(when pos
(queue-window-event
this
(lambda ()
(callback this (new column-control-event%
[event-type 'list-box-column]
[column pos]
[time-stamp (current-milliseconds)])))))))
(define/public (get-column-order)
(for/list ([i (in-range (length column-gtks))])
(column->pos (gtk_tree_view_get_column client-gtk i))))
(define/private (get-iter i)
(atomically
(let ([iter (make-GtkTreeIter 0 #f #f #f)]
@ -172,12 +278,38 @@
(def/public-unimplemented get-label-font)
(define/public (set-string i s)
(set! items
(append (take items i)
(list s)
(drop items (add1 i))))
(gtk_list_store_set store (get-iter i) 0 s -1))
(define/private (replace-nth items i s)
(append (take items i)
(list s)
(drop items (add1 i))))
(define/public (set-string i s [col 0])
(set! itemss
(replace-nth itemss
i
(replace-nth (list-ref itemss i)
col
s)))
(gtk_list_store_set store (get-iter i) col s -1))
(define/public (set-column-label i s)
(gtk_tree_view_column_set_title (list-ref column-gtks i) s))
(define/public (set-column-size i w mn mx)
(let ([col (list-ref column-gtks i)])
(gtk_tree_view_column_set_min_width col mn)
(gtk_tree_view_column_set_max_width col mx)
(gtk_tree_view_column_set_fixed_width col w)))
(define/public (get-column-size i)
(let ([col (list-ref column-gtks i)])
(values
(gtk_tree_view_column_get_width col)
(max (gtk_tree_view_column_get_min_width col) 0)
(let ([v (gtk_tree_view_column_get_max_width col)])
(if (negative? v)
10000
v)))))
(define/public (set-first-visible-item i)
(atomically
@ -185,11 +317,15 @@
(gtk_tree_view_scroll_to_cell client-gtk p #f #t 0.0 0.0)
(gtk_tree_path_free p))))
(define/public (set choices)
(define/public (set choices . more-choices)
(atomically
(set! ignore-click? #t)
(clear)
(set! items choices)
(set! itemss (apply map
(lambda (i . rest)
(cons i rest))
choices
more-choices))
(set! data (map (lambda (x) (box #f)) choices))
(reset-content)
(set! ignore-click? #f)))
@ -230,7 +366,7 @@
(let-values ([(start end) (get-visible-range)])
(add1 (- end start))))
(define/public (number) (length items))
(define/public (number) (length itemss))
(define/public (set-data i v) (set-box! (list-ref data i) v))
(define/public (get-data i) (unbox (list-ref data i)))
@ -259,13 +395,13 @@
(select i #t #f))
(define/public (delete i)
(set! items (append (take items i) (drop items (add1 i))))
(set! itemss (append (take itemss i) (drop itemss (add1 i))))
(set! data (append (take data i) (drop data (add1 i))))
(gtk_list_store_remove store (get-iter i))
(void))
(define/public (clear)
(set! items null)
(set! itemss null)
(set! data null)
(gtk_list_store_clear store))
@ -273,7 +409,8 @@
(define (append* s [v #f])
(atomically
(set! ignore-click? #t)
(set! items (append items (list s)))
(set! itemss (append itemss
(list (cons s empty-columns))))
(set! data (append data (list (box v))))
(let ([iter (make-GtkTreeIter 0 #f #f #f)])
(gtk_list_store_append store iter #f)
@ -281,4 +418,49 @@
(maybe-init-select)
(set! ignore-click? #f)))
(define/public (append-column label)
(let ([col (add1 (length empty-columns))])
(set! store (make-store (add1 col)))
(set! empty-columns (cons "" empty-columns))
(set! itemss
(for/list ([items (in-list itemss)])
(append items (list ""))))
(gtk_tree_view_set_model client-gtk store)
(let ([renderer (gtk_cell_renderer_text_new)])
(gtk_tree_view_column_new_with_attributes
label
renderer
"text"
col
#f))
(let ([column-gtk (make-column label col)])
(g_object_set_data column-gtk "wx" (g_object_get_data client-gtk "wx"))
(set! column-gtks (append column-gtks (list column-gtk)))
(gtk_tree_view_append_column client-gtk column-gtk)
(reset-content)
(column-finish column-gtk))))
(define/public (delete-column i)
(define (remove-nth l i)
(cond
[(zero? i) (cdr l)]
[else (cons (car l) (remove-nth (cdr l) (sub1 i)))]))
(set! empty-columns (cdr empty-columns))
(set! itemss
(for/list ([items (in-list itemss)])
(remove-nth items i)))
(let ([old (list-ref column-gtks i)])
(set! column-gtks (remove-nth column-gtks i))
(gtk_tree_view_remove_column client-gtk old))
(for ([column-gtk (in-list column-gtks)]
[pos (in-naturals)])
(when (pos . >= . i)
(gtk_tree_view_column_set_attributes column-gtk
renderer
"text"
pos
#f)))
(gtk_list_store_clear store)
(reset-content))
(atomically (reset-content)))

2
collects/mred/private/wx/win32/button.rkt
View File

@ -157,7 +157,7 @@
(define/override (is-command? cmd)
(= cmd BN_CLICKED))
(define/public (do-command cmd control-hwnd)
(define/override (do-command cmd control-hwnd)
(queue-window-event this (lambda ()
(callback this
(new control-event%

2
collects/mred/private/wx/win32/canvas.rkt
View File

@ -495,7 +495,7 @@
(or (= cmd CBN_SELENDOK)
(= cmd CBN_DROPDOWN)))
(define/public (do-command cmd control-hwnd)
(define/override (do-command cmd control-hwnd)
(cond
[(= cmd CBN_SELENDOK)
(let ([i (SendMessageW combo-hwnd CB_GETCURSEL 0 0)])

2
collects/mred/private/wx/win32/choice.rkt
View File

@ -81,7 +81,7 @@
(set! choice-dropped? #f))))
(= cmd CBN_SELENDOK))
(define/public (do-command cmd control-hwnd)
(define/override (do-command cmd control-hwnd)
(queue-window-event this (lambda ()
(callback this
(new control-event%

467
collects/mred/private/wx/win32/list-box.rkt
View File

@ -46,38 +46,219 @@
(define LB_GETSEL #x0187)
(define LB_SELITEMRANGE #x019B)
(define LVCF_WIDTH #x0002)
(define LVCF_TEXT #x0004)
(define LVCF_MINWIDTH #x0040)
(define LVS_REPORT #x0001)
(define LVS_SINGLESEL #x0004)
(define LVS_NOCOLUMNHEADER #x4000)
(define LVS_SHOWSELALWAYS #x0008)
(define LVS_EX_HEADERDRAGDROP #x00000010)
(define LVS_EX_FULLROWSELECT #x00000020)
(define LVIF_TEXT #x0001)
(define LVIF_DI_SETITEM #x1000)
(define LVM_FIRST #x1000)
(define LVM_INSERTITEMW (+ LVM_FIRST 77))
(define LVM_GETSTRINGWIDTHW (+ LVM_FIRST 87))
(define LVM_INSERTCOLUMNW (+ LVM_FIRST 97))
(define LVM_DELETECOLUMN (+ LVM_FIRST 28))
(define LVM_SETCOLUMNW (+ LVM_FIRST 96))
(define LVM_GETCOLUMNW (+ LVM_FIRST 95))
(define LVM_SETITEMTEXTW (+ LVM_FIRST 116))
(define LVM_DELETEALLITEMS (+ LVM_FIRST 9))
(define LVM_GETTOPINDEX (+ LVM_FIRST 39))
(define LVM_GETCOUNTPERPAGE (+ LVM_FIRST 40))
(define LVM_ENSUREVISIBLE (+ LVM_FIRST 19))
(define LVM_DELETEITEM (+ LVM_FIRST 8))
(define LVM_GETSELECTEDCOUNT (+ LVM_FIRST 50))
(define LVM_GETNEXTITEM (+ LVM_FIRST 12))
(define LVM_GETITEMSTATE (+ LVM_FIRST 44))
(define LVM_SETITEMSTATE (+ LVM_FIRST 43))
(define LVM_SETEXTENDEDLISTVIEWSTYLE (+ LVM_FIRST 54))
(define LVM_SETCOLUMNORDERARRAY (+ LVM_FIRST 58))
(define LVM_GETCOLUMNORDERARRAY (+ LVM_FIRST 59))
(define LVN_FIRST -100)
(define LVN_ITEMCHANGED (- LVN_FIRST 1))
(define LVN_COLUMNCLICK (- LVN_FIRST 8))
(define NM_FIRST 0)
(define NM_DBLCLK (- NM_FIRST 3))
(define LVNI_SELECTED #x0002)
(define LVIS_SELECTED #x0002)
(define-cstruct _LVCOLUMN
([mask _UINT]
[fmt _int]
[cx _int]
[pszText _permanent-string/utf-16]
[cchTextMax _int]
[iSubItem _int]
[iImage _int]
[iOrder _int]
[cxMin _int]
[cxDefault _int]
[cxIdeal _int]))
(define (make-lvcolumn flags label)
(make-LVCOLUMN flags
0 0
label
0 0 0 0 0 0 0))
(define (free-lvcolumn lv)
(let ([s (LVCOLUMN-pszText lv)])
(when s (free s))))
(define column-desc (cast (malloc (ctype-sizeof _LVCOLUMN) 'raw)
_pointer
_LVCOLUMN-pointer))
(memset column-desc 0 (ctype-sizeof _LVCOLUMN))
;; Microsoft docs say to add padding to a ListView
;; item's width, but it doesn't say how much padding:
(define COLUMN-PADDING 16)
(define-cstruct _LVITEM
([mask _UINT]
[iItem _int]
[iSubItem _int]
[state _UINT]
[stateMask _UINT]
[pszText _permanent-string/utf-16]
[cchTextMax _int]
[iImage _int]
[lParam _LPARAM]
[iIndent _int]
[iGroupId _int]
[cColumns _UINT]
[puColumns _UINT]
[piColFmt _int]
[iGroup _int]))
(define (make-lvitem flags pos col label)
(make-LVITEM flags
pos col
0 0 ; state & statemask
label
0 0
0 ; lParam
0 0 0
0 0 0))
(define (free-lvitem lv)
(let ([s (LVITEM-pszText lv)])
(when s (free s))))
(define-cstruct _NMLISTVIEW
([hdr _NMHDR]
[iItem _int]
[iSubItem _int]
;; ....
))
;; ------------------------------------------------------------
(define list-box%
(class item%
(init parent cb
label kind x y w h
choices style
font label-font)
font label-font
columns column-order)
(inherit set-size set-control-font
get-client-size)
(define num-columns (length columns))
(define single-column? (and (= 1 num-columns)
(not (memq 'column-headers style))
(not (memq 'variable-columns style))))
(define single? (eq? 'single kind))
(define hwnd
(CreateWindowExW/control WS_EX_CLIENTEDGE
"PLTLISTBOX"
(if single-column?
"PLTLISTBOX"
"PLTSysListView32")
label
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS LBS_NOTIFY
WS_VSCROLL
(if (memq 'hscroll style) WS_HSCROLL 0)
(cond
;; Win32 sense of "multiple" and "extended" is backwards
[(eq? kind 'extended) LBS_MULTIPLESEL]
[(eq? kind 'multiple) LBS_EXTENDEDSEL]
[else 0]))
(if single-column?
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS LBS_NOTIFY
WS_VSCROLL
(if (memq 'hscroll style) WS_HSCROLL 0)
(cond
;; Win32 sense of "multiple" and "extended" is backwards
[(eq? kind 'extended) LBS_MULTIPLESEL]
[(eq? kind 'multiple) LBS_EXTENDEDSEL]
[else 0]))
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS
LVS_REPORT
(if (memq 'column-headers style)
0
LVS_NOCOLUMNHEADER)
LVS_SHOWSELALWAYS
WS_VSCROLL
(if (memq 'hscroll style) WS_HSCROLL 0)
(cond
[(eq? kind 'extended) 0]
[(eq? kind 'multiple) 0]
[else LVS_SINGLESEL])))
0 0 0 0
(send parent get-client-hwnd)
#f
hInstance
#f))
(for ([s (in-list choices)])
(SendMessageW/str hwnd LB_ADDSTRING 0 s))
(when single-column?
(for ([s (in-list choices)])
(SendMessageW/str hwnd LB_ADDSTRING 0 s)))
(unless single-column?
(for ([label (in-list columns)]
[col (in-naturals)])
(atomically
(let ([col-desc (make-lvcolumn LVCF_TEXT label)])
(SendMessageW/ptr hwnd LVM_INSERTCOLUMNW col col-desc)
(free-lvcolumn col-desc)))
(let* ([label-width
(SendMessageW/str hwnd LVM_GETSTRINGWIDTHW 0 label)]
[max-width
(if (zero? col)
;; size column based on the content:
(for/fold ([w label-width]) ([s (in-list choices)]
[i (in-naturals)])
(atomically
(let ([lv (make-lvitem (bitwise-ior LVIF_DI_SETITEM
LVIF_TEXT)
i
col
s)])
(if (zero? col)
(SendMessageW/ptr hwnd LVM_INSERTITEMW 0 lv)
(SendMessageW/ptr hwnd LVM_SETITEMTEXTW i lv))
(free-lvitem lv)))
(max w
(SendMessageW/str hwnd LVM_GETSTRINGWIDTHW 0 s)))
;; size column based on the label, only:
label-width)])
(let ([col-desc (make-lvcolumn LVCF_WIDTH #f)])
(set-LVCOLUMN-cx! col-desc (+ max-width COLUMN-PADDING))
(SendMessageW/ptr hwnd LVM_SETCOLUMNW col col-desc)))))
(unless single-column?
(SendMessageW hwnd LVM_SETEXTENDEDLISTVIEWSTYLE 0
(bitwise-ior LVS_EX_FULLROWSELECT
(if (memq 'reorderable-headers style)
LVS_EX_HEADERDRAGDROP
0))))
(when column-order
(set-column-order column-order))
(super-new [callback cb]
[parent parent]
@ -90,19 +271,50 @@
(define callback cb)
(define/override (is-command? cmd)
(or (= cmd LBN_SELCHANGE)
(= cmd LBN_DBLCLK)))
(if single-column?
(or (= cmd LBN_SELCHANGE)
(= cmd LBN_DBLCLK))
(or (= cmd LVN_ITEMCHANGED)
(= cmd NM_DBLCLK)
(= cmd LVN_COLUMNCLICK))))
(define pending-changed (box #f))
(define/override (do-command cmd control-hwnd)
;; LVN_ITEMCHANGED notifications, in particular, get
;; set for each item that changes in a selection change.
;; Use a box to cancel pending callbacks to collapse the
;; multiple callbacks into one.
(set-box! pending-changed #f)
(let ([b (box #t)]
[t (if (if single-column?
(= cmd LBN_SELCHANGE)
(= cmd LVN_ITEMCHANGED))
'list-box
'list-box-dclick)])
(unless (eq? t 'list-box-dclick)
(set! pending-changed b))
(queue-window-event
this
(lambda ()
(when (unbox b)
(callback this
(new control-event%
[event-type t]
[time-stamp (current-milliseconds)])))))))
(define/override (do-command-ex cmd control-hwnd nmhdr)
(if (and (not single-column?)
(= cmd LVN_COLUMNCLICK))
(let ([col (NMLISTVIEW-iSubItem
(cast nmhdr _pointer _NMLISTVIEW-pointer))])
(queue-window-event this (lambda ()
(callback this
(new column-control-event%
[column col]
[event-type 'list-box-column]
[time-stamp (current-milliseconds)])))))
(super do-command-ex cmd control-hwnd nmhdr)))
(define/public (do-command cmd control-hwnd)
(queue-window-event this (lambda ()
(callback this
(new control-event%
[event-type (if (= cmd LBN_SELCHANGE)
'list-box
'list-box-dclick)]
[time-stamp (current-milliseconds)])))))
(define num (length choices))
(define/public (number) num)
@ -110,37 +322,138 @@
(define/public (get-data i) (unbox (list-ref data i)))
(define/public (set-data i v) (set-box! (list-ref data i) v))
(define/public (set-string i str)
(define/public (set-string i str [col 0])
(atomically
(SendMessageW/str hwnd LB_INSERTSTRING i str)
(SendMessageW hwnd LB_DELETESTRING (add1 i) 0)
(if single-column?
(begin
(SendMessageW/str hwnd LB_INSERTSTRING i str)
(SendMessageW hwnd LB_DELETESTRING (add1 i) 0))
(let ([lv (make-lvitem 0
0
col
str)])
(SendMessageW/ptr hwnd LVM_SETITEMTEXTW i lv)
(free-lvitem lv)))
(void)))
(define/public (set-column-order column-order)
(unless single-column?
(let* ([count num-columns]
[a (malloc _int count)])
(for ([n (in-list column-order)]
[i (in-range count)])
(ptr-set! a _int i n))
(SendMessageW/ptr hwnd LVM_SETCOLUMNORDERARRAY count a)
(InvalidateRect hwnd #f #f))))
(define/public (get-column-order)
(if single-column?
'(0)
(let* ([count num-columns]
[a (malloc _int count)])
(SendMessageW/ptr hwnd LVM_GETCOLUMNORDERARRAY count a)
(cast a _pointer (_list o _int count)))))
(define/public (set-column-label col s)
(unless single-column?
(atomically
(let ([col-desc (make-lvcolumn LVCF_TEXT s)])
(SendMessageW/ptr hwnd LVM_SETCOLUMNW col col-desc)
(free-lvcolumn col-desc)))))
(define min-col-width 0) ; not kept for us by XP
(define max-col-width 10000)
(define/public (set-column-size col w mn mx)
(if single-column?
(atomically
(set! min-col-width mn)
(set! max-col-width mx))
(atomically
(let ([col-desc (make-lvcolumn (bitwise-ior LVCF_WIDTH LVCF_MINWIDTH) #f)])
(set-LVCOLUMN-cx! col-desc w)
(set-LVCOLUMN-cxMin! col-desc mn)
(SendMessageW/ptr hwnd LVM_SETCOLUMNW col col-desc)
(set! min-col-width mn)
(set! max-col-width mx)))))
(define/public (get-column-size col)
(atomically
(let ([col-desc (make-lvcolumn (bitwise-ior LVCF_WIDTH LVCF_MINWIDTH) #f)])
(SendMessageW/ptr hwnd LVM_GETCOLUMNW col col-desc)
(let ([v (LVCOLUMN-cx col-desc)])
(values (max v min-col-width) ; in XP, may have been sized too small
min-col-width
max-col-width)))))
(define/public (append-column label)
(atomically
(let ([col-desc (make-lvcolumn (bitwise-ior LVCF_TEXT
LVCF_WIDTH)
label)])
(set-LVCOLUMN-cx! col-desc
(SendMessageW/str hwnd LVM_GETSTRINGWIDTHW 0 label))
(SendMessageW/ptr hwnd LVM_INSERTCOLUMNW num-columns col-desc)
(free-lvcolumn col-desc))
(set! num-columns (add1 num-columns))))
(define/public (delete-column col)
(atomically
(SendMessageW hwnd LVM_DELETECOLUMN col 0)
(set! num-columns (sub1 num-columns))))
(define/public (set-first-visible-item i)
(void (SendMessageW hwnd LB_SETTOPINDEX i 0)))
(if single-column?
(void (SendMessageW hwnd LB_SETTOPINDEX i 0))
(let ([c (SendMessageW hwnd LVM_GETCOUNTPERPAGE 0 0)])
(unless (= c i)
(if (> (SendMessageW hwnd LVM_GETTOPINDEX 0 0)
i)
(void (SendMessageW hwnd LVM_ENSUREVISIBLE i 0))
(void (SendMessageW hwnd LVM_ENSUREVISIBLE (sub1 (min num (+ i c))) 0)))))))
(define/public (get-first-item)
(SendMessageW hwnd LB_GETTOPINDEX 0 0))
(SendMessageW hwnd (if single-column? LB_GETTOPINDEX LVM_GETTOPINDEX) 0 0))
(define/public (number-of-visible-items)
(let ([ih (SendMessageW hwnd LB_GETITEMHEIGHT 0 0)])
(let ([w (box 0)]
[h (box 0)])
(get-client-size w h)
(quotient (unbox h) ih))))
(if single-column?
(let ([ih (SendMessageW hwnd LB_GETITEMHEIGHT 0 0)])
(let ([w (box 0)]
[h (box 0)])
(get-client-size w h)
(quotient (unbox h) ih)))
(SendMessageW hwnd LVM_GETCOUNTPERPAGE 0 0)))
(define/public (clear)
(atomically
(set! data null)
(set! num 0)
(void (SendMessageW hwnd LB_RESETCONTENT 0 0))))
(void (SendMessageW hwnd (if single-column?
LB_RESETCONTENT
LVM_DELETEALLITEMS)
0 0))))
(define/public (set choices)
(define/public (set choices . more-choices)
(atomically
(ShowWindow hwnd SW_HIDE)
(clear)
(for ([s (in-list choices)])
(SendMessageW/str hwnd LB_ADDSTRING 0 s))
(if single-column?
(for ([s (in-list choices)])
(SendMessageW/str hwnd LB_ADDSTRING 0 s))
(for ([choices (in-list (cons choices more-choices))]
[col (in-naturals)])
(for ([s (in-list choices)]
[i (in-naturals)])
(atomically
(let ([lv (make-lvitem (bitwise-ior LVIF_DI_SETITEM
LVIF_TEXT)
i
col
s)])
(if (zero? col)
(SendMessageW/ptr hwnd LVM_INSERTITEMW 0 lv)
(SendMessageW/ptr hwnd LVM_SETITEMTEXTW i lv))
(free-lvitem lv))))))
(set! data (map (lambda (s) (box #f)) choices))
(set! num (length choices))
(ShowWindow hwnd SW_SHOW)))
@ -148,7 +461,15 @@
(public [append* append])
(define (append* s [v #f])
(atomically
(SendMessageW/str hwnd LB_ADDSTRING 0 s)
(if single-column?
(SendMessageW/str hwnd LB_ADDSTRING 0 s)
(let ([lv (make-lvitem (bitwise-ior LVIF_DI_SETITEM
LVIF_TEXT)
num
0
s)])
(SendMessageW/ptr hwnd LVM_INSERTITEMW 0 lv)
(free-lvitem lv)))
(set! num (add1 num))
(set! data (append data (list (box v))))))
@ -156,25 +477,35 @@
(atomically
(set! data (append (take data i) (drop data (add1 i))))
(set! num (sub1 num))
(void (SendMessageW hwnd LB_DELETESTRING i 0))))
(void (SendMessageW hwnd (if single-column?
LB_DELETESTRING
LVM_DELETEITEM)
i 0))))
(define/public (get-selections)
(atomically
(if single?
(let ([v (SendMessageW hwnd LB_GETCURSEL 0 0)])
(if (= v LB_ERR)
null
(list v)))
(let ([n (SendMessageW hwnd LB_GETSELCOUNT 0 0)])
(if (zero? n)
null
(let ([selections (malloc n _LONG 'raw)])
(SendMessageW hwnd LB_GETSELITEMS n (cast selections _pointer _LPARAM))
(begin0
(for/list ([i (in-range n)])
(ptr-ref selections _LONG i))
(free selections))))))))
(if single-column?
(if single?
(let ([v (SendMessageW hwnd LB_GETCURSEL 0 0)])
(if (= v LB_ERR)
null
(list v)))
(let ([n (SendMessageW hwnd LB_GETSELCOUNT 0 0)])
(if (zero? n)
null
(let ([selections (malloc n _LONG 'raw)])
(SendMessageW hwnd LB_GETSELITEMS n (cast selections _pointer _LPARAM))
(begin0
(for/list ([i (in-range n)])
(ptr-ref selections _LONG i))
(free selections))))))
(let loop ([c (SendMessageW hwnd LVM_GETSELECTEDCOUNT 0 0)]
[pos -1])
(cond
[(zero? c) null]
[else (let ([pos (SendMessageW hwnd LVM_GETNEXTITEM pos LVNI_SELECTED)])
(cons pos (loop (sub1 c) pos)))])))))
(define/public (get-selection)
(let ([l (get-selections)])
(if (null? l)
@ -182,16 +513,28 @@
(car l))))
(define/public (selected? i)
(not (zero? (SendMessageW hwnd LB_GETSEL i 0))))
(if single-column?
(not (zero? (SendMessageW hwnd LB_GETSEL i 0)))
(not (zero? (SendMessageW hwnd LVM_GETITEMSTATE i LVIS_SELECTED)))))
(define/public (select i [on? #t] [one? #t])
(void
(if single?
(SendMessageW hwnd LB_SETCURSEL (if on? i -1) 0)
(begin
(unless one?
(SendMessageW hwnd LB_SELITEMRANGE 0 (MAKELPARAM 0 num)))
(SendMessageW hwnd LB_SETSEL (if on? 1 0) i)))))
(if single-column?
(if single?
(SendMessageW hwnd LB_SETCURSEL (if on? i -1) 0)
(begin
(unless one?
(SendMessageW hwnd LB_SELITEMRANGE 0 (MAKELPARAM 0 num)))
(SendMessageW hwnd LB_SETSEL (if on? 1 0) i)))
(let ([lv (make-lvitem 0 0 0 #f)])
(define (set-one i on?)
(set-LVITEM-stateMask! lv LVIS_SELECTED)
(set-LVITEM-state! lv (if on? LVIS_SELECTED 0))
(SendMessageW/ptr hwnd LVM_SETITEMSTATE i lv))
(when (and on? (not single?) (not one?))
(for ([i (in-list (get-selections))])
(set-one i #f)))
(set-one i on?)))))
(define/public (set-selection i)
(void (select i #t #f)))

2
collects/mred/private/wx/win32/radio-box.rkt
View File

@ -108,7 +108,7 @@
(define/override (is-command? cmd)
(= cmd BN_CLICKED))
(define/public (do-command cmd control-hwnd)
(define/override (do-command cmd control-hwnd)
(let ([val (for/fold ([i 0]) ([radio-hwnd (in-list radio-hwnds)]
[pos (in-naturals)])
(if (ptr-equal? control-hwnd radio-hwnd)

2
collects/mred/private/wx/win32/tab-panel.rkt
View File

@ -114,7 +114,7 @@
(define/override (is-command? cmd)
(= cmd -551))
(define/public (do-command cmd control-hwnd)
(define/override (do-command cmd control-hwnd)
(queue-window-event this (lambda ()
(callback this
(new control-event%

4
collects/mred/private/wx/win32/utils.rkt
View File

@ -22,7 +22,7 @@
GetWindowLongPtrW
SetWindowLongPtrW
SendMessageW SendMessageW/str
SendMessageW SendMessageW/str SendMessageW/ptr
GetSysColor GetRValue GetGValue GetBValue make-COLORREF
CreateBitmap
CreateCompatibleBitmap
@ -82,6 +82,8 @@
(define-user32 SendMessageW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT))
(define-user32 SendMessageW/str (_wfun _HWND _UINT _WPARAM _string/utf-16 -> _LRESULT)
#:c-id SendMessageW)
(define-user32 SendMessageW/ptr (_wfun _HWND _UINT _WPARAM _pointer -> _LRESULT)
#:c-id SendMessageW)
(define-user32 GetSysColor (_wfun _int -> _DWORD))

11
collects/mred/private/wx/win32/window.rkt
View File

@ -28,7 +28,9 @@
get-default-control-font
GetWindowRect
GetClientRect))
GetClientRect
_NMHDR))
(define (unhide-cursor) (void))
@ -213,7 +215,7 @@
[cmd (LOWORD (NMHDR-code nmhdr))])
(if (and wx (send wx is-command? cmd))
(begin
(send wx do-command cmd control-hwnd)
(send wx do-command-ex cmd control-hwnd nmhdr)
0)
(default w msg wParam lParam)))]
[(or (= msg WM_HSCROLL)
@ -246,6 +248,11 @@
(define/public (is-command? cmd) #f)
(define/public (control-scrolled) #f)
(define/public (do-command cmd control-hwnd)
(void))
(define/public (do-command-ex cmd control-hwnd nmhdr)
(do-command cmd control-hwnd))
(define/public (show on?)
(when on? (show-children))
(atomically (direct-show on?)))

1
collects/mred/private/wx/win32/wndclass.rkt
View File

@ -307,3 +307,4 @@
(register-no-cursor "msctls_trackbar32")
(register-no-cursor "msctls_progress32")
(register-no-cursor "SysTabControl32")
(register-no-cursor "SysListView32")

27
collects/mred/private/wxlitem.rkt
View File

@ -48,9 +48,9 @@
(define (filter-style style)
(remq 'deleted style))
(define-syntax-rule (bounce c (m arg ...) ...)
(define-syntax-rule (bounce c (m . args) ...)
(begin
(define/public m (lambda (arg ...) (send c m arg ...)))
(define/public m (lambda args (send c m . args)))
...))
;; ----------------------------------------
@ -121,7 +121,8 @@
(define wx-internal-list-box%
(make-window-glue%
(class100 (make-control% wx:list-box% 0 0 #t #t) (parent cb label kind x y w h choices style font label-font)
(class100 (make-control% wx:list-box% 0 0 #t #t) (parent cb label kind x y w h choices style font
label-font columns column-order)
(inherit get-first-item
set-first-visible-item)
(private
@ -147,23 +148,24 @@
[(wheel-up) (scroll -1) #t]
[(wheel-down) (scroll 1) #t]
[else #f])))])
(sequence (super-init style parent cb label kind x y w h choices (cons 'deleted style) font label-font)))))
(sequence (super-init style parent cb label kind x y w h choices (cons 'deleted style) font
label-font columns column-order)))))
(define wx-list-box%
(class wx-label-panel%
(init mred proxy parent cb label kind x y w h choices style font label-font)
(init mred proxy parent cb label kind x y w h choices style font label-font columns column-order)
(inherit get-p set-c)
(super-init proxy parent label style font 'left 'top)
(define c (make-object wx-internal-list-box% mred proxy (get-p) cb label kind x y w h choices
(filter-style style) font label-font))
(filter-style style) font label-font columns column-order))
(set-c c #t #t)
(bounce
c
(get-label-font)
(set-string i s)
(set-string i s col)
(set-selection i)
(get-selection)
(get-selections)
@ -178,8 +180,15 @@
(selected? i)
(delete i)
(clear)
(set choices)
(reset))
(set choices . more)
(reset)
(get-column-order)
(set-column-order l)
(set-column-label i l)
(set-column-size i w mn mx)
(get-column-size i)
(delete-column i)
(append-column l))
(define/public select
(case-lambda
[(i) (send c select i)]

28
collects/scribblings/gui/column-control-event-class.scrbl Normal file
View File

@ -0,0 +1,28 @@
#lang scribble/doc
@(require "common.ss")
@defclass/title[column-control-event% control-event% ()]{
A @scheme[column-control-event%] object contains information about a
event on an @racket[list-box%] column header.
@defconstructor[([column exact-nonnegative-integer?]
[event-type (one-of/c 'list-box-column)]
[time-stamp exact-integer? 0])]{
The @racket[column] argument indicates the column that was clicked.
}
@defmethod[(get-column) exact-nonnegative-integer?]{
Returns the column number (counting from 0) of the clicked column.
}
@defmethod[(set-column
[column exact-nonnegative-integer?])
void?]{
Sets the column number (counting from 0) of the clicked column.
}}

11
collects/scribblings/gui/control-event-class.scrbl
View File

@ -8,9 +8,10 @@ A @scheme[control-event%] object contains information about a
provided to a control or menu item callback procedure.
@defconstructor[([event-type (one-of/c 'button 'check-box 'choice
'list-box 'list-box-dclick 'text-field
'text-field-enter 'slider 'radio-box
'menu-popdown 'menu-popdown-none 'tab-panel)]
'list-box 'list-box-dclick 'list-box-column
'text-field 'text-field-enter
'slider 'radio-box 'tab-panel
'menu-popdown 'menu-popdown-none)]
[time-stamp exact-integer? 0])]{
The @scheme[event-type] argument is one of the following:
@ -20,14 +21,16 @@ The @scheme[event-type] argument is one of the following:
@item{@scheme['choice] --- for @scheme[choice%] item selections}
@item{@scheme['list-box] --- for @scheme[list-box%] selections and deselections}
@item{@scheme['list-box-dclick] --- for @scheme[list-box%] double-clicks}
@item{@scheme['list-box-column] --- for @scheme[list-box%] column clicks in
a @racket[column-control-event%] instance}
@item{@scheme['text-field] --- for @scheme[text-field%] changes}
@item{@scheme['text-field-enter] --- for single-line @scheme[text-field%] Enter event}
@item{@scheme['menu] --- for @scheme[selectable-menu-item<%>] callbacks}
@item{@scheme['slider] --- for @scheme[slider%] changes}
@item{@scheme['radio-box] --- for @scheme[radio-box%] selection changes}
@item{@scheme['tab-panel] --- for @scheme[tab-panel%] tab changes}
@item{@scheme['menu-popdown] --- for @scheme[popup-menu%] callbacks (item selected)}
@item{@scheme['menu-popdown-none] --- for @scheme[popup-menu%] callbacks (no item selected)}
@item{@scheme['tab-panel] --- for @scheme[tab-panel%] tab changes}
]
This value is extracted out of a @scheme[control-event%] object with

156
collects/scribblings/gui/list-box-class.scrbl
View File

@ -1,7 +1,8 @@
#lang scribble/doc
@(require "common.ss")
@(define lbnumnote @elem{List box items are indexed from @scheme[0].})
@(define lbnumnote @elem{List box rows are indexed from @scheme[0].})
@(define lbcnumnote @elem{List box rows and columns are indexed from @scheme[0].})
@defclass/title[list-box% object% (list-control<%>)]{
@ -16,7 +17,14 @@ Whenever the user changes the selection in a list box, the list box's
callback procedure is called. A callback procedure is provided as an
initialization argument when each list box is created.
@|lbnumnote|
A list box can have multiple columns with optional column headers. An
item in the list corresponds to a row that spans all columns. When
column headers are displayed, the column widths can be changed by a
user. In addition, columns can optionally support dragging by the
user to change the display order of columns, while the logical order
remains fixed.
@|lbcnumnote|
See also @scheme[choice%].
@ -30,6 +38,8 @@ See also @scheme[choice%].
(lambda (c e) (void))]
[style (listof (one-of/c 'single 'multiple 'extended
'vertical-label 'horizontal-label
'variable-columns 'column-headers
'clickable-headers 'reorderable-headers
'deleted))
'(single)]
[selection (or/c exact-nonnegative-integer? false/c) #f]
@ -41,7 +51,10 @@ See also @scheme[choice%].
[min-width (integer-in 0 10000) _graphical-minimum-width]
[min-height (integer-in 0 10000) _graphical-minimum-height]
[stretchable-width any/c #t]
[stretchable-height any/c #t])]{
[stretchable-height any/c #t]
[columns (cons/c label-string? (listof label-string?))
'("Column")]
[column-order (or/c #f (listof exact-nonnegative-integer?)) #f])]{
If @scheme[label] is not @scheme[#f], it is used as the list box
label. Otherwise, the list box will not display its label.
@ -49,7 +62,9 @@ If @scheme[label] is not @scheme[#f], it is used as the list box
@labelstripped[(scheme label) @elem{} @elem{move the keyboard focus to the list box}]
The @scheme[choices] list specifies the initial list of items
to appear in the list box.
to appear in the list box. If the list box has multiple columns,
@racket[choices] determines the content of the first column, and
other columns are initialized to the empty string.
The @scheme[callback] procedure is called when the user changes the list
box selection, by either selecting, re-selecting, deselecting, or
@ -57,6 +72,14 @@ The @scheme[callback] procedure is called when the user changes the list
callback is @indexed-scheme['list-box-dclick] when the user double-clicks
on an item, or @indexed-scheme['list-box] otherwise.
The @racket[columns] list determines the number of columns in the list
box. The column titles in @racket[columns] are shown only if
@racket[style] includes @racket['column-headers]. If @racket[style]
also includes @racket['clickable-headers], then a click on a header
triggers a call to @racket[callback] with a
@racket[column-control-event%] argument whose event type is
@indexed-scheme['list-box-column].
The @scheme[style] specification must include exactly one of the
following:
@itemize[
@ -85,17 +108,29 @@ The @scheme['multiple] and @scheme['extended] styles determine a
@HVLabelNote[@scheme[style]]{list box} @DeletedStyleNote[@scheme[style] @scheme[parent]]{list box}
If @racket[style] includes @racket['variable-columns], then the number
of columns in the list box can be changed via @method[list-box% append-column]
and @method[list-box% delete-column].
If @scheme[selection] is an integer, it is passed to
@method[list-control<%> set-selection] to set the initial selection. The @scheme[selection] must be less than
the length of @scheme[choices].
@FontLabelKWs[@scheme[font] @scheme[label-font]] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[]
It the @racket[column-order] argument is not @racket[#f], it
determines the order in which logical columns are initially displayed. See
@method[list-box% set-column-order] for more information. If
@racket[style] includes @racket['column-headers] and
@racket['reorderable-headers], then a user can reorder columns as
displayed (but the display order does not change the logical order of
the columns).
}
@defmethod[#:mode override
(append [item string]
(append [item label-string?]
[data any/c #f])
void?]{
@ -110,6 +145,15 @@ See also @xmethod[list-control<%> append].
}
@defmethod[(append-column [label label-string?])
void?]{
Adds a new column with title @racket[label] to the list box, but only
if the list box is created with the @racket['variable-columns]
style. The new column is logically the last column, and it is initially
displayed as the last column.}
@defmethod[(delete [n exact-nonnegative-integer?])
void?]{
@ -117,9 +161,47 @@ Deletes the item indexed by @scheme[n]. @|lbnumnote| If @scheme[n] is equal
to or larger than the number of items in the control, @|MismatchExn|.
Selected items that are not deleted remain selected, and no other
items are selected.
items are selected.}
@defmethod[(delete-column [n exact-nonnegative-integer?])
void?]{
Deletes the column with logical position @racket[n], but only if the
list box is created with the @racket['variable-columns] style, and
only if the list box currently has more than one column (i.e., the
number of columns can never be zero).}
@defmethod[(get-column-labels) (cons/c label-string? (listof label-string?))]{
Returns the labels of the list box's columns, and the number of
returned strings indicates the number of columns in the list box.}
@defmethod[(get-column-order) (listof exact-nonnegative-integer?)]{
Returns the display order of logical columns. Each column is
represented by its logical position in the result list, and the order
of the column positions indicates the display order.
See also @method[list-box% set-column-order].}
@defmethod[(get-column-width [column exact-nonnegative-integer?])
(values exact-nonnegative-integer?
exact-nonnegative-integer?
exact-nonnegative-integer?)]{
Gets the width of the column identified by @racket[column] (in logical
positions, as opposed to display positions), which must be between 0
and one less than the number of columns.
The result includes the column's current width as well as its minimum
and maximum widths to constrain the column size as adjusted by a user.
See also @method[list-box set-column-width].}
}
@defmethod[(get-data [n exact-nonnegative-integer?])
any/c]{
@ -165,7 +247,7 @@ For single-selection lists, the result is always either @scheme[null] or
@defmethod[(is-selected? [n exact-nonnegative-integer?])
boolean?]{
Returns @scheme[#t] if the item index by @scheme[n] is selected,
Returns @scheme[#t] if the items indexed by @scheme[n] is selected,
@scheme[#f] otherwise. @|lbnumnote| If @scheme[n] is equal to or
larger than the number of choices, @|MismatchExn|.
@ -204,12 +286,55 @@ The control's callback procedure is @italic{not} invoked.
}
@defmethod[(set [choices (listof label-string?)])
@defmethod[(set [choices (listof label-string?)]
...)
void?]{
Clears the list box and installs a new list of items.
Clears the list box and installs a new list of items. The number of
@racket[choices] lists must match the number of columns, and all
@racket[choices] lists must have the same number of items, otherwise
@|MismatchExn|.}
}
@defmethod[(set-column-label [column exact-nonnegative-integer?]
[label label-string?])
void?]{
Sets the label of the column identified by @racket[column] (in logical
positions, as opposed to display positions), which must be between 0
and one less than the number of columns.}
@defmethod[(set-column-order [column-order (listof exact-nonnegative-integer?)])
void?]{
Sets the order in which logical columns are displayed. Each element of
@racket[column-order] must identify a unique column by its logical
position, and all logical columns must be represented in the list.
See also @method[list-box% get-column-order].}
@defmethod[(set-column-width [column exact-nonnegative-integer?]
[width exact-nonnegative-integer?]
[min-width exact-nonnegative-integer?]
[max-width exact-nonnegative-integer?])
void?]{
Sets the width of the column identified by @racket[column] (in logical
positions, as opposed to display positions), which must be between 0
and one less than the number of columns.
The @racket[width] argument sets the current display width, while
@racket[min-width] and @racket[max-width] constrain the width of the
column when the user resizes it. The @racket[width] argument must be
no less than @racket[min-width] and no more than @racket[max-width].
The default width of a column is platform-specific, and the last
column of a list box may extend to the end of the control independent
of its requested size.
See also @method[list-box% get-column-width].}
@defmethod[(set-data [n exact-nonnegative-integer?]
@ -239,11 +364,14 @@ Scrolls the list box so that the item indexed by @scheme[n] is at the
@defmethod[(set-string [n exact-nonnegative-integer?]
[label label-string?])
[label label-string?]
[column exact-nonnegative-integer? 0])
void?]{
Sets the item indexed by @scheme[n]. @|lbnumnote| If @scheme[n] is
equal to or larger than the number of choices, @|MismatchExn|.
Sets the item indexed by @scheme[n] in logical column @racket[column].
@|lbcnumnote| If @scheme[n] is
equal to or larger than the number of choices, or if @racket[column]
is equal to or larger than the number of columns, @|MismatchExn|.
}
}

2
collects/scribblings/gui/list-control-intf.scrbl
View File

@ -22,7 +22,7 @@ In either case, the set of user-selectable items can be changed
@defmethod[(append [item string])
@defmethod[(append [item label-string?])
void?]{
Adds a new item to the list of user-selectable items. The current
selection is unchanged (unless the list control is an empty choice

1
collects/scribblings/gui/win-classes.scrbl
View File

@ -33,6 +33,7 @@ Alphabetical:
@include-section["clipboard-intf.scrbl"]
@include-section["combo-field-class.scrbl"]
@include-section["control-intf.scrbl"]
@include-section["column-control-event-class.scrbl"]
@include-section["control-event-class.scrbl"]
@include-section["cursor-class.scrbl"]
@include-section["dialog-class.scrbl"]

128
collects/tests/gracket/item.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/gui
#lang racket/gui
(require mzlib/class
mzlib/class100
@ -1402,7 +1402,8 @@
(instructions p "radiobox-steps.txt")
(send f show #t))
(define (choice-or-list-frame list? list-style empty?)
(define (choice-or-list-frame list? list-style empty?
[columns '("Choice")] [more-styles '()] [column-order #f])
(define f (make-frame frame% (if list? "List Test" "Choice Test")))
(define p f)
(define-values (actual-content actual-user-data)
@ -1412,7 +1413,10 @@
(list #f #f #f))))
(define commands
(if list?
(list 'list-box 'list-box-dclick)
(append (list 'list-box 'list-box-dclick)
(if (memq 'clickable-headers more-styles)
(list 'list-box-column)
null))
(list 'choice)))
(define old-list null)
(define multi? (or (memq 'multiple list-style)
@ -1428,6 +1432,8 @@
(printf "Double-click\n")
(unless (send cx get-selection)
(error "no selection for dclick"))]
[(eq? (send e get-event-type) 'list-box-column)
(printf "Column: ~a\n" (send e get-column))]
[else
; misc multi-selection
(printf "Changed: ~a\n" (if list?
@ -1435,12 +1441,21 @@
(send cx get-selection)))])
(check-callback-event c cx e commands #f)))
(define c (if list?
(make-object list-box% "Tester" actual-content p callback list-style)
(new list-box% [label "Tester"]
[choices actual-content]
[parent p]
[callback callback]
[style (append list-style more-styles)]
[columns columns]
[column-order column-order])
(make-object choice% "Tester" actual-content p callback)))
(define counter 0)
(define append-with-user-data? #f)
(define ap (new horizontal-panel% [parent p]
[stretchable-width #f]
[stretchable-height #f]))
(define ab (make-object button%
"Append" p
"Append" ap
(lambda (b e)
(set! counter (add1 counter))
(let ([naya (format "~aExtra ~a"
@ -1463,14 +1478,55 @@
naya-data))))
(set! append-with-user-data?
(not append-with-user-data?))))))
(define cs (when list?
(make-object button%
"Visible Indices" p
(lambda (b e)
(printf "top: ~a\nvisible count: ~a\n"
(send c get-first-visible-item)
(send c number-of-visible-items))))))
(define cdp (make-object horizontal-panel% p))
(new button%
[label "Add Column"]
[parent ap]
[callback (lambda (b e)
(let ([s (format "New ~a" (length columns))])
(send c append-column s)
(set! columns (append columns (list s)))))])
(new button%
[label "Delete Right Column"]
[parent ap]
[callback (lambda (b e)
(let ([pos (last (send c get-column-order))])
(send c delete-column pos)
(set! columns (send c get-column-labels))))])
(when list?
(let ([hp (new horizontal-panel%
[parent p]
[stretchable-width #f]
[stretchable-height #f])])
(make-object button%
"Visible Indices" hp
(lambda (b e)
(printf "top: ~a\nvisible count: ~a\n"
(send c get-first-visible-item)
(send c number-of-visible-items))))
(define (mk which pos)
(new button% [label (format "Set ~a Top" which)]
[parent hp]
[callback (lambda (b e) (send c set-first-visible-item pos))]))
(mk "First" 0)
(mk "Third" 2)
(mk "Tenth" 9)
(new button% [label "Reverse Columns"]
[parent hp]
[callback (lambda (b e) (send c set-column-order (reverse (send c get-column-order))))])
(new button% [label "Set Column Label"]
[parent hp]
[callback (lambda (b e)
(send c set-column-label (sub1 (length columns)) "Last")
(send c set-column-label 0 "First"))])
(new button% [label "Set Column Size"]
[parent hp]
[callback (lambda (b e)
(send c set-column-size 0 50 10 100)
(unless (= 1 (length columns))
(let-values ([(w mn mx) (send c get-column-size 0)])
(send c set-column-size (sub1 (length columns)) w mn mx))))])))
(define cdp (new horizontal-panel% [parent p]
[stretchable-height #f]))
(define rb (make-object button% "Clear" cdp
(lambda (b e)
(set! actual-content null)
@ -1510,7 +1566,11 @@
(make-object button%
"Reset" cdp
(lambda (b e)
(send c set '("Alpha" "Beta" "Gamma"))
(let ([extras (for/list ([in-list (cdr columns)]
[col (in-naturals 1)])
(for/list ([i (in-range 3)])
(format "~a, ~a" col i)))])
(send c set '("Alpha" "Beta" "Gamma") . extras))
(set! actual-content '("Alpha" "Beta" "Gamma"))
(set! actual-user-data (list #f #f #f))))
null))
@ -1533,6 +1593,11 @@
(let ([p (send c get-selection)])
(when p
(send c set-string p "New Name")
(for ([in-list (cdr columns)]
[col (in-naturals 1)])
(send c set-string p
(format "new ~a" col)
col))
(set! actual-content
(let loop ([ac actual-content][p p])
(if (zero? p)
@ -2300,12 +2365,39 @@
(make-object button% "Make Choice Frame" cp (lambda (b e) (choice-or-list-frame #f null #f)))
(make-object button% "Make Empty Choice Frame" cp (lambda (b e) (choice-or-list-frame #f null #t)))
(make-object button% "Make Combo Frame" cp (lambda (b e) (combo-frame #f)))
(define lcp (make-object horizontal-pane% ap))
(send lcp stretchable-width #f)
(define list-columns-choice (new choice%
[parent lcp]
[label "List Type"]
[choices '("Single Column"
"Multiple Columns")]))
(define (get-columns) (if (zero? (send list-columns-choice get-selection))
'("Column")
'("Main Entry" "Extra" "Final")))
(define list-headers-choice (new check-box%
[parent lcp]
[label "Show Columns"]))
(define (get-headers) (if (send list-headers-choice get-value)
'(column-headers clickable-headers reorderable-headers variable-columns)
'()))
(define list-order-choice (new check-box%
[parent lcp]
[label "Swap Last Two"]))
(define (get-order) (if (and (positive? (send list-columns-choice get-selection))
(send list-order-choice get-value))
'(0 2 1)
#f))
(define lp (make-object horizontal-pane% ap))
(send lp stretchable-width #f)
(make-object button% "Make List Frame" lp (lambda (b e) (choice-or-list-frame #t '(single) #f)))
(make-object button% "Make Empty List Frame" lp (lambda (b e) (choice-or-list-frame #t '(single) #t)))
(make-object button% "Make MultiList Frame" lp (lambda (b e) (choice-or-list-frame #t '(multiple) #f)))
(make-object button% "Make MultiExtendList Frame" lp (lambda (b e) (choice-or-list-frame #t '(extended) #f)))
(make-object button% "Make List Frame" lp
(lambda (b e) (choice-or-list-frame #t '(single) #f (get-columns) (get-headers) (get-order))))
(make-object button% "Make Empty List Frame" lp
(lambda (b e) (choice-or-list-frame #t '(single) #t (get-columns) (get-headers) (get-order))))
(make-object button% "Make MultiList Frame" lp
(lambda (b e) (choice-or-list-frame #t '(multiple) #f (get-columns) (get-headers) (get-order))))
(make-object button% "Make MultiExtendList Frame" lp
(lambda (b e) (choice-or-list-frame #t '(extended) #f (get-columns) (get-headers) (get-order))))
(define gsp (make-object horizontal-pane% ap))
(send gsp stretchable-height #f)
(make-object button% "Make Gauge Frame" gsp (lambda (b e) (gauge-frame)))