basis/documents/elements/elements.factor

   1 ! Copyright (C) 2006, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays combinators documents fry kernel math sequences
   4 unicode.categories ;
   5 IN: documents.elements
   6
   7 GENERIC: prev-elt ( loc document elt -- newloc )
   8 GENERIC: next-elt ( loc document elt -- newloc )
   9
  10 : prev/next-elt ( loc document elt -- start end )
  11     [ prev-elt ] [ next-elt ] 3bi ;
  12
  13 : elt-string ( loc document elt -- string )
  14     [ prev/next-elt ] [ drop ] 2bi doc-range ;
  15
  16 : set-elt-string ( string loc document elt -- )
  17     [ prev/next-elt ] [ drop ] 2bi set-doc-range ;
  18
  19 SINGLETON: char-elt
  20
  21 <PRIVATE
  22
  23 : (prev-char) ( loc document quot -- loc )
  24     {
  25         { [ pick { 0 0 } = ] [ 2drop ] }
  26         { [ pick second zero? ] [ drop [ first 1- ] dip line-end ] }
  27         [ call ]
  28     } cond ; inline
  29
  30 : (next-char) ( loc document quot -- loc )
  31     {
  32         { [ 2over doc-end = ] [ 2drop ] }
  33         { [ 2over line-end? ] [ 2drop first 1+ 0 2array ] }
  34         [ call ]
  35     } cond ; inline
  36
  37 PRIVATE>
  38
  39 M: char-elt prev-elt
  40     drop [ drop -1 +col ] (prev-char) ;
  41
  42 M: char-elt next-elt
  43     drop [ drop 1 +col ] (next-char) ;
  44
  45 SINGLETON: one-char-elt
  46
  47 M: one-char-elt prev-elt 2drop ;
  48
  49 M: one-char-elt next-elt 2drop ;
  50
  51 <PRIVATE
  52
  53 : (word-elt) ( loc document quot -- loc )
  54     pick [
  55         [ [ first2 swap ] dip doc-line ] dip call
  56     ] dip =col ; inline
  57
  58 : ((word-elt)) ( n seq -- ? n seq )
  59     [ ?nth blank? ] 2keep ;
  60
  61 : break-detector ( ? -- quot )
  62     '[ blank? _ xor ] ; inline
  63
  64 : (prev-word) ( ? col str -- col )
  65     rot break-detector find-last-from drop ?1+ ;
  66
  67 : (next-word) ( ? col str -- col )
  68     [ rot break-detector find-from drop ] keep
  69     over not [ nip length ] [ drop ] if ;
  70
  71 PRIVATE>
  72
  73 SINGLETON: one-word-elt
  74
  75 M: one-word-elt prev-elt
  76     drop
  77     [ [ [ f ] dip 1- ] dip (prev-word) ] (word-elt) ;
  78
  79 M: one-word-elt next-elt
  80     drop
  81     [ [ f ] 2dip (next-word) ] (word-elt) ;
  82
  83 SINGLETON: word-elt
  84
  85 M: word-elt prev-elt
  86     drop
  87     [ [ [ 1- ] dip ((word-elt)) (prev-word) ] (word-elt) ]
  88     (prev-char) ;
  89
  90 M: word-elt next-elt
  91     drop
  92     [ [ ((word-elt)) (next-word) ] (word-elt) ]
  93     (next-char) ;
  94
  95 SINGLETON: one-line-elt
  96
  97 M: one-line-elt prev-elt
  98     2drop first 0 2array ;
  99
 100 M: one-line-elt next-elt
 101     drop [ first dup ] dip doc-line length 2array ;
 102
 103 SINGLETON: line-elt
 104
 105 M: line-elt prev-elt
 106     2drop dup first zero? [ drop { 0 0 } ] [ -1 +line ] if ;
 107
 108 M: line-elt next-elt
 109     drop over first over last-line# number=
 110     [ nip doc-end ] [ drop 1 +line ] if ;
 111
 112 SINGLETON: doc-elt
 113
 114 M: doc-elt prev-elt 3drop { 0 0 } ;
 115
 116 M: doc-elt next-elt drop nip doc-end ;