-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays colors fry io.styles kernel locals math
+USING: accessors arrays colors fry io.styles kernel 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
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? ;
+renderer filled-column column-alignment
+column-widths total-width
+font text-color selection-color mouse-color
+selected-index selected-value
+mouse-index
+focused? ;
: <table> ( rows -- table )
table new-gadget
black >>mouse-color
black >>text-color ;
+<PRIVATE
+
: line-height ( table -- n )
font>> open-font "" string-height ;
: table-rows ( table -- rows )
[ control-value ] [ renderer>> ] bi '[ _ row-columns ] map ;
-: column-widths ( font rows -- total widths )
+: column-offsets ( table -- xs )
+ 0 [ table-gap + + ] accumulate nip ;
+
+: (compute-column-widths) ( font rows -- total widths )
[ drop 0 { } ] [
- tuck [ first length 0 <repetition> ] 2dip [
- [ string-width ] with map vmax
- ] with each
- 0 [ table-gap + + ] accumulate
- [ table-gap - ] dip
+ tuck [ first length 0 <repetition> ] 2dip
+ [ [ string-width ] with map vmax ] with each
+ [ [ sum ] [ length 1 [-] table-gap * ] bi + ] keep
] if-empty ;
+: compute-column-widths ( table -- total-width column-widths )
+ [ font>> open-font ] [ table-rows ] bi (compute-column-widths) ;
+
: update-cached-widths ( table -- )
- dup
- [ font>> open-font ] [ table-rows ] bi column-widths
- [ >>total-width ] [ >>column-widths ] bi* drop ;
+ dup compute-column-widths
+ [ >>total-width ] [ >>column-widths ] bi*
+ drop ;
+
+: filled-column-width ( table -- n )
+ [ dim>> first ] [ total-width>> ] bi [-] ;
+
+: update-filled-column ( table -- )
+ [ filled-column-width ]
+ [ filled-column>> ]
+ [ column-widths>> ] tri
+ 2dup empty? not and
+ [ [ + ] change-nth ] [ 3drop ] if ;
-M: table layout* update-cached-widths ;
+M: table layout*
+ [ update-cached-widths ] [ update-filled-column ] bi ;
: row-rect ( table row -- rect )
[ [ line-height ] dip * 0 swap 2array ]
y>row
] keep validate-row 1+ ;
-: draw-row ( widths columns font -- )
- '[ [ _ ] [ 0 2array ] [ ] tri* swap draw-string ] 2each ;
+: column-loc ( font column width align -- loc )
+ [ [ [ open-font ] dip string-width ] dip swap - ] dip
+ * 0 2array ;
+
+: draw-column ( font column width align -- )
+ over [
+ [ 2dup ] 2dip column-loc draw-string
+ ] dip table-gap + 0 2array gl-translate ;
+
+: draw-row ( columns widths align font -- )
+ '[ [ _ ] 3dip draw-column ] 3each ;
: 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
+: column-alignment ( table -- seq )
+ dup column-alignment>>
+ [ ] [ column-widths>> length 0 <repetition> ] ?if ;
+
+: draw-rows ( table -- )
+ {
+ [ text-color>> gl-color ]
+ [ first-visible-row ]
+ [ last-visible-row ]
+ [ control-value ]
+ [ line-height ]
+ [ renderer>> ]
+ [ column-widths>> ]
+ [ column-alignment ]
+ [ font>> ]
+ } cleave '[
+ [ 0 ] dip _ * 2array [
+ _ row-columns _ _ _ draw-row
] with-translation
] each-slice-index ;
] if ;
M: table pref-dim*
- dup update-cached-widths
- [ total-width>> ] [
- [ font>> open-font "" string-height ]
- [ control-value length ]
- bi *
- ] bi 2array ;
+ [ compute-column-widths drop ] keep
+ [ font>> open-font "" string-height ]
+ [ control-value length ]
+ bi * 2array ;
: nth-row ( row table -- value/f )
over [ control-value nth ] [ 2drop f ] if ;
{ T{ key-down f f "HOME" } [ first-row ] }
{ T{ key-down f f "END" } [ last-row ] }
} set-gestures
+
+PRIVATE>
\ No newline at end of file
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: ui.tools.workspace kernel quotations accessors fry
-assocs present math math.order math.vectors arrays locals
+assocs present math.order math.vectors arrays locals
models.search models.sort models sequences vocabs
tools.profiler ui ui.commands ui.gadgets ui.gadgets.panes
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
ui.gadgets.buttons ui.gadgets.tables ui.gadgets.search-tables
ui.gadgets.labelled ui.gadgets.buttons ui.gadgets.packs
-ui.gadgets.labels ui.gadgets.tabbed words ;
+ui.gadgets.labels ui.gadgets.tabbed words prettyprint ;
FROM: models.filter => <filter> ;
FROM: models.compose => <compose> ;
IN: ui.tools.profiler
methods
generic class ;
-SINGLETON: profile-renderer
+SINGLETON: word-renderer
! Value is a { word count } pair
-M: profile-renderer row-columns
+M: word-renderer row-columns
drop [ [ present ] map ] [ { "All" "" } ] if* ;
+SINGLETON: method-renderer
+
+! Value is a { method-body count } pair
+M: method-renderer row-columns
+ drop [ first synopsis ] [ second present ] bi 2array ;
+
: <profiler-model> ( values profiler -- model )
[ [ filter-counts ] <filter> ] [ sort>> ] bi* <sort> ;
swap dup [ first present subseq? ] [ 2drop t ] if ;
: <profiler-table> ( model -- table )
- [ match? ] <search-table> profile-renderer >>renderer ;
+ [ match? ] <search-table>
+ word-renderer >>renderer
+ { 0 1 } >>column-alignment
+ 0 >>filled-column ;
: <profiler-filter-model> ( counts profiler -- model' )
[ <model> ] dip <profiler-model> [ f prefix ] <filter> ;
3bi and ;
: <methods-model> ( profiler -- model )
- [ method-counters <model> ] dip
- [ generic>> ] [ class>> ] bi 3array <compose>
- [ first3 '[ _ _ method-matches? ] filter ] <filter> ;
+ [
+ [ method-counters <model> ] dip
+ [ generic>> ] [ class>> ] bi 3array <compose>
+ [ first3 '[ _ _ method-matches? ] filter ] <filter>
+ ] keep <profiler-model> ;
: sort-options ( -- alist )
{
1/2 track-add
1/2 track-add
profiler methods>> <profiler-table>
+ method-renderer >>renderer
"Methods" <labelled-gadget>
1/2 track-add ;