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