diff --git a/basis/documents/documents.factor b/basis/documents/documents.factor index fb1d2b2406..451c912779 100644 --- a/basis/documents/documents.factor +++ b/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* ; -: 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 } , ; +: (doc-range) ( from to line# document -- slice ) + [ start/end-on-line ] 2keep doc-line ; : 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 ] [ diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index c94f6ef583..625c80817c 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/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 -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 ; >>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 ; - -: 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>> ] 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 ; diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor index 1cdea14588..ef509e2e13 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/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 -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 [ 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 ; > "" 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 ] ?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 -- ) - [ [ ] [ 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 ]