Table gadgets work in progress
Slava Pestov
parent
feaac5ae43
commit
d001237921
|
|
@ -0,0 +1,45 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel delegate fry sequences
|
||||
models models.search locals
|
||||
ui.gadgets.editors ui.gadgets.labels ui.gadgets.scrollers
|
||||
ui.gadgets.tables ui.gadgets.tracks ui.gadgets.borders
|
||||
ui.gadgets.buttons ;
|
||||
IN: ui.gadgets.search-tables
|
||||
|
||||
TUPLE: search-field < track field ;
|
||||
|
||||
: clear-search-field ( search-field -- )
|
||||
field>> editor>> clear-editor ;
|
||||
|
||||
: <clear-button> ( search-field -- button )
|
||||
"X" swap '[ drop _ clear-search-field ] <roll-button> ;
|
||||
|
||||
: <search-field> ( model -- gadget )
|
||||
{ 1 0 } search-field new-track
|
||||
{ 5 5 } >>gap
|
||||
"Search:" <label> f track-add
|
||||
swap <model-field> 10 >>min-width >>field
|
||||
dup field>> 1 track-add
|
||||
dup <clear-button> f track-add ;
|
||||
|
||||
TUPLE: search-table < track table field ;
|
||||
|
||||
! We don't want to delegate all slots, just a few setters
|
||||
PROTOCOL: table-protocol
|
||||
renderer>> (>>renderer)
|
||||
selected-value>> (>>selected-value) ;
|
||||
|
||||
CONSULT: table-protocol search-table table>> ;
|
||||
|
||||
:: <search-table> ( values quot -- gadget )
|
||||
f <model> :> search
|
||||
{ 0 1 } search-table new-track
|
||||
values >>model
|
||||
search <search-field> >>field
|
||||
dup field>> 2 <filled-border> f track-add
|
||||
values search quot <search-model> <table> >>table
|
||||
dup table>> <scroller> 1 track-add ;
|
||||
|
||||
M: search-table model-changed
|
||||
nip field>> clear-search-field ;
|
||||
|
|
@ -0,0 +1,48 @@
|
|||
USING: accessors arrays effects help kernel locals models
|
||||
present prettyprint ui ui.gadgets.panes ui.gadgets.scrollers
|
||||
ui.gadgets.tables ui.gadgets.tracks vocabs models.filter
|
||||
ui.gadgets.search-tables sequences fry ;
|
||||
IN: scratchpad
|
||||
|
||||
SINGLETON: word-renderer
|
||||
M: word-renderer row-columns
|
||||
drop
|
||||
[ name>> ] [ stack-effect present ]
|
||||
bi 2array ;
|
||||
|
||||
SINGLETON: vocab-renderer
|
||||
M: vocab-renderer row-columns
|
||||
drop vocab-name
|
||||
1array ;
|
||||
|
||||
: search-vocabs ( vocabs search -- vocabs' )
|
||||
'[ _ swap subseq? ] filter [ >vocab-link ] map ;
|
||||
|
||||
: <vocabs-table> ( in-model -- gadget )
|
||||
vocabs <model> [ search-vocabs ] <search-table>
|
||||
vocab-renderer >>renderer
|
||||
swap >>selected-value
|
||||
"Vocabularies" <labelled-gadget> ;
|
||||
|
||||
: search-words ( words search -- words' )
|
||||
'[ _ swap name>> subseq? ] filter ;
|
||||
|
||||
: <vocab-table> ( out-model in-model -- gadget )
|
||||
[ words natural-sort ] <filter>
|
||||
[ search-words ] <search-table>
|
||||
word-renderer >>renderer
|
||||
swap >>selected-value
|
||||
"Words" <labelled-gadget> ;
|
||||
|
||||
: table-demo ( -- )
|
||||
[let | m [ f <model> ] m' [ f <model> ] |
|
||||
{ 1 0 } <track>
|
||||
{ 0 1 } <track>
|
||||
m <vocabs-table> 1/2 track-add
|
||||
m' m <vocab-table> 1/2 track-add
|
||||
1/3 track-add
|
||||
{ m' m } <compose>
|
||||
[ first2 or [ help ] when* ] <pane-control> <scroller>
|
||||
"Definition" <labelled-gadget> 2/3 track-add
|
||||
"Hi" open-status-window
|
||||
] ;
|
||||
|
|
@ -0,0 +1,213 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays colors fry io.styles kernel locals math
|
||||
math.geometry.rect math.order math.vectors namespaces opengl
|
||||
sequences ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar
|
||||
ui.gadgets.worlds ui.gestures ui.render models math.ranges sequences
|
||||
combinators ;
|
||||
IN: ui.gadgets.tables
|
||||
|
||||
! Row rendererer protocol
|
||||
GENERIC: row-columns ( row renderer -- columns )
|
||||
|
||||
SINGLETON: trivial-renderer
|
||||
|
||||
M: trivial-renderer row-columns drop ;
|
||||
|
||||
TUPLE: table < gadget
|
||||
renderer column-widths total-width
|
||||
font text-color selection-color mouse-color
|
||||
selected-index selected-value
|
||||
mouse-index
|
||||
focused? ;
|
||||
|
||||
: <table> ( rows -- table )
|
||||
table new-gadget
|
||||
swap >>model
|
||||
trivial-renderer >>renderer
|
||||
f <model> >>selected-value
|
||||
{ "sans-serif" plain 12 } >>font
|
||||
T{ rgba f 0.8 0.8 1.0 1.0 } >>selection-color
|
||||
black >>mouse-color
|
||||
black >>text-color ;
|
||||
|
||||
: line-height ( table -- n )
|
||||
font>> open-font "" string-height ;
|
||||
|
||||
CONSTANT: table-gap 5
|
||||
|
||||
: table-rows ( table -- rows )
|
||||
[ control-value ] [ renderer>> ] bi '[ _ row-columns ] map ;
|
||||
|
||||
: column-widths ( font rows -- total widths )
|
||||
[ drop 0 { } ] [
|
||||
tuck [ length 0 <repetition> ] 2dip [
|
||||
[ string-width ] with map vmax
|
||||
] with each
|
||||
0 [ table-gap + + ] accumulate
|
||||
[ table-gap - ] dip
|
||||
] if-empty ;
|
||||
|
||||
: update-cached-widths ( table -- )
|
||||
dup
|
||||
[ font>> open-font ] [ table-rows ] bi column-widths
|
||||
[ >>total-width ] [ >>column-widths ] bi* drop ;
|
||||
|
||||
M: table layout* update-cached-widths ;
|
||||
|
||||
: row-rect ( table row -- rect )
|
||||
[ [ line-height ] dip * 0 swap 2array ]
|
||||
[ drop [ dim>> first ] [ line-height ] bi 2array ] 2bi <rect> ;
|
||||
|
||||
: highlight-row ( table row color filled? -- )
|
||||
[ dup ] 2dip '[
|
||||
_ gl-color
|
||||
row-rect rect-bounds swap [
|
||||
_ [ gl-fill-rect ] [ gl-rect ] if
|
||||
] with-translation
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: draw-selected ( table -- )
|
||||
{
|
||||
[ ]
|
||||
[ selected-index>> ]
|
||||
[ selection-color>> ]
|
||||
[ focused?>> ]
|
||||
} cleave
|
||||
highlight-row ;
|
||||
|
||||
: draw-moused ( table -- )
|
||||
[ ] [ mouse-index>> ] [ mouse-color>> ] tri f highlight-row ;
|
||||
|
||||
: y>row ( y table -- n )
|
||||
line-height /i ;
|
||||
|
||||
: validate-row ( m table -- n )
|
||||
control-value length 1- min 0 max ;
|
||||
|
||||
: first-visible-row ( table -- n )
|
||||
[
|
||||
[ clip get loc>> second origin get second - ] dip
|
||||
y>row
|
||||
] keep validate-row ;
|
||||
|
||||
: last-visible-row ( table -- n )
|
||||
[
|
||||
[ clip get rect-extent nip second origin get second - ] dip
|
||||
y>row
|
||||
] keep validate-row 1+ ;
|
||||
|
||||
: draw-row ( widths columns font -- )
|
||||
'[ [ _ ] [ 0 2array ] [ ] tri* swap draw-string ] 2each ;
|
||||
|
||||
: each-slice-index ( from to seq quot -- )
|
||||
[ [ <slice> ] [ drop [a,b) ] 3bi ] dip 2each ; inline
|
||||
|
||||
:: draw-rows ( table -- )
|
||||
table font>> :> font
|
||||
table line-height :> line-height
|
||||
table text-color>> gl-color
|
||||
table
|
||||
[ first-visible-row ]
|
||||
[ last-visible-row ]
|
||||
[ control-value ] tri [
|
||||
line-height * 0 swap 2array [
|
||||
table column-widths>>
|
||||
swap
|
||||
table renderer>> row-columns
|
||||
font draw-row
|
||||
] with-translation
|
||||
] each-slice-index ;
|
||||
|
||||
M: table draw-gadget*
|
||||
dup control-value empty? [ drop ] [
|
||||
origin get [
|
||||
[ draw-selected ]
|
||||
[ draw-moused ]
|
||||
[ draw-rows ]
|
||||
tri
|
||||
] with-translation
|
||||
] if ;
|
||||
|
||||
M: table pref-dim*
|
||||
dup update-cached-widths
|
||||
[ total-width>> ] [
|
||||
[ font>> open-font "" string-height ]
|
||||
[ control-value length ]
|
||||
bi *
|
||||
] bi 2array ;
|
||||
|
||||
: nth-row ( row table -- value/f )
|
||||
over [ control-value nth ] [ 2drop f ] if ;
|
||||
|
||||
: selected-row ( table -- value/f )
|
||||
[ selected-index>> ] keep nth-row ;
|
||||
|
||||
: update-selected-value ( table -- )
|
||||
[ selected-row ] keep selected-value>> set-model ;
|
||||
|
||||
M: table model-changed
|
||||
nip
|
||||
[ f >>selected-index update-selected-value ]
|
||||
[ relayout ]
|
||||
bi ;
|
||||
|
||||
: thin-row-rect ( table row -- rect )
|
||||
row-rect [ { 0 1 } v* ] change-dim ;
|
||||
|
||||
: (select-row) ( table row -- )
|
||||
over validate-row
|
||||
[ [ thin-row-rect ] [ drop ] 2bi scroll>rect ]
|
||||
[ >>selected-index relayout-1 ]
|
||||
2bi ;
|
||||
|
||||
: mouse-row ( table -- n )
|
||||
[ hand-rel second ] keep y>row ;
|
||||
|
||||
: click-row ( table -- )
|
||||
dup request-focus
|
||||
dup control-value empty?
|
||||
[ drop ] [ dup mouse-row (select-row) ] if ;
|
||||
|
||||
: select-row ( table row -- )
|
||||
[ (select-row) ] [ drop update-selected-value ] 2bi ;
|
||||
|
||||
: prev-row ( table -- )
|
||||
dup selected-index>> 1- select-row ;
|
||||
|
||||
: next-row ( table -- )
|
||||
dup selected-index>> 1+ select-row ;
|
||||
|
||||
: first-row ( table -- )
|
||||
0 select-row ;
|
||||
|
||||
: last-row ( table -- )
|
||||
dup control-value length 1- select-row ;
|
||||
|
||||
: hide-mouse-help ( table -- )
|
||||
f >>mouse-index [ hide-status ] [ relayout-1 ] bi ;
|
||||
|
||||
: show-mouse-help ( table -- )
|
||||
[ mouse-row ] keep
|
||||
2dup control-value length 1- 0 swap between? [
|
||||
[ swap >>mouse-index relayout-1 ]
|
||||
[
|
||||
[ nth-row ] keep
|
||||
over [ show-summary ] [ 2drop ] if
|
||||
] 2bi
|
||||
] [ nip hide-mouse-help ] if ;
|
||||
|
||||
table H{
|
||||
{ T{ mouse-enter } [ show-mouse-help ] }
|
||||
{ T{ mouse-leave } [ hide-mouse-help ] }
|
||||
{ T{ motion } [ show-mouse-help ] }
|
||||
{ T{ button-down } [ click-row ] }
|
||||
{ T{ button-up } [ update-selected-value ] }
|
||||
{ T{ gain-focus } [ t >>focused? drop ] }
|
||||
{ T{ lose-focus } [ f >>focused? drop ] }
|
||||
{ T{ drag } [ click-row ] }
|
||||
{ T{ key-down f f "UP" } [ prev-row ] }
|
||||
{ T{ key-down f f "DOWN" } [ next-row ] }
|
||||
{ T{ key-down f f "HOME" } [ first-row ] }
|
||||
{ T{ key-down f f "END" } [ last-row ] }
|
||||
} set-gestures
|
||||
Loading…
Reference in New Issue