ui.gadgets.editors and ui.gadgets.tables: factor out common code into ui.gadgets.line-support, fix selection rendering

documents: don't use dynamic variables inappropriately, clean up stack shuffling

basis/documents/documents.factor

@@ -46,27 +46,24 @@ TUPLE: document < model locs undos redos inside-undo? ;
 : doc-lines ( from to document -- slice )
     [ 1+ ] [ value>> ] bi* <slice> ;
 
-: start-on-line ( document from line# -- n1 )
+: start-on-line ( from line# document -- n1 )
-    [ dup first ] dip = [ nip second ] [ 2drop 0 ] if ;
+    drop over first =
+    [ second ] [ drop 0 ] if ;
 
-: end-on-line ( document to line# -- n2 )
+:: end-on-line ( to line# document -- n2 )
-    over first over = [
+    to first line# =
-        drop second nip
+    [ to second ] [ line# document doc-line length ] if ;
-    ] [
-        nip swap doc-line length
-    ] if ;
 
 : each-line ( from to quot -- )
-    2over = [
+    2over = [ 3drop ] [
-        3drop
-    ] [
         [ [ first ] bi@ [a,b] ] dip each
     ] if ; inline
 
-: start/end-on-line ( from to line# -- n1 n2 )
+: map-lines ( from to quot -- results )
-    [ [ document get ] 2dip start-on-line ]
+    accumulator [ each-line ] dip ; inline
-    [ [ document get ] 2dip end-on-line ]
+
-    bi-curry bi* ;
+: start/end-on-line ( from to line# document -- n1 n2 )
+    [ start-on-line ] [ end-on-line ] bi-curry bi-curry bi* ;
 
 : last-line# ( document -- line )
     value>> length 1- ;
@@ -78,8 +75,8 @@ CONSTANT: doc-start { 0 0 }
 
 <PRIVATE
 
-: (doc-range) ( from to line# -- )
+: (doc-range) ( from to line# document -- slice )
-    [ start/end-on-line ] keep document get doc-line <slice> , ;
+    [ start/end-on-line ] 2keep doc-line <slice> ;
 
 : text+loc ( lines loc -- loc )
     over [
@@ -117,11 +114,9 @@ CONSTANT: doc-start { 0 0 }
 PRIVATE>
 
 : doc-range ( from to document -- string )
-    [
+    [ 2dup ] dip
-        document set 2dup [
+    '[ [ 2dup ] dip _ (doc-range) ] map-lines
-            [ 2dup ] dip (doc-range)
+    2nip "\n" join ;
-        ] each-line 2drop
-    ] { } make "\n" join ;
 
 : add-undo ( edit document -- )
     dup inside-undo?>> [ 2drop ] [

basis/ui/gadgets/editors/editors.factor

@@ -1,17 +1,18 @@
 ! Copyright (C) 2006, 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays documents documents.elements kernel math
-models models.filter namespaces locals fry make opengl opengl.gl
+math.ranges models models.filter namespaces locals fry make opengl
-sequences strings math.vectors math.functions sorting colors
+opengl.gl sequences strings math.vectors math.functions sorting colors
 colors.constants combinators assocs math.order fry calendar alarms
 continuations ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
 ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
 ui.gadgets.theme ui.gadgets.menus ui.gadgets.wrappers ui.render
-ui.text ui.gestures math.rectangles splitting unicode.categories fonts ;
+ui.gadgets.line-support ui.text ui.gestures math.rectangles splitting
+unicode.categories fonts ;
 IN: ui.gadgets.editors
 
 TUPLE: editor < gadget
-font color caret-color selection-color
+font caret-color selection-color
 caret mark
 focused? blink blink-alarm ;
 
@@ -22,7 +23,6 @@ focused? blink blink-alarm ;
     <loc> >>mark ; inline
 
 : editor-theme ( editor -- editor )
-    COLOR: black >>color
     COLOR: red >>caret-color
     selection-color >>selection-color
     monospace-font >>font ; inline
@@ -101,12 +101,6 @@ M: editor ungraft*
 
 : editor-line ( n editor -- str ) control-value nth ;
 
-: line-height ( editor -- n )
-    font>> "" text-height ;
-
-: y>line ( y editor -- line# )
-    line-height /i ;
-
 :: point>loc ( point editor -- loc )
     point second editor y>line {
         { [ dup 0 < ] [ drop { 0 0 } ] }
@@ -135,9 +129,6 @@ M: editor ungraft*
 : loc>x ( loc editor -- x )
     [ first2 swap ] dip [ editor-line ] [ font>> ] bi swap offset>x round ;
 
-: line>y ( lines# editor -- y )
-    line-height * ;
-
 : loc>point ( loc editor -- loc )
     [ loc>x ] [ [ first ] dip line>y ] 2bi 2array ;
 
@@ -154,90 +145,42 @@ M: editor ungraft*
         ] keep scroll>rect
     ] [ drop ] if ;
 
-: draw-caret ( -- )
+: draw-caret? ( editor -- ? )
-    editor get [ focused?>> ] [ blink>> ] bi and [
+    [ focused?>> ] [ blink>> ] bi and ;
-        editor get
+
+: draw-caret ( editor -- )
+    dup draw-caret? [
         [ caret-color>> gl-color ]
         [
-            dup caret-loc origin get v+
+            [ caret-loc ] [ caret-dim ] bi
-            swap caret-dim over v+
+            over v+ gl-line
-            gl-line
         ] bi
-    ] when ;
+    ] [ drop ] if ;
-
-: line-translation ( n -- loc )
-    editor get line-height * 0.0 swap 2array ;
-
-: translate-lines ( n -- )
-    line-translation gl-translate ;
-
-: draw-line ( editor str -- )
-    [ font>> ] dip { 0 0 } draw-text ;
-
-: first-visible-line ( editor -- n )
-    [
-        [ clip get loc>> second origin get second - ] dip
-        y>line
-    ] keep model>> validate-line ;
-
-: last-visible-line ( editor -- n )
-    [
-        [ clip get rect-extent nip second origin get second - ] dip
-        y>line
-    ] keep model>> validate-line 1+ ;
-
-: with-editor ( editor quot -- )
-    [
-        swap
-        dup first-visible-line \ first-visible-line set
-        dup last-visible-line \ last-visible-line set
-        dup model>> document set
-        editor set
-        call
-    ] with-scope ; inline
-
-: visible-lines ( editor -- seq )
-    [ \ first-visible-line get \ last-visible-line get ] dip
-    control-value <slice> ;
-
-: with-editor-translation ( n quot -- )
-    [ line-translation origin get v+ ] dip with-translation ;
-    inline
-
-: draw-lines ( -- )
-    \ first-visible-line get [
-        editor get dup color>> gl-color
-        dup visible-lines
-        [ draw-line 1 translate-lines ] with each
-    ] with-editor-translation ;
 
 : selection-start/end ( editor -- start end )
     [ editor-mark ] [ editor-caret ] bi sort-pair ;
 
-: (draw-selection) ( x1 x2 -- )
+SYMBOL: selected-lines
-    over - 1+
-    dup 0 = [ 1+ ] when
-    [ 0.0 2array ] [ editor get line-height 2array ] bi*
-    swap [ gl-fill-rect ] with-translation ;
 
-: draw-selected-line ( start end n -- )
+TUPLE: selected-line start end first? last? ;
-    [ start/end-on-line ] keep
-    [ swap 2array editor get loc>x ] curry bi@
-    (draw-selection) ;
 
-: draw-selection ( -- )
+: compute-selection ( editor -- assoc )
-    editor get selection-color>> gl-color
+    [ selection-start/end [ [ first ] bi@ [a,b] ] 2keep ] keep model>>
-    editor get selection-start/end
+    '[ [ _ _ ] keep _ start/end-on-line 2array ] H{ } map>assoc ;
-    over first [
+
-        2dup '[
+M: editor draw-line ( line index editor -- )
-            [ _ _ ] dip
+    [
-            draw-selected-line
+        [ selected-lines get at ] dip
-            1 translate-lines
+        '[ first2 _ selection-color>> <selection> ] when*
-        ] each-line
+    ] keep font>> swap { 0 0 } draw-text ;
-    ] with-editor-translation ;
 
 M: editor draw-gadget*
-    [ draw-selection draw-lines draw-caret ] with-editor ;
+    origin get [
+        [ compute-selection selected-lines set ]
+        [ draw-lines ]
+        [ draw-caret ]
+        tri
+    ] with-translation ;
 
 M: editor pref-dim*
     [ font>> ] [ control-value ] bi text-dim ;

basis/ui/gadgets/tables/tables.factor

@@ -1,18 +1,17 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays colors colors.constants fry kernel math
-math.rectangles math.order math.vectors namespaces opengl
+math.rectangles math.order math.vectors namespaces opengl sequences
-sequences ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar
+ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar
 ui.gadgets.worlds ui.gadgets.theme ui.gestures ui.render ui.text
-ui.gadgets.menus math.rectangles models math.ranges sequences
+ui.gadgets.menus ui.gadgets.line-support math.rectangles models
-combinators fonts ;
+math.ranges sequences combinators fonts locals ;
 IN: ui.gadgets.tables
 
 ! Row rendererer protocol
 GENERIC: row-columns ( row renderer -- columns )
 GENERIC: row-value ( row renderer -- object )
 GENERIC: row-color ( row renderer -- color )
-GENERIC: row-font ( row renderer -- font )
 
 SINGLETON: trivial-renderer
 
@@ -20,13 +19,10 @@ M: trivial-renderer row-columns drop ;
 M: object row-value drop ;
 M: object row-color 2drop f ;
 
-M: object row-font
-    row-color dup [ <font> swap >>foreground ] when ;
-
 TUPLE: table < gadget
 renderer filled-column column-alignment action hook
 column-widths total-width
-font text-color selection-color focus-border-color
+font selection-color focus-border-color
 mouse-color column-line-color selection-required?
 selected-index selected-value
 mouse-index
@@ -43,14 +39,10 @@ focused? ;
         selection-color >>selection-color
         focus-border-color >>focus-border-color
         COLOR: dark-gray >>column-line-color
-        COLOR: black >>mouse-color
+        COLOR: black >>mouse-color ;
-        COLOR: black >>text-color ;
 
 <PRIVATE
 
-: line-height ( table -- n )
-    font>> "" text-height ;
-
 CONSTANT: table-gap 6
 
 : table-rows ( table -- rows )
@@ -125,24 +117,6 @@ M: table layout*
         '[ [ 0 2array ] [ _ 2array ] bi gl-line ] each
     ] bi ;
 
-: y>row ( y table -- n )
-    line-height /i ;
-
-: validate-row ( m table -- n )
-    control-value [ drop f ] [ length 1- min 0 max ] if-empty ;
-
-: visible-row ( table quot -- n )
-    '[
-        [ clip get @ origin get [ second ] bi@ - ] dip
-        y>row
-    ] keep validate-row ; inline
-
-: first-visible-row ( table -- n )
-    [ loc>> ] visible-row ;
-
-: last-visible-row ( table -- n )
-    [ rect-extent nip ] visible-row 1+ ;
-
 : column-loc ( font column width align -- loc )
     [ [ text-width ] dip swap - ] dip
     * 0 2array ;
@@ -156,34 +130,28 @@ M: table layout*
     dup column-alignment>>
     [ ] [ column-widths>> length 0 <repetition> ] ?if ;
 
-: draw-row ( index table -- )
+:: row-font ( row index table -- font )
-    [ [ renderer>> row-columns ] [ column-widths>> ] [ column-alignment ] tri ]
+    table font>> clone
-    [ [ renderer>> row-font ] [ font>> swap derive-font ] bi ] 2bi
+    row table renderer>> row-color [ >>foreground ] when*
+    index table selected-index>> = [ table selection-color>> >>background ] when ;
+
+M: table draw-line ( row index table -- )
+    [
+        nip
+        [ renderer>> row-columns ]
+        [ column-widths>> ]
+        [ column-alignment ]
+        tri
+    ] [ row-font ] 3bi
     '[ [ _ ] 3dip draw-column ] 3each ;
 
-: each-slice-index ( from to seq quot -- )
-    [ [ <slice> ] [ drop [a,b) ] 3bi ] dip 2each ; inline
-
-: draw-rows ( table -- )
-    {
-        [ text-color>> gl-color ]
-        [ first-visible-row ]
-        [ last-visible-row ]
-        [ control-value ]
-        [ line-height ]
-        [ ]
-    } cleave '[
-        [ 0 ] dip _ * 2array
-        [ _ draw-row ] with-translation
-    ] each-slice-index ;
-
 M: table draw-gadget*
     dup control-value empty? [ drop ] [
         origin get [
             {
                 [ draw-selected ]
                 [ draw-columns ]
-                [ draw-rows ]
+                [ draw-lines ]
                 [ draw-moused ]
             } cleave
         ] with-translation
@@ -238,12 +206,12 @@ M: table model-changed
     2bi ;
 
 : mouse-row ( table -- n )
-    [ hand-rel second ] keep y>row ;
+    [ hand-rel second ] keep y>line ;
 
 : table-button-down ( table -- )
     dup request-focus
     dup control-value empty? [ drop ] [
-        dup [ mouse-row ] keep validate-row
+        dup [ mouse-row ] keep validate-line
         [ >>mouse-index ] [ (select-row) ] bi
     ] if ;
 
@@ -259,7 +227,7 @@ PRIVATE>
     [ row-action ] [ update-selected-value ] if ;
 
 : select-row ( table n -- )
-    over validate-row
+    over validate-line
     [ (select-row) ]
     [ drop update-selected-value ]
     [ show-row-summary ]