extra/documents/documents.factor

   1 ! Copyright (C) 2006, 2007 Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays io kernel math models namespaces sequences strings
   4 splitting io.streams.lines combinators ;
   5 IN: documents
   6
   7 : +col ( loc n -- newloc ) >r first2 r> + 2array ;
   8
   9 : +line ( loc n -- newloc ) >r first2 swap r> + swap 2array ;
  10
  11 : =col ( n loc -- newloc ) first swap 2array ;
  12
  13 : =line ( n loc -- newloc ) second 2array ;
  14
  15 : lines-equal? ( loc1 loc2 -- ? ) [ first ] 2apply number= ;
  16
  17 TUPLE: document locs ;
  18
  19 : <document> ( -- document )
  20     V{ "" } clone <model> V{ } clone
  21     { set-delegate set-document-locs } document construct ;
  22
  23 : add-loc document-locs push ;
  24
  25 : remove-loc document-locs delete ;
  26
  27 : update-locs ( loc document -- )
  28     document-locs [ set-model ] curry* each ;
  29
  30 : doc-line ( n document -- string ) model-value nth ;
  31
  32 : doc-lines ( from to document -- slice )
  33     >r 1+ r> model-value <slice> ;
  34
  35 : start-on-line ( document from line# -- n1 )
  36     >r dup first r> = [ nip second ] [ 2drop 0 ] if ;
  37
  38 : end-on-line ( document to line# -- n2 )
  39     over first over = [
  40         drop second nip
  41     ] [
  42         nip swap doc-line length
  43     ] if ;
  44
  45 : each-line ( from to quot -- )
  46     pick pick = [
  47         3drop
  48     ] [
  49         >r [ first ] 2apply 1+ dup <slice> r> each
  50     ] if ; inline
  51
  52 : start/end-on-line ( from to line# -- n1 n2 )
  53     tuck >r >r document get -rot start-on-line r> r>
  54     document get -rot end-on-line ;
  55
  56 : (doc-range) ( from to line# -- )
  57     [ start/end-on-line ] keep document get doc-line <slice> , ;
  58
  59 : doc-range ( from to document -- string )
  60     [
  61         document set 2dup [
  62             >r 2dup r> (doc-range)
  63         ] each-line 2drop
  64     ] { } make "\n" join ;
  65
  66 : text+loc ( lines loc -- loc )
  67     over >r over length 1 = [
  68         nip first2
  69     ] [
  70         first swap length 1- + 0
  71     ] if r> peek length + 2array ;
  72
  73 : prepend-first ( str seq -- )
  74     0 swap [ append ] change-nth ;
  75
  76 : append-last ( str seq -- )
  77     [ length 1- ] keep [ swap append ] change-nth ;
  78
  79 : loc-col/str ( loc document -- str col )
  80     >r first2 swap r> nth swap ;
  81
  82 : prepare-insert ( newinput from to lines -- newinput )
  83     tuck loc-col/str tail-slice >r loc-col/str head-slice r>
  84     pick append-last over prepend-first ;
  85
  86 : (set-doc-range) ( newlines from to lines -- )
  87     [ prepare-insert ] 3keep
  88     >r [ first ] 2apply 1+ r>
  89     replace-slice ;
  90
  91 : set-doc-range ( string from to document -- )
  92     [
  93         >r >r >r string-lines r> [ text+loc ] 2keep r> r>
  94         [ [ (set-doc-range) ] keep ] change-model
  95     ] keep update-locs ;
  96
  97 : remove-doc-range ( from to document -- )
  98     >r >r >r "" r> r> r> set-doc-range ;
  99
 100 : last-line# ( document -- line )
 101     model-value length 1- ;
 102
 103 : validate-line ( line document -- line )
 104     last-line# min 0 max ;
 105
 106 : validate-col ( col line document -- col )
 107     doc-line length min 0 max ;
 108
 109 : line-end ( line# document -- loc )
 110     dupd doc-line length 2array ;
 111
 112 : line-end? ( loc document -- ? )
 113     >r first2 swap r> doc-line length = ;
 114
 115 : doc-end ( document -- loc )
 116     [ last-line# ] keep line-end ;
 117
 118 : validate-loc ( loc document -- newloc )
 119     over first over model-value length >= [
 120         nip doc-end
 121     ] [
 122         over first 0 < [
 123             2drop { 0 0 }
 124         ] [
 125             >r first2 swap tuck r> validate-col 2array
 126         ] if
 127     ] if ;
 128
 129 : doc-string ( document -- str )
 130     model-value "\n" join ;
 131
 132 : set-doc-string ( string document -- )
 133     >r string-lines V{ } like r> [ set-model ] keep
 134     dup doc-end swap update-locs ;
 135
 136 : clear-doc ( document -- )
 137     "" swap set-doc-string ;
 138
 139 GENERIC: prev-elt ( loc document elt -- newloc )
 140 GENERIC: next-elt ( loc document elt -- newloc )
 141
 142 : prev/next-elt ( loc document elt -- start end )
 143     3dup next-elt >r prev-elt r> ;
 144
 145 : elt-string ( loc document elt -- string )
 146     over >r prev/next-elt r> doc-range ;
 147
 148 TUPLE: char-elt ;
 149
 150 : (prev-char) ( loc document quot -- loc )
 151     -rot {
 152         { [ over { 0 0 } = ] [ drop ] }
 153         { [ over second zero? ] [ >r first 1- r> line-end ] }
 154         { [ t ] [ pick call ] }
 155     } cond nip ; inline
 156
 157 : (next-char) ( loc document quot -- loc )
 158     -rot {
 159         { [ 2dup doc-end = ] [ drop ] }
 160         { [ 2dup line-end? ] [ drop first 1+ 0 2array ] }
 161         { [ t ] [ pick call ] }
 162     } cond nip ; inline
 163
 164 M: char-elt prev-elt
 165     drop [ drop -1 +col ] (prev-char) ;
 166
 167 M: char-elt next-elt
 168     drop [ drop 1 +col ] (next-char) ;
 169
 170 : (word-elt) ( loc document quot -- loc )
 171     pick >r
 172     >r >r first2 swap r> doc-line r> call
 173     r> =col ; inline
 174
 175 : ((word-elt)) [ ?nth blank? ] 2keep ;
 176
 177 : break-detector ( ? -- quot )
 178     [ >r blank? r> xor ] curry ; inline
 179
 180 : (prev-word) ( ? col str -- col )
 181     rot break-detector find-last*
 182     drop [ 1+ ] [ 0 ] if* ;
 183
 184 : (next-word) ( ? col str -- col )
 185     [ rot break-detector find* drop ] keep
 186     over not [ nip length ] [ drop ] if ;
 187
 188 TUPLE: one-word-elt ;
 189
 190 M: one-word-elt prev-elt
 191     drop
 192     [ [ f -rot >r 1- r> (prev-word) ] (word-elt) ] (prev-char) ;
 193
 194 M: one-word-elt next-elt
 195     drop
 196     [ [ f -rot (next-word) ] (word-elt) ] (next-char) ;
 197
 198 TUPLE: word-elt ;
 199
 200 M: word-elt prev-elt
 201     drop
 202     [ [ >r 1- r> ((word-elt)) (prev-word) ] (word-elt) ]
 203     (prev-char) ;
 204
 205 M: word-elt next-elt
 206     drop
 207     [ [ ((word-elt)) (next-word) ] (word-elt) ]
 208     (next-char) ;
 209
 210 TUPLE: one-line-elt ;
 211
 212 M: one-line-elt prev-elt
 213     2drop first 0 2array ;
 214
 215 M: one-line-elt next-elt
 216     drop >r first dup r> doc-line length 2array ;
 217
 218 TUPLE: line-elt ;
 219
 220 M: line-elt prev-elt
 221     2drop dup first zero? [ drop { 0 0 } ] [ -1 +line ] if ;
 222
 223 M: line-elt next-elt
 224     drop over first over last-line# number=
 225     [ nip doc-end ] [ drop 1 +line ] if ;
 226
 227 TUPLE: doc-elt ;
 228
 229 M: doc-elt prev-elt 3drop { 0 0 } ;
 230
 231 M: doc-elt next-elt drop nip doc-end ;