library/ui/text/editor.factor

   1 ! Copyright (C) 2006 Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: gadgets-text
   4 USING: arrays errors freetype gadgets gadgets-borders
   5 gadgets-buttons gadgets-frames gadgets-labels
   6 gadgets-scrolling gadgets-theme io kernel math models namespaces
   7 opengl sequences strings styles ;
   8
   9 TUPLE: editor
  10 font color caret-color selection-color
  11 caret mark
  12 focused? ;
  13
  14 TUPLE: loc-monitor editor ;
  15
  16 : <loc> ( editor -- loc )
  17     <loc-monitor> { 0 0 } <model> [ add-connection ] keep ;
  18
  19 : init-editor-locs ( editor -- )
  20     dup <loc> over set-editor-caret
  21     dup <loc> swap set-editor-mark ;
  22
  23 C: editor ( -- editor )
  24     dup <document> <gadget> delegate>control
  25     dup init-editor-locs
  26     dup editor-theme ;
  27
  28 : activate-editor-model ( editor model -- )
  29     dup activate-model swap control-model add-loc ;
  30
  31 : deactivate-editor-model ( editor model -- )
  32     dup deactivate-model swap control-model remove-loc ;
  33
  34 M: editor graft*
  35     dup dup editor-caret activate-editor-model
  36     dup dup editor-mark activate-editor-model
  37     dup control-self swap control-model add-connection ;
  38
  39 M: editor ungraft*
  40     dup dup editor-caret deactivate-editor-model
  41     dup dup editor-mark deactivate-editor-model
  42     dup control-self swap control-model remove-connection ;
  43
  44 M: editor model-changed
  45     control-self dup control-model
  46     over editor-caret [ over validate-loc ] (change-model)
  47     over editor-mark [ over validate-loc ] (change-model)
  48     drop relayout ;
  49
  50 : editor-caret* editor-caret model-value ;
  51
  52 : editor-mark* editor-mark model-value ;
  53
  54 : change-caret ( editor quot -- )
  55     over >r >r dup editor-caret* swap control-model r> call r>
  56     [ control-model validate-loc ] keep
  57     editor-caret set-model* ; inline
  58
  59 : mark>caret ( editor -- )
  60     dup editor-caret* swap editor-mark set-model* ;
  61
  62 : change-caret&mark ( editor quot -- )
  63     over >r change-caret r> mark>caret ; inline
  64
  65 : editor-line ( n editor -- str ) control-value nth ;
  66
  67 : editor-font* ( editor -- font ) editor-font lookup-font ;
  68
  69 : line-height ( editor -- n )
  70     editor-font* font-height ;
  71
  72 : run-char-widths ( str editor -- wlist )
  73     #! List of x co-ordinates of each character.
  74     editor-font* swap >array [ char-width ] map-with
  75     dup 0 [ + ] accumulate nip swap 2 v/n v+ ;
  76
  77 : x>offset ( x line# editor -- col# )
  78     [ editor-line ] keep
  79     over >r run-char-widths [ <= ] find-with drop dup -1 =
  80     [ drop r> length ] [ r> drop ] if ;
  81
  82 : y>line ( y editor -- line# )
  83     [ line-height / >fixnum ] keep control-model validate-line ;
  84
  85 : point>loc ( point editor -- loc )
  86     over second over y>line [
  87         >r >r first r> r> swap x>offset
  88     ] keep swap 2array ;
  89
  90 : click-loc ( editor model -- )
  91     >r [ hand-rel ] keep point>loc r> set-model* ;
  92
  93 : focus-editor ( editor -- )
  94     t over set-editor-focused? relayout-1 ;
  95
  96 : unfocus-editor ( editor -- )
  97     f over set-editor-focused? relayout-1 ;
  98
  99 : (offset>x) ( font col# str -- x )
 100     swap head-slice string-width ;
 101
 102 : offset>x ( col# line# editor -- x )
 103     [ editor-line ] keep editor-font* -rot (offset>x) ;
 104
 105 : loc>x ( loc editor -- x ) >r first2 swap r> offset>x ;
 106
 107 : line>y ( lines# editor -- y )
 108     line-height * ;
 109
 110 : caret-loc ( editor -- loc )
 111     [ editor-caret* ] keep 2dup loc>x
 112     rot first rot line>y 2array ;
 113
 114 : caret-dim ( editor -- dim )
 115     line-height 1 swap 2array ;
 116
 117 : caret-rect ( editor -- dim )
 118     dup caret-loc swap caret-dim <rect> ;
 119
 120 : scroll>caret ( editor -- )
 121     dup gadget-grafted? [
 122         dup caret-rect over scroll>rect
 123     ] when drop ;
 124
 125 M: loc-monitor model-changed
 126     loc-monitor-editor control-self
 127     dup relayout-1 scroll>caret ;
 128
 129 : draw-caret ( -- )
 130     editor get editor-focused? [
 131         editor get
 132         dup editor-caret-color gl-color
 133         caret-rect rect-extent gl-line
 134     ] when ;
 135
 136 : translate-lines ( n -- )
 137     editor get line-height * 0.0 swap 0.0 glTranslated ;
 138
 139 : draw-line ( editor str -- )
 140     over editor-color gl-color
 141     >r editor-font r> draw-string ;
 142
 143 : first-visible-line ( editor -- n )
 144     clip get rect-loc second origin get second -
 145     swap y>line ;
 146
 147 : last-visible-line ( editor -- n )
 148     clip get rect-extent nip second origin get second -
 149     swap y>line 1+ ;
 150
 151 : with-editor ( editor quot -- )
 152     [
 153         swap
 154         dup first-visible-line \ first-visible-line set
 155         dup last-visible-line \ last-visible-line set
 156         dup control-model document set
 157         editor set
 158         call
 159     ] with-scope ; inline
 160
 161 : visible-lines ( editor -- seq )
 162     \ first-visible-line get
 163     \ last-visible-line get
 164     rot control-value <slice> ;
 165
 166 : draw-lines ( -- )
 167     GL_MODELVIEW [
 168         \ first-visible-line get translate-lines
 169         editor get dup visible-lines
 170         [ draw-line 1 translate-lines ] each-with
 171     ] do-matrix ;
 172
 173 : selection-start/end ( editor -- start end )
 174     dup editor-mark* swap editor-caret*
 175     2dup <=> 0 > [ swap ] when ;
 176
 177 : (draw-selection) ( x1 x2 -- )
 178     2dup = [ 2 + ] when
 179     0.0 swap editor get line-height glRectd ;
 180
 181 : draw-selected-line ( start end n -- )
 182     [ start/end-on-line ] keep tuck
 183     >r >r editor get offset>x r> r>
 184     editor get offset>x
 185     (draw-selection) ;
 186
 187 : draw-selection ( -- )
 188     GL_MODELVIEW [
 189         editor get
 190         dup editor-selection-color gl-color
 191         selection-start/end
 192         over first translate-lines
 193         2dup [
 194             >r 2dup r> draw-selected-line
 195             1 translate-lines
 196         ] each-line 2drop
 197     ] do-matrix ;
 198
 199 M: editor draw-gadget*
 200     [ draw-selection draw-lines draw-caret ] with-editor ;
 201
 202 : editor-height ( editor -- n )
 203     [ control-value length ] keep line>y ;
 204
 205 : editor-width ( editor -- n )
 206     0 swap dup editor-font* swap control-value
 207     [ string-width max ] each-with ;
 208
 209 M: editor pref-dim*
 210     dup editor-width swap editor-height 2array ;
 211
 212 M: editor gadget-selection?
 213     selection-start/end = not ;
 214
 215 M: editor gadget-selection
 216     [ selection-start/end ] keep control-model doc-range ;
 217
 218 : remove-editor-selection ( editor -- )
 219     [ selection-start/end ] keep control-model
 220     remove-doc-range ;
 221
 222 M: editor user-input*
 223     [ selection-start/end ] keep control-model set-doc-range t ;
 224
 225 : editor-text ( editor -- str )
 226     control-model doc-text ;
 227
 228 : set-editor-text ( str editor -- )
 229     control-model set-doc-text ;
 230
 231 ! Editors support the stream output protocol
 232 M: editor stream-write1 >r ch>string r> stream-write ;
 233
 234 M: editor stream-write control-self user-input ;
 235
 236 M: editor stream-close drop ;