From d0012379219fc181be24b2caa0f1da9d71100615 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 19 Dec 2008 02:37:40 -0600
Subject: [PATCH] Table gadgets work in progress

---
 .../search-tables/search-tables.factor        |  45 ++++
 basis/ui/gadgets/tables/table-demo.factor     |  48 ++++
 basis/ui/gadgets/tables/tables.factor         | 213 ++++++++++++++++++
 3 files changed, 306 insertions(+)
 create mode 100644 basis/ui/gadgets/search-tables/search-tables.factor
 create mode 100644 basis/ui/gadgets/tables/table-demo.factor
 create mode 100644 basis/ui/gadgets/tables/tables.factor

diff --git a/basis/ui/gadgets/search-tables/search-tables.factor b/basis/ui/gadgets/search-tables/search-tables.factor
new file mode 100644
index 0000000000..6110657542
--- /dev/null
+++ b/basis/ui/gadgets/search-tables/search-tables.factor
@@ -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 ;
\ No newline at end of file
diff --git a/basis/ui/gadgets/tables/table-demo.factor b/basis/ui/gadgets/tables/table-demo.factor
new file mode 100644
index 0000000000..3de370126e
--- /dev/null
+++ b/basis/ui/gadgets/tables/table-demo.factor
@@ -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
+    ] ;
\ No newline at end of file
diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor
new file mode 100644
index 0000000000..8122a2d6a8
--- /dev/null
+++ b/basis/ui/gadgets/tables/tables.factor
@@ -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