core/ui/text/elements.factor

   1 IN: gadgets-text
   2 USING: arrays kernel math sequences strings models ;
   3
   4 GENERIC: prev-elt ( loc document elt -- newloc )
   5 GENERIC: next-elt ( loc document elt -- newloc )
   6
   7 TUPLE: char-elt ;
   8
   9 : (prev-char) ( loc document quot -- loc )
  10     -rot {
  11         { [ over { 0 0 } = ] [ drop ] }
  12         { [ over second zero? ] [ >r first 1- r> line-end ] }
  13         { [ t ] [ pick call ] }
  14     } cond nip ; inline
  15
  16 : (next-char) ( loc document quot -- loc )
  17     -rot {
  18         { [ 2dup doc-end = ] [ drop ] }
  19         { [ 2dup line-end? ] [ drop first 1+ 0 2array ] }
  20         { [ t ] [ pick call ] }
  21     } cond nip ; inline
  22
  23 M: char-elt prev-elt
  24     drop [ drop -1 +col ] (prev-char) ;
  25
  26 M: char-elt next-elt
  27     drop [ drop 1 +col ] (next-char) ;
  28
  29 : (word-elt) ( loc document quot -- loc )
  30     pick >r
  31     >r >r first2 swap r> doc-line r> call
  32     r> =col ; inline
  33
  34 : ((word-elt)) [ ?nth blank? ] 2keep ;
  35
  36 : (prev-word) ( ? col str -- col )
  37     [ blank? xor ] find-last-with* drop 1+ ;
  38
  39 : (next-word) ( ? col str -- col )
  40     [ [ blank? xor ] find-with* drop ] keep
  41     over -1 = [ nip length ] [ drop ] if ;
  42
  43 TUPLE: one-word-elt ;
  44
  45 M: one-word-elt prev-elt
  46     drop
  47     [ [ f -rot >r 1- r> (prev-word) ] (word-elt) ] (prev-char) ;
  48
  49 M: one-word-elt next-elt
  50     drop
  51     [ [ f -rot (next-word) ] (word-elt) ] (next-char) ;
  52
  53 TUPLE: word-elt ;
  54
  55 M: word-elt prev-elt
  56     drop
  57     [ [ >r 1- r> ((word-elt)) (prev-word) ] (word-elt) ]
  58     (prev-char) ;
  59
  60 M: word-elt next-elt
  61     drop
  62     [ [ ((word-elt)) (next-word) ] (word-elt) ]
  63     (next-char) ;
  64
  65 TUPLE: one-line-elt ;
  66
  67 M: one-line-elt prev-elt
  68     2drop first 0 2array ;
  69
  70 M: one-line-elt next-elt
  71     drop >r first dup r> doc-line length 2array ;
  72
  73 TUPLE: line-elt ;
  74
  75 M: line-elt prev-elt 2drop -1 +line ;
  76
  77 M: line-elt next-elt 2drop 1 +line ;
  78
  79 TUPLE: doc-elt ;
  80
  81 M: doc-elt prev-elt 3drop { 0 0 } ;
  82
  83 M: doc-elt next-elt drop nip doc-end ;