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 0 swap 2array ;
 116
 117 : scroll>caret ( editor -- )
 118     dup gadget-grafted? [
 119         dup caret-loc over caret-dim { 1 0 } v+ <rect>
 120         over scroll>rect
 121     ] when drop ;
 122
 123 M: loc-monitor model-changed
 124     loc-monitor-editor control-self
 125     dup relayout-1 scroll>caret ;
 126
 127 : draw-caret ( -- )
 128     editor get editor-focused? [
 129         editor get
 130         dup editor-caret-color gl-color
 131         dup caret-loc origin get v+
 132         swap caret-dim over v+ gl-line
 133     ] when ;
 134
 135 : line-translation ( n -- loc )
 136     editor get line-height * 0.0 swap 2array ;
 137
 138 : translate-lines ( n -- )
 139     line-translation gl-translate ;
 140
 141 : draw-line ( editor str -- )
 142     >r dup editor-color gl-color editor-font r>
 143     { 0 0 } draw-string ;
 144
 145 : first-visible-line ( editor -- n )
 146     clip get rect-loc second origin get second -
 147     swap y>line ;
 148
 149 : last-visible-line ( editor -- n )
 150     clip get rect-extent nip second origin get second -
 151     swap y>line 1+ ;
 152
 153 : with-editor ( editor quot -- )
 154     [
 155         swap
 156         dup first-visible-line \ first-visible-line set
 157         dup last-visible-line \ last-visible-line set
 158         dup control-model document set
 159         editor set
 160         call
 161     ] with-scope ; inline
 162
 163 : visible-lines ( editor -- seq )
 164     \ first-visible-line get
 165     \ last-visible-line get
 166     rot control-value <slice> ;
 167
 168 : with-editor-translation ( n quot -- )
 169     >r line-translation origin get v+ r> with-translation ;
 170     inline
 171
 172 : draw-lines ( -- )
 173     \ first-visible-line get [
 174         editor get dup visible-lines
 175         [ draw-line 1 translate-lines ] each-with
 176     ] with-editor-translation ;
 177
 178 : selection-start/end ( editor -- start end )
 179     dup editor-mark* swap editor-caret*
 180     2dup <=> 0 > [ swap ] when ;
 181
 182 : (draw-selection) ( x1 x2 -- )
 183     2dup = [ 2 + ] when
 184     0.0 swap editor get line-height glRectd ;
 185
 186 : draw-selected-line ( start end n -- )
 187     [ start/end-on-line ] keep tuck
 188     >r >r editor get offset>x r> r>
 189     editor get offset>x
 190     (draw-selection) ;
 191
 192 : draw-selection ( -- )
 193     editor get editor-selection-color gl-color
 194     editor get selection-start/end
 195     over first [
 196         2dup [
 197             >r 2dup r> draw-selected-line
 198             1 translate-lines
 199         ] each-line 2drop
 200     ] with-editor-translation ;
 201
 202 M: editor draw-gadget*
 203     [ draw-selection draw-lines draw-caret ] with-editor ;
 204
 205 : editor-height ( editor -- n )
 206     [ control-value length ] keep line>y ;
 207
 208 : editor-width ( editor -- n )
 209     0 swap dup editor-font* swap control-value
 210     [ string-width max ] each-with ;
 211
 212 M: editor pref-dim*
 213     dup editor-width swap editor-height 2array ;
 214
 215 M: editor gadget-selection?
 216     selection-start/end = not ;
 217
 218 M: editor gadget-selection
 219     [ selection-start/end ] keep control-model doc-range ;
 220
 221 : remove-editor-selection ( editor -- )
 222     [ selection-start/end ] keep control-model
 223     remove-doc-range ;
 224
 225 M: editor user-input*
 226     [ selection-start/end ] keep control-model set-doc-range t ;
 227
 228 : editor-text ( editor -- str )
 229     control-model doc-text ;
 230
 231 : set-editor-text ( str editor -- )
 232     control-model set-doc-text ;
 233
 234 ! Editors support the stream output protocol
 235 M: editor stream-write1 >r ch>string r> stream-write ;
 236
 237 M: editor stream-write control-self user-input ;
 238
 239 M: editor stream-close drop ;