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 shufflingdb4
Slava Pestov
parent
ca2c14646e
commit
9f49139057
|
|
@ -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 )
|
||||
[ dup first ] dip = [ nip second ] [ 2drop 0 ] if ;
|
||||
: start-on-line ( from line# document -- n1 )
|
||||
drop over first =
|
||||
[ second ] [ drop 0 ] if ;
|
||||
|
||||
: end-on-line ( document to line# -- n2 )
|
||||
over first over = [
|
||||
drop second nip
|
||||
] [
|
||||
nip swap doc-line length
|
||||
] if ;
|
||||
:: end-on-line ( to line# document -- n2 )
|
||||
to first line# =
|
||||
[ to second ] [ line# document doc-line length ] if ;
|
||||
|
||||
: each-line ( from to quot -- )
|
||||
2over = [
|
||||
3drop
|
||||
] [
|
||||
2over = [ 3drop ] [
|
||||
[ [ first ] bi@ [a,b] ] dip each
|
||||
] if ; inline
|
||||
|
||||
: start/end-on-line ( from to line# -- n1 n2 )
|
||||
[ [ document get ] 2dip start-on-line ]
|
||||
[ [ document get ] 2dip end-on-line ]
|
||||
bi-curry bi* ;
|
||||
: map-lines ( from to quot -- results )
|
||||
accumulator [ each-line ] dip ; inline
|
||||
|
||||
: 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# -- )
|
||||
[ start/end-on-line ] keep document get doc-line <slice> , ;
|
||||
: (doc-range) ( from to line# document -- 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 )
|
||||
[
|
||||
document set 2dup [
|
||||
[ 2dup ] dip (doc-range)
|
||||
] each-line 2drop
|
||||
] { } make "\n" join ;
|
||||
[ 2dup ] dip
|
||||
'[ [ 2dup ] dip _ (doc-range) ] map-lines
|
||||
2nip "\n" join ;
|
||||
|
||||
: add-undo ( edit document -- )
|
||||
dup inside-undo?>> [ 2drop ] [
|
||||
|
|
|
|||
|
|
@ -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
|
||||
sequences strings math.vectors math.functions sorting colors
|
||||
math.ranges models models.filter namespaces locals fry make opengl
|
||||
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 ( -- )
|
||||
editor get [ focused?>> ] [ blink>> ] bi and [
|
||||
editor get
|
||||
: draw-caret? ( editor -- ? )
|
||||
[ focused?>> ] [ blink>> ] bi and ;
|
||||
|
||||
: draw-caret ( editor -- )
|
||||
dup draw-caret? [
|
||||
[ caret-color>> gl-color ]
|
||||
[
|
||||
dup caret-loc origin get v+
|
||||
swap caret-dim over v+
|
||||
gl-line
|
||||
[ caret-loc ] [ caret-dim ] bi
|
||||
over v+ gl-line
|
||||
] bi
|
||||
] when ;
|
||||
|
||||
: 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 ;
|
||||
] [ drop ] if ;
|
||||
|
||||
: selection-start/end ( editor -- start end )
|
||||
[ editor-mark ] [ editor-caret ] bi sort-pair ;
|
||||
|
||||
: (draw-selection) ( x1 x2 -- )
|
||||
over - 1+
|
||||
dup 0 = [ 1+ ] when
|
||||
[ 0.0 2array ] [ editor get line-height 2array ] bi*
|
||||
swap [ gl-fill-rect ] with-translation ;
|
||||
SYMBOL: selected-lines
|
||||
|
||||
: draw-selected-line ( start end n -- )
|
||||
[ start/end-on-line ] keep
|
||||
[ swap 2array editor get loc>x ] curry bi@
|
||||
(draw-selection) ;
|
||||
TUPLE: selected-line start end first? last? ;
|
||||
|
||||
: draw-selection ( -- )
|
||||
editor get selection-color>> gl-color
|
||||
editor get selection-start/end
|
||||
over first [
|
||||
2dup '[
|
||||
[ _ _ ] dip
|
||||
draw-selected-line
|
||||
1 translate-lines
|
||||
] each-line
|
||||
] with-editor-translation ;
|
||||
: compute-selection ( editor -- assoc )
|
||||
[ selection-start/end [ [ first ] bi@ [a,b] ] 2keep ] keep model>>
|
||||
'[ [ _ _ ] keep _ start/end-on-line 2array ] H{ } map>assoc ;
|
||||
|
||||
M: editor draw-line ( line index editor -- )
|
||||
[
|
||||
[ selected-lines get at ] dip
|
||||
'[ first2 _ selection-color>> <selection> ] when*
|
||||
] keep font>> swap { 0 0 } draw-text ;
|
||||
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
sequences ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar
|
||||
math.rectangles math.order math.vectors namespaces opengl sequences
|
||||
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
|
||||
combinators fonts ;
|
||||
ui.gadgets.menus ui.gadgets.line-support math.rectangles models
|
||||
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 >>text-color ;
|
||||
COLOR: black >>mouse-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 -- )
|
||||
[ [ renderer>> row-columns ] [ column-widths>> ] [ column-alignment ] tri ]
|
||||
[ [ renderer>> row-font ] [ font>> swap derive-font ] bi ] 2bi
|
||||
:: row-font ( row index table -- font )
|
||||
table font>> clone
|
||||
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 ]
|
||||
|
|
|
|||
Loading…
Reference in New Issue