! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays documents documents.elements kernel math
-math.ranges models models.filter namespaces locals fry make opengl
+math.ranges models models.arrow namespaces locals fry make opengl
opengl.gl sequences strings math.vectors math.functions sorting colors
-colors.constants combinators assocs math.order fry calendar alarms
+colors.constants combinators assocs math.order 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.pens.solid ui.gadgets.line-support ui.text ui.gestures
-math.rectangles splitting unicode.categories fonts ;
+ui.gadgets.menus ui.gadgets.wrappers ui.render ui.pens.solid
+ui.gadgets.line-support ui.text ui.gestures ui.baseline-alignment
+math.rectangles splitting unicode.categories grouping ;
+EXCLUDE: fonts => selection ;
IN: ui.gadgets.editors
-TUPLE: editor < gadget
-font caret-color selection-color
+TUPLE: editor < line-gadget
+caret-color
caret mark
focused? blink blink-alarm ;
: editor-theme ( editor -- editor )
COLOR: red >>caret-color
- selection-color >>selection-color
monospace-font >>font ; inline
: new-editor ( class -- editor )
- new-gadget
+ new-line-gadget
<document> >>model
init-editor-locs
editor-theme ; inline
[ first2 swap ] dip [ editor-line ] [ font>> ] bi swap offset>x round ;
: loc>point ( loc editor -- loc )
- [ loc>x ] [ [ first ] dip line>y ] 2bi 2array ;
+ [ loc>x ] [ [ first ] dip line>y ceiling ] 2bi 2array ;
: caret-loc ( editor -- loc )
[ editor-caret ] keep loc>point ;
: scroll>caret ( editor -- )
dup graft-state>> second [
[
- [ caret-loc ] [ caret-dim { 1 0 } v+ ] bi <rect>
+ [ caret-loc ] [ caret-dim { 2 1 } v+ ] bi <rect>
] keep scroll>rect
] [ drop ] if ;
TUPLE: selected-line start end first? last? ;
: compute-selection ( editor -- assoc )
- [ selection-start/end [ [ first ] bi@ [a,b] ] 2keep ] keep model>>
- '[ [ _ _ ] keep _ start/end-on-line 2array ] H{ } map>assoc ;
+ dup gadget-selection? [
+ [ selection-start/end [ [ first ] bi@ [a,b] ] 2keep ] keep model>>
+ '[ [ _ _ ] keep _ start/end-on-line 2array ] H{ } map>assoc
+ ] [ drop f ] if ;
+
+:: draw-selection ( line pair editor -- )
+ pair [ editor font>> line offset>x ] map :> pair
+ editor selection-color>> gl-color
+ pair first 0 2array
+ pair second pair first - round 1 max editor line-height 2array
+ gl-fill-rect ;
+
+: draw-unselected-line ( line editor -- )
+ font>> swap draw-text ;
+
+: draw-selected-line ( line pair editor -- )
+ over all-equal? [
+ [ nip draw-unselected-line ] [ draw-selection ] 3bi
+ ] [
+ [ draw-selection ]
+ [
+ [ [ first2 ] [ selection-color>> ] bi* <selection> ] keep
+ draw-unselected-line
+ ] 3bi
+ ] if ;
M: editor draw-line ( line index editor -- )
- [
- [ selected-lines get at ] dip
- '[ first2 _ selection-color>> <selection> ] when*
- ] keep font>> swap draw-text ;
+ [ selected-lines get at ] dip over
+ [ draw-selected-line ] [ nip draw-unselected-line ] if ;
M: editor draw-gadget*
dup compute-selection selected-lines [
] with-variable ;
M: editor pref-dim*
- [ font>> ] [ control-value ] bi text-dim ;
+ ! Add some space for the caret.
+ [ font>> ] [ control-value ] bi text-dim { 1 0 } v+ ;
-M: editor baseline
- font>> "" line-metrics ascent>> ;
+M: editor baseline font>> font-metrics ascent>> ;
+
+M: editor cap-height font>> font-metrics cap-height>> ;
: contents-changed ( model editor -- )
swap
{ T{ key-down f { A+ } "BACKSPACE" } delete-to-end-of-line }
} define-command-map
-: paste ( editor -- ) clipboard get paste-clipboard ;
+: com-paste ( editor -- ) clipboard get paste-clipboard ;
: paste-selection ( editor -- ) selection get paste-clipboard ;
-: cut ( editor -- ) clipboard get editor-cut ;
+: com-cut ( editor -- ) clipboard get editor-cut ;
editor "clipboard" f {
- { paste-action paste }
+ { cut-action com-cut }
{ copy-action com-copy }
- { cut-action cut }
- { T{ button-up f f 2 } paste-selection }
+ { paste-action com-paste }
{ T{ button-up } com-copy-selection }
+ { T{ button-up f f 2 } paste-selection }
} define-command-map
: previous-character ( editor -- )
} define-command-map
: clear-editor ( editor -- )
- #! The with-datastack is a kludge to make it infer. Stupid.
- model>> 1array [ clear-doc ] with-datastack drop ;
+ model>> clear-doc ;
: select-all ( editor -- ) doc-elt select-elt ;
editor "selection" f {
{ T{ button-down f { S+ } 1 } extend-selection }
+ { T{ button-up f { S+ } 1 } com-copy-selection }
{ T{ drag } drag-selection }
{ gain-focus focus-editor }
{ lose-focus unfocus-editor }
} define-command-map
: editor-menu ( editor -- )
- { com-undo com-redo cut com-copy paste } show-commands-menu ;
+ {
+ com-undo
+ com-redo
+ ----
+ com-cut
+ com-copy
+ com-paste
+ } show-commands-menu ;
editor "misc" f {
{ T{ button-down f f 3 } editor-menu }
: next-line ( editor -- ) line-elt editor-next ;
-: select-previous-line ( editor -- )
- line-elt editor-select-prev ;
+<PRIVATE
-: select-next-line ( editor -- )
- line-elt editor-select-next ;
+: page-elt ( editor -- editor element ) dup visible-lines 1 - <page-elt> ;
+
+PRIVATE>
+
+: previous-page ( editor -- ) page-elt editor-prev ;
+
+: next-page ( editor -- ) page-elt editor-next ;
+
+: select-previous-line ( editor -- ) line-elt editor-select-prev ;
+
+: select-next-line ( editor -- ) line-elt editor-select-next ;
+
+: select-previous-page ( editor -- ) page-elt editor-select-prev ;
+
+: select-next-page ( editor -- ) page-elt editor-select-next ;
: insert-newline ( editor -- )
"\n" swap user-input* drop ;
: this-line-and-next ( document line -- start end )
[ nip 0 swap 2array ]
- [ [ nip 1+ ] [ 1+ swap doc-line length ] 2bi 2array ]
+ [ [ nip 1 + ] [ 1 + swap doc-line length ] 2bi 2array ]
2bi ;
: last-line? ( document line -- ? )
{ T{ key-down f f "DOWN" } next-line }
{ T{ key-down f { S+ } "UP" } select-previous-line }
{ T{ key-down f { S+ } "DOWN" } select-next-line }
+ { T{ key-down f f "PAGE_UP" } previous-page }
+ { T{ key-down f f "PAGE_DOWN" } next-page }
+ { T{ key-down f { S+ } "PAGE_UP" } select-previous-page }
+ { T{ key-down f { S+ } "PAGE_DOWN" } select-next-page }
{ T{ key-down f f "RET" } insert-newline }
{ T{ key-down f { S+ } "RET" } insert-newline }
{ T{ key-down f f "ENTER" } insert-newline }
! A useful model
: <element-model> ( editor element -- model )
[ [ caret>> ] [ model>> ] bi ] dip
- '[ _ _ elt-string ] <filter> ;
+ '[ _ _ elt-string ] <arrow> ;
! Fields wrap an editor
-TUPLE: field < wrapper editor min-width max-width ;
+TUPLE: field < border editor min-cols max-cols ;
: field-theme ( gadget -- gadget )
+ { 2 2 } >>size
+ { 1 0 } >>fill
COLOR: gray <solid> >>boundary ; inline
: <field-border> ( gadget -- border )
field-theme ;
: new-field ( class -- gadget )
- [ <editor> dup <field-border> ] dip new-wrapper swap >>editor ; inline
+ [ <editor> ] dip new-border
+ dup gadget-child >>editor
+ field-theme ; inline
-: column-width ( editor n -- width )
- [ editor>> font>> ] [ CHAR: \s <string> ] bi* text-width ;
+! For line-gadget-width
+M: field font>> editor>> font>> ;
M: field pref-dim*
- [ call-next-method ]
- [ dup min-width>> dup [ column-width 0 2array vmax ] [ 2drop ] if ]
- [ dup max-width>> dup [ column-width 1/0. 2array vmin ] [ 2drop ] if ]
- tri ;
+ dup
+ [ editor>> pref-dim ] keep
+ [ line-gadget-width ] [ drop second ] 2bi 2array
+ border-pref-dim ;
TUPLE: model-field < field field-model ;
[ editor>> editor-string ]
[ editor>> clear-editor ]
[ quot>> ]
- tri call ;
+ tri call( string -- ) ;
action-field H{
{ T{ key-down f f "RET" } [ invoke-action-field ] }
projects / factor.git / blobdiff