[ -1/0. or * ] [ 1/.0 or * ] bi-curry* bi
[ max ] [ min ] bi* ;
+: em ( font -- x ) "m" text-width ;
+
+PRIVATE>
+
: line-gadget-width ( pref-dim gadget -- w )
- [ first ] [ [ font>> "m" text-width ] [ min-cols>> ] [ max-cols>> ] tri ] bi* clamp ;
+ [ first ] [ [ font>> em ] [ min-cols>> ] [ max-cols>> ] tri ] bi* clamp ;
: line-gadget-height ( pref-dim gadget -- h )
[ second ] [ [ line-height ] [ min-rows>> ] [ max-rows>> ] tri ] bi* clamp ;
-PRIVATE>
-
M: line-gadget pref-viewport-dim
[ pref-dim ] keep
[ line-gadget-width ]
! Copyright (C) 2008, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel delegate fry sequences
-models models.search models.delay calendar locals
-ui.gadgets.editors ui.gadgets.labels ui.gadgets.scrollers
-ui.gadgets.tables ui.gadgets.tracks ui.gadgets.borders
-ui.gadgets.buttons ui.gadgets ;
+USING: accessors kernel delegate fry sequences models models.search
+models.delay calendar locals ui.pens ui.pens.image ui.gadgets.editors
+ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.tables
+ui.gadgets.tracks ui.gadgets.borders ui.gadgets.buttons ui.gadgets ;
IN: ui.gadgets.search-tables
TUPLE: search-field < track field ;
: clear-search-field ( search-field -- )
field>> editor>> clear-editor ;
+: <clear-button-pen> ( -- pen )
+ "clear-button" theme-image <image-pen> dup
+ "clear-button-clicked" theme-image <image-pen> dup dup <button-pen> ;
+
: <clear-button> ( search-field -- button )
- "X" swap '[ drop _ clear-search-field ] <roll-button> ;
+ [ f ] dip '[ drop _ clear-search-field ] <button>
+ <clear-button-pen> >>interior
+ dup dup interior>> pen-pref-dim >>min-dim ;
: <search-field> ( model -- gadget )
horizontal search-field new-track
{ 5 5 } >>gap
+baseline+ >>align
- swap <model-field> 10 >>min-width >>field
+ swap <model-field> 10 >>min-cols >>field
dup field>> "Search:" label-on-left 1 track-add
dup <clear-button> f track-add ;
! A protocol with customizable slots
SLOT-PROTOCOL: table-protocol
renderer
-filled-column
-column-alignment
action
hook
font
+gap
selection-color
focus-border-color
mouse-color
column-line-color
selection-required?
-selected-value ;
+single-click?
+selected-value
+min-rows
+min-cols
+max-rows
+max-cols ;
CONSULT: table-protocol search-table table>> ;
-:: <search-table> ( values quot -- gadget )
+:: <search-table> ( values renderer quot -- gadget )
f <model> :> search
vertical search-table new-track
values >>model
search <search-field> >>field
dup field>> { 2 2 } <filled-border> f track-add
- values search 500 milliseconds <delay> quot <search> <table> >>table
+ values search 500 milliseconds <delay> quot <search>
+ renderer <table> >>table
dup table>> <scroller> 1 track-add ;
M: search-table model-changed
--- /dev/null
+IN: ui.gadgets.tables.tests
+USING: ui.gadgets.tables ui.gadgets.scrollers accessors
+models namespaces tools.test kernel ;
+
+SINGLETON: test-renderer
+
+M: test-renderer row-columns drop ;
+
+M: test-renderer column-titles drop { "First" "Last" } ;
+
+[ ] [
+ {
+ { "Britney" "Spears" }
+ { "Justin" "Timberlake" }
+ { "Don" "Stewart" }
+ } <model> test-renderer <table>
+ "table" set
+] unit-test
+
+[ ] [
+ "table" get <scroller> "scroller" set
+] unit-test
\ No newline at end of file
USING: accessors arrays colors colors.constants fry kernel math
math.rectangles math.order math.vectors namespaces opengl sequences
ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar
-ui.gadgets.worlds ui.gestures ui.render ui.text ui.commands
+ui.gadgets.worlds ui.gestures ui.render ui.pens.solid ui.text ui.commands
ui.images ui.gadgets.menus ui.gadgets.line-support math.rectangles
models math.ranges sequences combinators fonts locals strings ;
IN: ui.gadgets.tables
! Row rendererer protocol
GENERIC: prototype-row ( renderer -- columns )
+GENERIC: column-alignment ( renderer -- alignment )
+GENERIC: filled-column ( renderer -- n )
+GENERIC: column-titles ( renderer -- strings )
+
GENERIC: row-columns ( row renderer -- columns )
GENERIC: row-value ( row renderer -- object )
GENERIC: row-color ( row renderer -- color )
SINGLETON: trivial-renderer
-M: trivial-renderer row-columns drop ;
M: object prototype-row drop { "" } ;
+M: object column-alignment drop f ;
+M: object filled-column drop f ;
+M: object column-titles drop f ;
+
+M: trivial-renderer row-columns drop ;
M: object row-value drop ;
M: object row-color 2drop f ;
TUPLE: table < line-gadget
{ renderer initial: trivial-renderer }
-filled-column column-alignment
{ action initial: [ drop ] }
single-click?
{ hook initial: [ ] }
mouse-index
focused? ;
-: <table> ( rows -- table )
+: <table> ( rows renderer -- table )
table new-line-gadget
+ swap >>renderer
swap >>model
f <model> >>selected-value
sans-serif-font >>font
: column-offsets ( widths gap -- x xs )
[ 0 ] dip '[ _ + + ] accumulate ;
-: initial-widths ( rows -- widths )
- first length 0 <repetition> ;
+CONSTANT: column-title-background COLOR: light-gray
+
+: column-title-font ( font -- font' )
+ column-title-background font-with-background t >>bold? ;
-: row-column-widths ( font row -- widths )
- [ cell-width ] with map ;
+: initial-widths ( table rows -- widths )
+ over renderer>> column-titles dup
+ [ [ drop font>> ] dip [ text-width ] with map ]
+ [ drop nip first length 0 <repetition> ]
+ if ;
+
+: row-column-widths ( table row -- widths )
+ [ font>> ] dip [ cell-width ] with map ;
+
+: compute-total-width ( gap widths -- total )
+ swap [ column-offsets drop ] keep - ;
-: (compute-column-widths) ( gap font rows -- total widths )
- [ 2drop 0 { } ] [
- [ nip initial-widths ] 2keep
+: compute-column-widths ( table -- total widths )
+ dup table-rows [ drop 0 { } ] [
+ [ drop gap>> ] [ initial-widths ] [ ] 2tri
[ row-column-widths vmax ] with each
- [ swap [ column-offsets drop ] keep - ] keep
+ [ compute-total-width ] keep
] if-empty ;
-: compute-column-widths ( table -- total-width column-widths )
- [ gap>> ] [ font>> ] [ table-rows ] tri (compute-column-widths) ;
-
: update-cached-widths ( table -- )
dup compute-column-widths
[ >>total-width ] [ >>column-widths ] bi*
: update-filled-column ( table -- )
[ filled-column-width ]
- [ filled-column>> ]
+ [ renderer>> filled-column ]
[ column-widths>> ] tri
2dup empty? not and
[ [ + ] change-nth ] [ 3drop ] if ;
] dip
] dip translate-column ;
-: column-alignment ( table -- seq )
- dup column-alignment>>
+: table-column-alignment ( table -- seq )
+ dup renderer>> column-alignment
[ ] [ column-widths>> length 0 <repetition> ] ?if ;
:: row-font ( row index table -- font )
row table renderer>> row-color [ >>foreground ] when*
index table selected-index>> = [ table selection-color>> >>background ] when ;
+: draw-columns ( columns widths alignment font gap -- )
+ '[ [ _ ] 3dip _ draw-column ] 3each ;
+
M: table draw-line ( row index table -- )
[
nip
[ renderer>> row-columns ]
[ column-widths>> ]
- [ column-alignment ]
+ [ table-column-alignment ]
tri
]
[ row-font ]
[ 2nip gap>> ] 3tri
- '[ [ _ ] 3dip _ draw-column ] 3each ;
+ draw-columns ;
M: table draw-gadget*
dup control-value empty? [ drop ] [
{ T{ key-down f f "PAGE_DOWN" } next-page }
} define-command-map
+TUPLE: column-headers < gadget table ;
+
+: <column-headers> ( table -- gadget )
+ column-headers new
+ swap >>table
+ column-title-background <solid> >>interior ;
+
+: draw-column-titles ( table -- )
+ {
+ [ renderer>> column-titles ]
+ [ column-widths>> ]
+ [ table-column-alignment ]
+ [ font>> column-title-font ]
+ [ gap>> ]
+ } cleave
+ draw-columns ;
+
+M: column-headers draw-gadget*
+ table>> draw-column-titles ;
+
+M: column-headers pref-dim*
+ table>> [ pref-dim first ] [ font>> "" text-height ] bi 2array ;
+
+M: table viewport-column-header
+ dup renderer>> column-titles
+ [ <column-headers> ] [ drop f ] if ;
+
PRIVATE>
\ No newline at end of file
drop [ name>> ] [ "Abort" ] if* "• " prepend 1array ;
: <restart-list> ( debugger -- gadget )
- dup restarts>> f prefix <model> <table>
+ dup restarts>> f prefix <model>
restart-renderer <table>
[ [ \ restart invoke-command ] when* ] >>action
swap restart-hook>> >>hook
- restart-renderer >>renderer
t >>selection-required?
t >>single-click? ; inline
M: inspector-renderer row-value
drop value>> ;
+M: inspector-renderer column-titles
+ drop { "Key" "Value" } ;
+
: <summary-gadget> ( model -- gadget )
[
standard-table-style [
call-next-method [ [ key-string>> ] compare ] sort ;
: <inspector-table> ( model -- table )
- [ make-slot-descriptions ] <filter> <table>
+ [ make-slot-descriptions ] <filter>
inspector-renderer <table>
[ dup primary-operation invoke-command ] >>action
- inspector-renderer >>renderer
monospace-font >>font ;
: <inspector-gadget> ( model -- gadget )
vertical inspector-gadget new-track
+ { 3 3 } >>gap
add-toolbar
swap >>model
dup model>> <inspector-table> >>table
: <completion-table> ( interactor completion-mode -- table )
[ completion-element ] [ completion-quot ] [ nip ] 2tri
- [ <completion-model> <table> ] dip
- >>renderer
+ [ <completion-model> ] dip <table>
monospace-font >>font
t >>selection-required?
t >>single-click?
M: vocab-renderer row-value
call-next-method dup [ vocab ] when ;
+M: profiler-renderer column-alignment drop { 0 1 } ;
+M: profiler-renderer filled-column drop 0 ;
+
+M: word-renderer column-titles drop { "Word" "Count" } ;
+M: vocab-renderer column-titles drop { "Vocabulary" "Count" } ;
+
SINGLETON: method-renderer
+M: method-renderer column-alignment drop { 0 1 } ;
+M: method-renderer filled-column drop 0 ;
+
! Value is a { method-body count } pair
M: method-renderer row-columns
drop [ first synopsis ] [ second present ] bi 2array ;
M: method-renderer row-value drop first ;
+M: method-renderer column-titles drop { "Method" "Count" } ;
+
: <profiler-model> ( values profiler -- model )
[ [ filter-counts ] <filter> ] [ sort>> ] bi* <sort> ;
: match? ( pair/f str -- ? )
swap dup [ first present subseq? ] [ 2drop t ] if ;
-: <profiler-table> ( model -- table )
- [ match? ] <search-table>
- { 0 1 } >>column-alignment
- 0 >>filled-column ;
+: <profiler-table> ( model renderer -- table )
+ [ match? ] <search-table> ;
: <profiler-filter-model> ( counts profiler -- model' )
[ <model> ] dip <profiler-model> [ f prefix ] <filter> ;
:: <words-tab> ( profiler -- gadget )
horizontal <track>
{ 3 3 } >>gap
- profiler vocabs>> <profiler-table>
+ profiler vocabs>>
vocab-renderer <profiler-table>
profiler vocab>> >>selected-value
- vocab-renderer >>renderer
"Vocabularies" <labeled-gadget>
1/2 track-add
- profiler <words-model> <profiler-table>
- word-renderer >>renderer
+ profiler <words-model> word-renderer <profiler-table>
"Words" <labeled-gadget>
1/2 track-add ;
{ 3 3 } >>gap
horizontal <track>
{ 3 3 } >>gap
- profiler <generic-model> <profiler-table>
+ profiler <generic-model>
word-renderer <profiler-table>
profiler generic>> >>selected-value
- word-renderer >>renderer
"Generic words" <labeled-gadget>
1/2 track-add
- profiler <class-model> <profiler-table>
+ profiler <class-model>
word-renderer <profiler-table>
profiler class>> >>selected-value
- word-renderer >>renderer
"Classes" <labeled-gadget>
1/2 track-add
1/2 track-add
- profiler methods>> <profiler-table>
- method-renderer >>renderer
+ profiler methods>> method-renderer <profiler-table>
"Methods" <labeled-gadget>
1/2 track-add ;
M: stack-entry-renderer row-value drop object>> ;
: <stack-table> ( model -- table )
- [ [ <stack-entry> ] map ] <filter> <table>
+ [ [ <stack-entry> ] map ] <filter>
stack-entry-renderer <table>
monospace-font >>font
[ i:inspector ] >>action
- stack-entry-renderer >>renderer
t >>single-click? ;
: <stack-display> ( model quot title -- gadget )
projects / factor.git / commitdiff