basis/documents/elements/elements.factor

   1 ! Copyright (C) 2006, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators documents kernel math
   4 math.order sequences unicode ;
   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 ( loc document quot: ( loc document -- loc ) -- 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 ( loc document quot: ( loc document -- loc ) -- loc )
  31     {
  32         { [ 2over doc-end = ] [ 2drop ] }
  33         { [ 2over line-end? ] [ 2drop first 1 + 0 2array ] }
  34         [ call ]
  35     } cond ; inline
  36
  37 : modify-col ( loc document quot: ( col str -- col' ) -- loc )
  38     pick [
  39         [ [ first2 swap ] dip doc-line ] dip call
  40     ] dip =col ; inline
  41
  42 PRIVATE>
  43
  44 M: char-elt prev-elt
  45     drop [ [ last-grapheme-from ] modify-col ] prev ;
  46
  47 M: char-elt next-elt
  48     drop [ [ first-grapheme-from ] modify-col ] next ;
  49
  50 SINGLETON: one-char-elt
  51
  52 M: one-char-elt prev-elt 2drop ;
  53
  54 M: one-char-elt next-elt 2drop ;
  55
  56 <PRIVATE
  57
  58 : blank-at? ( n seq -- n seq ? )
  59     2dup ?nth unicode:blank? ;
  60
  61 : break-detector ( ? -- quot )
  62     '[ unicode:blank? _ xor ] ; inline
  63
  64 : prev-word ( col str ? -- col )
  65     break-detector find-last-from drop ?1+ ;
  66
  67 : next-word ( col str ? -- col )
  68     [ break-detector find-from drop ] [ drop length ] 2bi or ;
  69
  70 PRIVATE>
  71
  72 SINGLETON: one-word-elt
  73
  74 M: one-word-elt prev-elt
  75     drop
  76     [ [ 1 - ] dip f prev-word ] modify-col ;
  77
  78 M: one-word-elt next-elt
  79     drop
  80     [ f next-word ] modify-col ;
  81
  82 SINGLETON: word-start-elt
  83
  84 M: word-start-elt prev-elt
  85     drop one-word-elt prev-elt ;
  86
  87 M: word-start-elt next-elt 2drop ;
  88
  89 SINGLETON: word-elt
  90
  91 M: word-elt prev-elt
  92     drop
  93     [ [ [ 1 - ] dip blank-at? prev-word ] modify-col ]
  94     prev ;
  95
  96 M: word-elt next-elt
  97     drop
  98     [ [ blank-at? next-word ] modify-col ]
  99     next ;
 100
 101 SINGLETON: one-line-elt
 102
 103 M: one-line-elt prev-elt
 104     2drop first 0 2array ;
 105
 106 M: one-line-elt next-elt
 107     drop [ first dup ] dip doc-line length 2array ;
 108
 109 <PRIVATE
 110
 111 :: prev-paragraph ( loc document -- loc' )
 112     loc first 1 [-] document value>>
 113     [ empty? ] find-last-from drop [ 1 + ] [ 0 ] if* :> line#
 114
 115     loc first line# = loc second 0 = and [
 116         line# 1 [-] 0 2array
 117     ] [
 118         line# 0 2array
 119     ] if ;
 120
 121 :: next-paragraph ( loc document -- loc' )
 122     loc first 1 + document value>>
 123     [ empty? ] find-from drop :> line#
 124
 125     line# [
 126         1 - dup document doc-line length 2array
 127         dup loc = [ first 1 + 0 2array ] when
 128     ] [
 129         document doc-end
 130     ] if* ;
 131
 132 PRIVATE>
 133
 134 SINGLETON: paragraph-elt
 135
 136 M: paragraph-elt prev-elt drop prev-paragraph ;
 137
 138 M: paragraph-elt next-elt drop next-paragraph ;
 139
 140 TUPLE: page-elt { #lines integer read-only } ;
 141
 142 C: <page-elt> page-elt
 143
 144 M: page-elt prev-elt
 145     nip
 146     2dup [ first ] [ #lines>> ] bi* <
 147     [ 2drop { 0 0 } ] [ #lines>> neg +line ] if ;
 148
 149 M: page-elt next-elt
 150     3dup [ first ] [ last-line# ] [ #lines>> ] tri* - >
 151     [ drop nip doc-end ] [ nip #lines>> +line ] if ;
 152
 153 CONSTANT: line-elt T{ page-elt { #lines 1 } }
 154
 155 SINGLETON: doc-elt
 156
 157 M: doc-elt prev-elt 3drop { 0 0 } ;
 158
 159 M: doc-elt next-elt drop nip doc-end ;