| 1 | REBOL [
|
|---|
| 2 | TITLE: "Enhanced area"
|
|---|
| 3 | auteurs: "Shadwolf, Steeve"
|
|---|
| 4 | start-date: 07/04/2009
|
|---|
| 5 | release-date: 22/04/2009
|
|---|
| 6 | credits: { Carl sassenrath, Steeve, Maxim, Coccinelle, Cyphre (AGG guru ^^)}
|
|---|
| 7 | purpose: { construct a new style "area-tc",
|
|---|
| 8 | with rendering dynamic colorized text using draw/agg}
|
|---|
| 9 | Download: http://my-svn.assembla.com/svn/shadwolforge/
|
|---|
| 10 | Docstrack: { docs, source diff and time tracs available on
|
|---|
| 11 | http://my-trac.assembla.com/shadwolforge/
|
|---|
| 12 | }
|
|---|
| 13 | ]
|
|---|
| 14 | ;print ""
|
|---|
| 15 | area-tc: context [ ;** global context
|
|---|
| 16 |
|
|---|
| 17 | colors: [
|
|---|
| 18 | char! 0.120.40
|
|---|
| 19 | date! 0.120.150
|
|---|
| 20 | decimal! 0.120.150
|
|---|
| 21 | email! 0.120.40
|
|---|
| 22 | file! 0.120.40
|
|---|
| 23 | integer! 0.120.150
|
|---|
| 24 | issue! 0.120.40
|
|---|
| 25 | money! 0.120.150
|
|---|
| 26 | pair! 0.120.150
|
|---|
| 27 | string! 0.120.40
|
|---|
| 28 | tag! 0.120.40
|
|---|
| 29 | time! 0.120.150
|
|---|
| 30 | tuple! 0.120.150
|
|---|
| 31 | url! 250.120.40
|
|---|
| 32 | refinement! 160.120.40
|
|---|
| 33 | comment! 10.10.160
|
|---|
| 34 | block! 0.0.0
|
|---|
| 35 | datatype! 120.60.100
|
|---|
| 36 | function! 140.0.0
|
|---|
| 37 | native! 140.0.0
|
|---|
| 38 | action! 140.0.0
|
|---|
| 39 | error! 255.0.0
|
|---|
| 40 | multi! 0.120.40
|
|---|
| 41 | free-text! 0.0.200
|
|---|
| 42 | default! 0.0.0
|
|---|
| 43 |
|
|---|
| 44 | ]
|
|---|
| 45 | ;func-list: make string! 5000
|
|---|
| 46 | ;foreach fun bind first system/words system/words [
|
|---|
| 47 | ; if all [value? :fun any-function? get :fun][
|
|---|
| 48 | ; insert insert tail func-list #" " form fun
|
|---|
| 49 | ; ]
|
|---|
| 50 | ;]
|
|---|
| 51 | ;**print length? func-list
|
|---|
| 52 | multi-chars: complement charset "^^}^/^-" ;** to detect end of rebol strings
|
|---|
| 53 | save-color: color: start: end: out-style: x:
|
|---|
| 54 | str: type: f: value: multi: grow?: none
|
|---|
| 55 |
|
|---|
| 56 | ;** markers used in replacement of the draw comman PUSH. Much easy to track them.
|
|---|
| 57 | expand: ;** marker for info messages (like errors)
|
|---|
| 58 | hilight: 'push ;** marker for hilight background
|
|---|
| 59 | no-edit: edit: 'aliased
|
|---|
| 60 |
|
|---|
| 61 | edit-mode: none
|
|---|
| 62 |
|
|---|
| 63 | abs-x: 0
|
|---|
| 64 | ;** rule to output draw dialect
|
|---|
| 65 | gen-draw: [end: (
|
|---|
| 66 | str: copy/part start end
|
|---|
| 67 | unless tail? str [
|
|---|
| 68 | color: any [select colors type color select colors 'default! 0.0.0]
|
|---|
| 69 | abs-x: x * f/x + f/origine-x
|
|---|
| 70 | either save-color <> color [
|
|---|
| 71 | if block? color [
|
|---|
| 72 | out-style: insert insert insert insert insert insert insert insert out-style
|
|---|
| 73 | 'pen color/2 'fill-pen color/2 'box
|
|---|
| 74 | as-pair abs-x 7 as-pair (f/x * length? str) + abs-x 7 + f/y 3
|
|---|
| 75 | type: none
|
|---|
| 76 | color: color/1
|
|---|
| 77 | ]
|
|---|
| 78 | out-style: insert insert insert insert insert out-style
|
|---|
| 79 | 'pen color [text edit] as-pair abs-x + f/xy/x 5 str
|
|---|
| 80 |
|
|---|
| 81 | ][
|
|---|
| 82 | insert tail pick out-style -1 str
|
|---|
| 83 | ]
|
|---|
| 84 | if type = 'error! [
|
|---|
| 85 | out-style: insert/only insert out-style 'expand
|
|---|
| 86 | reduce ['pen red 'text 'vectorial as-pair abs-x 5 + f/y reform [value/id value/arg1]]
|
|---|
| 87 | ]
|
|---|
| 88 | x: x + length? str
|
|---|
| 89 | save-color: color
|
|---|
| 90 | if type = 'error! [grow?: true]
|
|---|
| 91 | ]
|
|---|
| 92 | )]
|
|---|
| 93 | tab1: next tab2: next tab3: next tab4: " "
|
|---|
| 94 | what: none
|
|---|
| 95 | gen-tab: [(
|
|---|
| 96 | what: pick [tab4 tab3 tab2 tab1] x // 4 + 1 ;** align tabs
|
|---|
| 97 | out-style: insert insert insert out-style
|
|---|
| 98 | [text edit] as-pair x * f/x + f/xy/x + f/origine-x 5 what
|
|---|
| 99 | x: x + length? get what
|
|---|
| 100 | save-color: none
|
|---|
| 101 | )]
|
|---|
| 102 |
|
|---|
| 103 | spaces: exclude charset [#"^(1)" - #" "] charset "^/^-" ;** treat like space
|
|---|
| 104 |
|
|---|
| 105 | ;** rule to detect rebol values (uses load/next)
|
|---|
| 106 | ;** (heavy, because we handle errors too)
|
|---|
| 107 | rebol-value: [skip (
|
|---|
| 108 | error? set/any [value end] try [load/next start]
|
|---|
| 109 | either error? :value [
|
|---|
| 110 | value: disarm :value
|
|---|
| 111 | either value/arg2/1 = #"{" [
|
|---|
| 112 | end: any [find start newline tail start]
|
|---|
| 113 | type: 'multi!
|
|---|
| 114 | multi: case [
|
|---|
| 115 | multi < 2 [3]
|
|---|
| 116 | multi = 2 [4]
|
|---|
| 117 | 'else [multi]
|
|---|
| 118 | ]
|
|---|
| 119 | ][
|
|---|
| 120 | end: skip start length? value/arg2
|
|---|
| 121 | type: 'error!
|
|---|
| 122 | ]
|
|---|
| 123 | ][
|
|---|
| 124 | case/all [
|
|---|
| 125 | path? :value [value: first :value]
|
|---|
| 126 | all [word? :value value? :value][value: get value]
|
|---|
| 127 | any-string? :value [
|
|---|
| 128 | if find/part start newline end [
|
|---|
| 129 | end: find/part start newline end
|
|---|
| 130 | multi: case [
|
|---|
| 131 | multi < 2 [3]
|
|---|
| 132 | multi = 2 [4]
|
|---|
| 133 | 'else [multi]
|
|---|
| 134 | ]
|
|---|
| 135 | type: 'multi!
|
|---|
| 136 | ]
|
|---|
| 137 | ]
|
|---|
| 138 | ]
|
|---|
| 139 | type: type?/word :value
|
|---|
| 140 | color: none
|
|---|
| 141 | ]
|
|---|
| 142 | ) :end
|
|---|
| 143 | ]
|
|---|
| 144 |
|
|---|
| 145 | no-tabs: complement charset "^/^-"
|
|---|
| 146 | gen-to-end: [any [some no-tabs | end: tab :end gen-draw some [tab gen-tab] start:] gen-draw]
|
|---|
| 147 | any-char: complement charset " ^-"
|
|---|
| 148 |
|
|---|
| 149 | ;** construct a draw block for one line
|
|---|
| 150 | set 'colorize func [
|
|---|
| 151 | face line out
|
|---|
| 152 | /local check-multi check-free-text orig lvl-start lvl val cont pline pos
|
|---|
| 153 | ][
|
|---|
| 154 | color: save-color: grow?: none
|
|---|
| 155 | f: face
|
|---|
| 156 | x: 0
|
|---|
| 157 | orig: out-style: out
|
|---|
| 158 |
|
|---|
| 159 | ;** multi = -1, free text before REBOL header
|
|---|
| 160 | ;** multi = 0, code not parsed
|
|---|
| 161 | ;** multi = 1, normal code
|
|---|
| 162 | ;** multi = 2, end of multi-line string
|
|---|
| 163 | ;** multi = 3, begin of multi-line string
|
|---|
| 164 | ;** multi = 4, full multi-line string
|
|---|
| 165 |
|
|---|
| 166 | lvl: lvl-start
|
|---|
| 167 | multi: case [
|
|---|
| 168 | head? line [-1]
|
|---|
| 169 | 2 < val: first pline: pick line -1 [4]
|
|---|
| 170 | val = -1 [-1]
|
|---|
| 171 | 'else [1]
|
|---|
| 172 | ]
|
|---|
| 173 | lvl: lvl-start: either pline [pline/3/2][1]
|
|---|
| 174 | line: line/1
|
|---|
| 175 |
|
|---|
| 176 | check-multi: if multi <> 4 [[end skip]]
|
|---|
| 177 | check-free-text: [(cont: if multi <> -1 [[end skip]]) cont]
|
|---|
| 178 |
|
|---|
| 179 | ;**all [char? line/2 print line]
|
|---|
| 180 | parse/all line/2 [
|
|---|
| 181 | start:
|
|---|
| 182 | check-free-text "rebol" any #" " #"[" (multi: 1) end skip
|
|---|
| 183 | | check-free-text (type: 'free-text!) gen-to-end
|
|---|
| 184 | | opt [
|
|---|
| 185 | check-multi start: some [
|
|---|
| 186 | some multi-chars
|
|---|
| 187 | | #"^^" [skip | end]
|
|---|
| 188 | | end: tab :end (type: 'multi!) gen-draw some [tab gen-tab] start:
|
|---|
| 189 | | #"}" (multi: 2) break ;** end of multi-line
|
|---|
| 190 | | break ;** newline
|
|---|
| 191 | ]
|
|---|
| 192 | (type: 'multi!) gen-draw
|
|---|
| 193 | ]
|
|---|
| 194 | any [
|
|---|
| 195 | start: [newline | end] break
|
|---|
| 196 | | some spaces (type: 'blank!) gen-draw
|
|---|
| 197 | | tab gen-tab
|
|---|
| 198 | | [#"[" | #"("] (type: 'block! lvl: lvl + 1) gen-draw
|
|---|
| 199 | | [#"]" | #")"] (type: 'block! lvl: lvl - 1) gen-draw
|
|---|
| 200 | | #";"(type: 'comment!) gen-to-end
|
|---|
| 201 | | rebol-value gen-draw
|
|---|
| 202 | ]
|
|---|
| 203 | ]
|
|---|
| 204 |
|
|---|
| 205 | line/1: multi
|
|---|
| 206 | line/3: as-pair lvl-start lvl
|
|---|
| 207 |
|
|---|
| 208 |
|
|---|
| 209 | f/h-scroller/max-x: max f/h-scroller/max-x x * f/x + f/origine-x + (f/x * 10)
|
|---|
| 210 | ;**f/cursor/len: x
|
|---|
| 211 |
|
|---|
| 212 | case [
|
|---|
| 213 | empty? orig [ ;** if the text contains no chars, add a dummy line
|
|---|
| 214 | append orig compose [text edit (as-pair f/origine-x + f/xy/x 5) (copy "")]
|
|---|
| 215 | ]
|
|---|
| 216 | not same? back start find/reverse start any-char [
|
|---|
| 217 | insert insert insert tail orig
|
|---|
| 218 | [pen blue text no-edit]
|
|---|
| 219 | as-pair x * f/x + f/origine-x + f/xy/x 5
|
|---|
| 220 | "�"
|
|---|
| 221 | ]
|
|---|
| 222 | ]
|
|---|
| 223 | grow? ;** notices if it's a simple line or a double-size line
|
|---|
| 224 | ]
|
|---|
| 225 |
|
|---|
| 226 | ;** cut text into lines
|
|---|
| 227 | set 'build-data func [
|
|---|
| 228 | text f /local out
|
|---|
| 229 | ][
|
|---|
| 230 | out: f/data
|
|---|
| 231 | clear out
|
|---|
| 232 | parse/all text [any [pos: (out: insert/only out reduce [0 pos 0x0]) thru newline]]
|
|---|
| 233 | f/origine-x: f/x * (1 + length? to string! length? head out)
|
|---|
| 234 | recycle/on
|
|---|
| 235 | out: head out
|
|---|
| 236 | ]
|
|---|
| 237 |
|
|---|
| 238 | ;** boxline: [pen red fill-pen red box 0x1 32x18]
|
|---|
| 239 |
|
|---|
| 240 | ;** debug: display where show occurs
|
|---|
| 241 | ;show: func [f][print either in f 'cursor ['area-tc]['cursor-only] system/words/show f]
|
|---|
| 242 |
|
|---|
| 243 | ;** markers used in replacement of the draw comman PUSH. Much easy to track them with parse.
|
|---|
| 244 | expand: ;** marker for info messages (like errors)
|
|---|
| 245 | hilight: 'push ;** marker for hilight background
|
|---|
| 246 | no-edit: ;** marker for text no editable
|
|---|
| 247 | edit: 'aliased
|
|---|
| 248 |
|
|---|
| 249 | ;** contruct draw blocks, only for new lines inserted
|
|---|
| 250 | render-text: func [
|
|---|
| 251 | f inc
|
|---|
| 252 | /stay
|
|---|
| 253 | /local pos char color draw-txt
|
|---|
| 254 | prev-col draw-sblk nb line data n decal
|
|---|
| 255 | ][
|
|---|
| 256 | ;start: now/precise
|
|---|
| 257 | prev-col: none
|
|---|
| 258 | case [
|
|---|
| 259 | stay [
|
|---|
| 260 | inc: inc - 1
|
|---|
| 261 | data: skip f/data inc
|
|---|
| 262 | ]
|
|---|
| 263 | inc < 0 [
|
|---|
| 264 | inc: negate min abs inc ((index? f/data) - 1)
|
|---|
| 265 | data: f/data: skip f/data inc
|
|---|
| 266 | ]
|
|---|
| 267 | inc > 0 [
|
|---|
| 268 | inc: min max 0 ((length? f/data) - f/nb-lines) inc
|
|---|
| 269 | data: f/data: skip f/data inc
|
|---|
| 270 | ]
|
|---|
| 271 | 'else [data: f/data]
|
|---|
| 272 | ]
|
|---|
| 273 |
|
|---|
| 274 | draw-txt: any [find f/effect/draw 'push tail f/effect/draw]
|
|---|
| 275 |
|
|---|
| 276 | case [
|
|---|
| 277 | stay [
|
|---|
| 278 | draw-txt: clear skip draw-txt max 0 inc * 4
|
|---|
| 279 | nb: min f/nb-lines f/nb-lines - inc
|
|---|
| 280 | ]
|
|---|
| 281 | empty? draw-txt [
|
|---|
| 282 | nb: f/nb-lines
|
|---|
| 283 | ]
|
|---|
| 284 | inc > 0 [
|
|---|
| 285 | remove/part draw-txt 4 * inc
|
|---|
| 286 | draw-txt: tail draw-txt
|
|---|
| 287 | nb: min f/nb-lines inc
|
|---|
| 288 | data: skip data either f/nb-lines > inc [f/nb-lines - inc][0]
|
|---|
| 289 | ;** A FAIRE, si inc d�passe le nombre de lignes affich�es,
|
|---|
| 290 | ;** parser les lignes skip�es (non affich�es)
|
|---|
| 291 | ;** pour d�tecter les strings multi-ligne
|
|---|
| 292 | ]
|
|---|
| 293 | inc < 0 [
|
|---|
| 294 | clear skip draw-txt max 0 4 * (f/nb-lines + inc)
|
|---|
| 295 | nb: min f/nb-lines abs inc
|
|---|
| 296 | ]
|
|---|
| 297 | 'else [return true]
|
|---|
| 298 | ]
|
|---|
| 299 | nb: min nb length? data
|
|---|
| 300 | n: 1
|
|---|
| 301 | decal: as-pair 0 f/y
|
|---|
| 302 | while [n <= nb][
|
|---|
| 303 | line: at data n
|
|---|
| 304 | draw-txt: insert draw-txt 'push
|
|---|
| 305 | draw-sblk: insert insert insert make block! 50
|
|---|
| 306 | [hilight none pen 128.128.128 text no-edit] as-pair f/xy/x 5
|
|---|
| 307 | reverse copy/part reverse head insert change
|
|---|
| 308 | clear "" " " (n - 1 + index? data) (f/origine-x - f/x / f/x)
|
|---|
| 309 | if colorize f line draw-sblk [
|
|---|
| 310 | decal: as-pair 0 2 * f/y
|
|---|
| 311 | ]
|
|---|
| 312 | draw-txt: insert insert insert/only draw-txt head draw-sblk 'translate decal
|
|---|
| 313 | decal: as-pair 0 f/y
|
|---|
| 314 | n: n + 1
|
|---|
| 315 | ]
|
|---|
| 316 |
|
|---|
| 317 | set-y f 5 ;** recalc all y offset of texts (which can be absolute only)
|
|---|
| 318 | unless f/cursor/selection? [show f]
|
|---|
| 319 | ;** probe difference now/precise start
|
|---|
| 320 | ]
|
|---|
| 321 |
|
|---|
| 322 | ;** recalc of all y offset after verstical scroll
|
|---|
| 323 | set-y: func [f y /local blk pair line idx gb lgb chg-y][
|
|---|
| 324 | blk: f/effect/draw
|
|---|
| 325 | blk: find f/effect/draw 'push
|
|---|
| 326 | lgb: index? f/data
|
|---|
| 327 | gb: f/cursor/global-idx
|
|---|
| 328 | idx: 2
|
|---|
| 329 | f/cursor/show?: false
|
|---|
| 330 | chg-y: [thru 'text ['edit | 'no-edit] pair: pair! (pair/1/y: y)]
|
|---|
| 331 | foreach [cmd value] blk [
|
|---|
| 332 | switch cmd [
|
|---|
| 333 | translate [y: y + value/y]
|
|---|
| 334 | push [
|
|---|
| 335 | if gb = lgb [
|
|---|
| 336 | f/cursor/xy/y: y
|
|---|
| 337 | f/cursor/data: at blk idx
|
|---|
| 338 | f/cursor/show?: true
|
|---|
| 339 | ]
|
|---|
| 340 | parse value [
|
|---|
| 341 | any chg-y
|
|---|
| 342 | any [thru 'push into [any chg-y to end break]]
|
|---|
| 343 | ]
|
|---|
| 344 | lgb: lgb + 1
|
|---|
| 345 | ]
|
|---|
| 346 |
|
|---|
| 347 | ]
|
|---|
| 348 | idx: idx + 2
|
|---|
| 349 | ]
|
|---|
| 350 | ]
|
|---|
| 351 |
|
|---|
| 352 | move-x: func [f x /local blk pair chg-x][
|
|---|
| 353 | blk: f/effect/draw
|
|---|
| 354 | blk: find f/effect/draw 'push
|
|---|
| 355 | chg-x: [thru 'text ['edit | 'no-edit] pair: pair! (pair/1/x: x + pair/1/x)]
|
|---|
| 356 | foreach [cmd value] blk [
|
|---|
| 357 | switch cmd [
|
|---|
| 358 | translate [x: x + value/x]
|
|---|
| 359 | push [
|
|---|
| 360 | parse value [
|
|---|
| 361 | any chg-x
|
|---|
| 362 | any [thru 'push into [any chg-x to end break]]
|
|---|
| 363 | ]
|
|---|
| 364 | ]
|
|---|
| 365 | ]
|
|---|
| 366 | ]
|
|---|
| 367 | f/cursor/xy/x: f/cursor/xy/x + x
|
|---|
| 368 | ]
|
|---|
| 369 |
|
|---|
| 370 |
|
|---|
| 371 | ;** return the inner face matching the point
|
|---|
| 372 | map-inner: func [face point /local pane][
|
|---|
| 373 | unless pane: face/pane [return face]
|
|---|
| 374 | unless block? pane [pane: to block! pane]
|
|---|
| 375 | foreach face pane [
|
|---|
| 376 | if within? point face/offset face/size [return map-inner face point - face/offset]
|
|---|
| 377 | ]
|
|---|
| 378 | face
|
|---|
| 379 | ]
|
|---|
| 380 |
|
|---|
| 381 | get*: func [v][do back change/only [none] v] ;** if v is a word, get value in the world
|
|---|
| 382 | any-char: complement space: charset " ^-"
|
|---|
| 383 |
|
|---|
| 384 | ;** find a free place in the whole area to display the info box
|
|---|
| 385 | find-free-places: func [
|
|---|
| 386 | f
|
|---|
| 387 | /local data end x len l-len r-pos stack-l stack-r
|
|---|
| 388 | ][
|
|---|
| 389 | stack-l: clear []
|
|---|
| 390 | stack-r: clear []
|
|---|
| 391 | data: f/data
|
|---|
| 392 | loop len: f/nb-lines [
|
|---|
| 393 | line: data/1/2
|
|---|
| 394 | end: any [find line newline tail line]
|
|---|
| 395 |
|
|---|
| 396 | ;** length of the left free zone
|
|---|
| 397 | pos: any [find/part line space end line]
|
|---|
| 398 | l-len: -1 + index? pos
|
|---|
| 399 |
|
|---|
| 400 | ;** start of the rigth free zone
|
|---|
| 401 | pos: ant [find/reverse end any-char end]
|
|---|
| 402 | r-start: index? pos
|
|---|
| 403 |
|
|---|
| 404 | stack-l: insert stack-l l-len
|
|---|
| 405 | stack-r: insert stack-r r-len
|
|---|
| 406 | data: next data
|
|---|
| 407 | ]
|
|---|
| 408 | x: maximum-of stack-l
|
|---|
| 409 | loop len [
|
|---|
| 410 |
|
|---|
| 411 | stack-l: next stack-l
|
|---|
| 412 | ]
|
|---|
| 413 | ]
|
|---|
| 414 |
|
|---|
| 415 | event-func: use [
|
|---|
| 416 | origin off-mem save-size 0x0 drag track
|
|---|
| 417 | ][
|
|---|
| 418 | origin: off-mem: save-size: 0x0
|
|---|
| 419 | drag: track: false
|
|---|
| 420 | func [
|
|---|
| 421 | {area-tc handler} ;** don't remove or change this text, it's used to identify the handler
|
|---|
| 422 | face event /local tmp
|
|---|
| 423 | ][
|
|---|
| 424 | ;**print [event/type event/key]
|
|---|
| 425 | switch event/type [
|
|---|
| 426 | time none ;** a lot of 'time events are sent, check it first
|
|---|
| 427 | key [
|
|---|
| 428 | ;** key handler for faces without text and caret (actually only for areat-tc)
|
|---|
| 429 | if event/1 = 'time [return event] ;** FUUUUUCK, why we receive that crap event here ???
|
|---|
| 430 | if all [
|
|---|
| 431 | tmp: system/view/focal-face
|
|---|
| 432 | in tmp 'style
|
|---|
| 433 | tmp/style = 'area-tc
|
|---|
| 434 | ][
|
|---|
| 435 | tmp/feel/engage tmp 'key event
|
|---|
| 436 | ]
|
|---|
| 437 | ]
|
|---|
| 438 | move [
|
|---|
| 439 | either drag [
|
|---|
| 440 | tmp: track/offset
|
|---|
| 441 | drag/feel/drag drag event/offset - origin
|
|---|
| 442 | origin: origin + track/offset - tmp ;** correct the origin, if the tracked face has moved
|
|---|
| 443 | return false ;** disable move event
|
|---|
| 444 | ][off-mem: event/offset ] ;** for mouse wheel motion
|
|---|
| 445 | ]
|
|---|
| 446 | resize [
|
|---|
| 447 | tmp: negate saved-size - saved-size: face/pane/1/size
|
|---|
| 448 | foreach face face/pane/1/pane [
|
|---|
| 449 | if in face/feel 'resize [face/feel/resize face tmp]
|
|---|
| 450 | ]
|
|---|
| 451 | ]
|
|---|
| 452 | down [
|
|---|
| 453 | face: map-inner event/face event/offset
|
|---|
| 454 | if in face/feel 'drag [
|
|---|
| 455 | ;** the draging face which contains the pointer may be different from the draged (track) face
|
|---|
| 456 | drag: face
|
|---|
| 457 | origin: event/offset
|
|---|
| 458 | track: drag/feel/drag/track drag event/offset
|
|---|
| 459 | ]
|
|---|
| 460 | ]
|
|---|
| 461 | up [if drag [recycle drag: false]]
|
|---|
| 462 | scroll-line [
|
|---|
| 463 | face: event/face
|
|---|
| 464 | face: map-inner event/face off-mem
|
|---|
| 465 | if in face/feel 'scrollwheel [
|
|---|
| 466 | face/feel/scrollwheel face event off-mem - win-offset? face
|
|---|
| 467 | ]
|
|---|
| 468 | ]
|
|---|
| 469 | active [saved-size: face/pane/1/size]
|
|---|
| 470 | ]
|
|---|
| 471 | ;**[print [event/type event/offset]]
|
|---|
| 472 | event
|
|---|
| 473 | ]
|
|---|
| 474 | ]
|
|---|
| 475 | key-to-insert: make bitset! #{
|
|---|
| 476 | 01000000FFFFFFFFFFFFFFFFFFFFFF7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
|
|---|
| 477 | }
|
|---|
| 478 |
|
|---|
| 479 | stylize/master [
|
|---|
| 480 | area-tc: box with [
|
|---|
| 481 | style: 'area-tc
|
|---|
| 482 | rate: 1
|
|---|
| 483 | text: none
|
|---|
| 484 | para: make para [origin: 0x0 margin: 0x0]
|
|---|
| 485 | delay: 0
|
|---|
| 486 | ask: 'recycle ;** command to delay
|
|---|
| 487 | color: white
|
|---|
| 488 | x: 8 ;** current x size oh 1 char
|
|---|
| 489 | y: 18 ;** current y size of a line
|
|---|
| 490 | origine-x: 3 * x ;** stock la position a la quelle le texte d�marre apres le rendu des num�ro de ligne
|
|---|
| 491 | data: []
|
|---|
| 492 | font-obj: make face/font [name: "lucida console" size: 14 style: none offset: 0x0]
|
|---|
| 493 | nb-lines: 0
|
|---|
| 494 | xy: 0x0 ;** scroll offset
|
|---|
| 495 | move-offset: 0x0
|
|---|
| 496 | save-x: 0
|
|---|
| 497 | file-name: none
|
|---|
| 498 | effect: [draw [pen none font font-obj line-width 1 translate xy]]
|
|---|
| 499 | open-file: func [ file [file! none!] /local ][
|
|---|
| 500 | if any [file file: request-file ][
|
|---|
| 501 | ;** data: build-data detab/size read file 4 self
|
|---|
| 502 | if block? file [file: first file]
|
|---|
| 503 | data: build-data read/direct file self
|
|---|
| 504 | file-name: file
|
|---|
| 505 | render-text/stay t 1
|
|---|
| 506 | ]
|
|---|
| 507 | ]
|
|---|
| 508 | write-file: func [/local dt str-tmp n line nbline] [
|
|---|
| 509 | dt: head data
|
|---|
| 510 | str-tmp: "" n: 1 nbline: length? dt
|
|---|
| 511 | while [n <= nbline ] [
|
|---|
| 512 | line: second dt/:n ; on transfert le pointeur vers le document dans data vers un autre pointeur
|
|---|
| 513 | append str-tmp copy/part line any [ find line newline tail line] ;on copy jusqu'a newline ou jusqu'a la fin
|
|---|
| 514 | append str-tmp newline
|
|---|
| 515 | n: n + 1
|
|---|
| 516 | ]
|
|---|
| 517 | write file-name str-tmp
|
|---|
| 518 | ]
|
|---|
| 519 | save-file: func [] [
|
|---|
| 520 | if 0 <> length? data [
|
|---|
| 521 | either none? file-name [ ; data is full but we don't have a file-name
|
|---|
| 522 | if file-name: request-file/save/title "Save as..." "save"
|
|---|
| 523 | [
|
|---|
| 524 | if block? file [file: first file]
|
|---|
| 525 | write-file ]
|
|---|
| 526 |
|
|---|
| 527 | ] [
|
|---|
| 528 | ; data is full and we have a file name
|
|---|
| 529 | write-file
|
|---|
| 530 | ]
|
|---|
| 531 | ]
|
|---|
| 532 | ]
|
|---|
| 533 | v-scroller: make face [
|
|---|
| 534 | offset: 0x0 size: 13x0 color: none edge: none
|
|---|
| 535 | size-box: 0x0
|
|---|
| 536 | para: none
|
|---|
| 537 | effect: [draw [pen sky line-width 2 fill-pen none box 0x0 size-box 2]]
|
|---|
| 538 | feel: make feel [
|
|---|
| 539 | redraw: func [f a /local p l][
|
|---|
| 540 | if all ['show = a p: f/parent-face 0 < l: length? head p/data][
|
|---|
| 541 | f/size/y: max 25 p/nb-lines / l * p/size/y
|
|---|
| 542 | f/offset/y: (index? p/data) / (l - p/nb-lines) * (p/size/y - f/size/y)
|
|---|
| 543 | f/size-box: f/size - 2x2
|
|---|
| 544 | ]
|
|---|
| 545 | ]
|
|---|
| 546 | drag: func [f offset /track /local coeff][
|
|---|
| 547 | f/parent-face/delay: 3 ;** don't perturb the scroll please
|
|---|
| 548 | if track [return f]
|
|---|
| 549 | if 1 <= abs coeff: offset/y / (f/size/y / f/parent-face/nb-lines) [
|
|---|
| 550 | render-text f/parent-face to integer! coeff
|
|---|
| 551 | if f/parent-face/cursor/selection? [
|
|---|
| 552 | f/parent-face/feel/expand-selector f/parent-face/cursor
|
|---|
| 553 | show f/parent-face
|
|---|
| 554 | ]
|
|---|
| 555 | ]
|
|---|
| 556 | ]
|
|---|
| 557 | engage: func [f a e][false] ;** don't send events to the area
|
|---|
| 558 | ]
|
|---|
| 559 | ]
|
|---|
| 560 | h-scroller: make face [
|
|---|
| 561 | offset: 0x0 size: 0x13 color: none edge: none
|
|---|
| 562 | size-box: 0x0
|
|---|
| 563 | text: none
|
|---|
| 564 | edge: none
|
|---|
| 565 | font: make font [align: 'right size: 10 style: 'bold color: red]
|
|---|
| 566 | para: make para [origin: 0x0]
|
|---|
| 567 | max-x: 1
|
|---|
| 568 | effect: [draw [pen sky line-width 2 fill-pen none box 0x0 size-box 2]]
|
|---|
| 569 | feel: make feel [
|
|---|
| 570 | redraw: func [f a /local parent][
|
|---|
| 571 | if 'show = a [
|
|---|
| 572 | f/show?: if f/max-x > f/parent-face/size/x [
|
|---|
| 573 | parent: f/parent-face
|
|---|
| 574 | f/offset/x: to integer! negate parent/xy/x / f/max-x * parent/size/x
|
|---|
| 575 | f/size/x: to integer! (parent/size/x ** 2) / f/max-x
|
|---|
| 576 | f/size-box: f/size - 2x2
|
|---|
| 577 | true
|
|---|
| 578 | ]
|
|---|
| 579 | ]
|
|---|
| 580 | ]
|
|---|
| 581 | drag: func [scroller offset /track /local parent save-x decal x][
|
|---|
| 582 | f: scroller/parent-face
|
|---|
| 583 | f/delay: 3 ;** don't perturb the scroll please
|
|---|
| 584 | if track [return scroller]
|
|---|
| 585 | if f/x <= abs offset/x [
|
|---|
| 586 | offset/x: to integer! offset/x + 4 / f/x * f/x
|
|---|
| 587 | save-x: f/xy/x
|
|---|
| 588 | x: f/xy/x: min 0 max
|
|---|
| 589 | f/size/x - scroller/max-x
|
|---|
| 590 | f/xy/x - offset/x
|
|---|
| 591 |
|
|---|
| 592 | ;** change change skip tail boxline -2
|
|---|
| 593 | ;** as-pair negate x 1 as-pair 32 - x 18
|
|---|
| 594 |
|
|---|
| 595 | if 0 <> decal: x - save-x [move-x f decal]
|
|---|
| 596 | show f
|
|---|
| 597 | ]
|
|---|
| 598 | ]
|
|---|
| 599 | engage: func [f a e][false] ;** don't send events to the area
|
|---|
| 600 | ]
|
|---|
| 601 | ]
|
|---|
| 602 | cursor: make face [
|
|---|
| 603 | offset: 0x5 size: 2x18 para: color: edge: none
|
|---|
| 604 | xy: as-pair origine-x 5
|
|---|
| 605 | sub-string: idx: global-idx: col: old-col:
|
|---|
| 606 | old-idx: tmp-offset: pos-len: old-pos-len: none
|
|---|
| 607 | selection?: false
|
|---|
| 608 | selector-xy: [0x0]
|
|---|
| 609 | head?: false
|
|---|
| 610 | data: pos-blk: []
|
|---|
| 611 | blink-color: red
|
|---|
| 612 | size-box: 2x16
|
|---|
| 613 | effect: [draw [pen blink-color fill-pen blink-color box 0x1 size-box]]
|
|---|
| 614 | feel: make feel [
|
|---|
| 615 | redraw: func [f a][
|
|---|
| 616 | if a = 'show [
|
|---|
| 617 | f/offset: f/xy
|
|---|
| 618 | if f/selection? [
|
|---|
| 619 | f/selector-xy/1/x: f/xy/x - f/parent-face/xy/x
|
|---|
| 620 | ]
|
|---|
| 621 | ]
|
|---|
| 622 | ]
|
|---|
| 623 | engage: func [f a e][] ;** disable events
|
|---|
| 624 | ]
|
|---|
| 625 | ]
|
|---|
| 626 | feel: make feel [
|
|---|
| 627 | scrollwheel: func [f event offset] [
|
|---|
| 628 | f/delay: 3
|
|---|
| 629 | dir: either event/offset/y > 0 ['down]['up]
|
|---|
| 630 | switch dir [
|
|---|
| 631 | down [render-text f 3]
|
|---|
| 632 | up [render-text f -3]
|
|---|
| 633 | ]
|
|---|
| 634 | if f/cursor/selection? [expand-selector f/cursor show f]
|
|---|
| 635 | ]
|
|---|
| 636 | resize: func [f size+][
|
|---|
| 637 | f/size: f/size + size+
|
|---|
| 638 | f/nb-lines: to-integer (f/size/y - 10 / f/y)
|
|---|
| 639 | f/v-scroller/offset: as-pair f/size/x - 13 2
|
|---|
| 640 | f/h-scroller/offset: as-pair 2 f/size/y - 13
|
|---|
| 641 | render-text/stay f 1
|
|---|
| 642 | if f/cursor/selection? [expand-selector f/cursor show f]
|
|---|
| 643 | ]
|
|---|
| 644 | begin-selection: func [
|
|---|
| 645 | cursor /local f
|
|---|
| 646 | ][
|
|---|
| 647 |
|
|---|
| 648 | f: cursor/parent-face
|
|---|
| 649 | cursor/selection?: true
|
|---|
| 650 | insert-selector f next cursor/data/1 cursor/xy/x + f/xy/x
|
|---|
| 651 | cursor/selector-xy: back tail cursor/data/1/2
|
|---|
| 652 | cursor/old-idx: cursor/global-idx
|
|---|
| 653 | cursor/old-pos-len: cursor/pos-len
|
|---|
| 654 | get-col cursor
|
|---|
| 655 | cursor/old-col: cursor/col
|
|---|
| 656 | ]
|
|---|
| 657 |
|
|---|
| 658 | ;** drag = activate selection
|
|---|
| 659 | drag: func [f offset /track /local cursor][
|
|---|
| 660 |
|
|---|
| 661 | ;** beware, it's the cursor which moves, not the area.
|
|---|
| 662 | if track [return f/cursor]
|
|---|
| 663 | unless f/cursor/selection? [begin-selection f/cursor]
|
|---|
| 664 |
|
|---|
| 665 | ;** not enough displacement to move the cursor
|
|---|
| 666 | if all [f/x > abs offset/x f/y > abs offset/y][exit]
|
|---|
| 667 |
|
|---|
| 668 | case [
|
|---|
| 669 | all [positive? offset/y f/cursor/idx = f/nb-lines][render-text f 1] ;** scroll down
|
|---|
| 670 | all [negative? offset/y f/cursor/idx = 1][render-text f -1] ;** scroll up
|
|---|
| 671 | ]
|
|---|
| 672 | click f f/cursor/xy + offset
|
|---|
| 673 | expand-selector f/cursor
|
|---|
| 674 | show f
|
|---|
| 675 | ]
|
|---|
| 676 |
|
|---|
| 677 | detect: func [f e][
|
|---|
| 678 | ;**print remold [e/1 e/2 e/3 e/4 e/5 e/6]
|
|---|
| 679 | if e/type = 'move [
|
|---|
| 680 | ;** because of the timer, 'move events are received, even if there is no move
|
|---|
| 681 | if all [find [info-position recycle] f/ask f/move-offset <> e/offset][
|
|---|
| 682 | f/ask: 'info-position
|
|---|
| 683 | f/delay: 2
|
|---|
| 684 | f/move-offset: e/offset
|
|---|
| 685 | ]
|
|---|
| 686 | return false
|
|---|
| 687 | ]
|
|---|
| 688 | e
|
|---|
| 689 | ]
|
|---|
| 690 | engage: func [f a e /local key tmp cursor select?][
|
|---|
| 691 | ;**print remold [a e/type e/key e/1 e/2 e/3 e/4 e/5 e/6]
|
|---|
| 692 | cursor: f/cursor
|
|---|
| 693 | if a = 'time [
|
|---|
| 694 | ;print [now/time f/ask f/delay]
|
|---|
| 695 | either all [cursor/show? find [recycle info-position] f/ask] [
|
|---|
| 696 | f/cursor/blink-color: get first reverse [red none]
|
|---|
| 697 | show f/cursor
|
|---|
| 698 | ][f/cursor/blink-color: red]
|
|---|
| 699 | case [
|
|---|
| 700 | 0 > f/delay: f/delay - 1 [
|
|---|
| 701 | ;** if f/ask <> 'show [print ["timer:" now/time f/ask] ]
|
|---|
| 702 | switch f/ask [
|
|---|
| 703 | show []
|
|---|
| 704 | recycle [recycle]
|
|---|
| 705 | ]
|
|---|
| 706 | f/ask: 'recycle
|
|---|
| 707 | f/rate: 1 ;** default rate, 1 event per second
|
|---|
| 708 | f/delay: 5 ;** recycle after 5 secs of inactivity
|
|---|
| 709 | show f ;** DON't remove the show here (needed to update the face rate)
|
|---|
| 710 | ]
|
|---|
| 711 | ]
|
|---|
| 712 | return false
|
|---|
| 713 | ]
|
|---|
| 714 | select?: cursor/selection?
|
|---|
| 715 | unless find [up down] key: e/key [f/save-x: 0]
|
|---|
| 716 | if f/ask <> 'show [f/ask: 'info-cursor f/delay: 3]
|
|---|
| 717 | cursor/blink-color: red
|
|---|
| 718 |
|
|---|
| 719 | if all [e/5 not select? any [word? key key < #" "]][
|
|---|
| 720 | select?: true
|
|---|
| 721 | begin-selection cursor
|
|---|
| 722 | ]
|
|---|
| 723 | switch a [
|
|---|
| 724 | down [click f e/offset]
|
|---|
| 725 | key [
|
|---|
| 726 | ;** e/6 = true for ctrl
|
|---|
| 727 | switch/default key[
|
|---|
| 728 | page-up [render-text f negate f/nb-lines]
|
|---|
| 729 | page-down [render-text f f/nb-lines]
|
|---|
| 730 | #"^P" [inc-font-size f 1] ;** increase font size
|
|---|
| 731 | #"^L" [inc-font-size f -1] ;** decrease font size
|
|---|
| 732 | #"^B" [bold f]
|
|---|
| 733 | ][
|
|---|
| 734 | locate-cursor cursor
|
|---|
| 735 | ]
|
|---|
| 736 | switch/default key [
|
|---|
| 737 | #"^M" [split-line f]
|
|---|
| 738 | #"^[" []
|
|---|
| 739 | #"^~" [ ;** delete
|
|---|
| 740 | either select? [
|
|---|
| 741 | do-selection/delete f
|
|---|
| 742 | ][
|
|---|
| 743 | delete-char cursor
|
|---|
| 744 | recolorize cursor
|
|---|
| 745 | ]
|
|---|
| 746 | show f
|
|---|
| 747 | ]
|
|---|
| 748 | #"^H" [ ;** backtab
|
|---|
| 749 | either select? [
|
|---|
| 750 | do-selection/delete f
|
|---|
| 751 | ][
|
|---|
| 752 | move-cursor/left cursor
|
|---|
| 753 | delete-char cursor
|
|---|
| 754 | recolorize cursor
|
|---|
| 755 | ]
|
|---|
| 756 | show f
|
|---|
| 757 | ]
|
|---|
| 758 | right [
|
|---|
| 759 | either e/6 [
|
|---|
| 760 | right-word cursor
|
|---|
| 761 | ][
|
|---|
| 762 | move-cursor/right cursor
|
|---|
| 763 | ]
|
|---|
| 764 | show cursor ]
|
|---|
| 765 | left [
|
|---|
| 766 | either e/6 [
|
|---|
| 767 | left-word cursor
|
|---|
| 768 | ][
|
|---|
| 769 | move-cursor/left cursor
|
|---|
| 770 | ]
|
|---|
| 771 | show cursor
|
|---|
| 772 | ]
|
|---|
| 773 | down [down-cursor cursor]
|
|---|
| 774 | up [up-cursor cursor]
|
|---|
| 775 | end [
|
|---|
| 776 | constraint f as-pair 100000 cursor/xy/y
|
|---|
| 777 | show cursor
|
|---|
| 778 | ]
|
|---|
| 779 | home [
|
|---|
| 780 | constraint f as-pair f/origine-x + f/xy/x cursor/xy/y
|
|---|
| 781 | show cursor
|
|---|
| 782 | ]
|
|---|
| 783 | #"^S" [ if request "Save file ? " [ f/save-file] ]
|
|---|
| 784 | #"^O" [ if request "Open a file?" [ f/open-file none]]
|
|---|
| 785 | #"^N" [ if request "Start a new file?" [f/data: build-data "" f render-text/stay f 1 ]]
|
|---|
| 786 | #"^C" [do-selection/clip f]
|
|---|
| 787 | #"^X" [do-selection/clip/delete f]
|
|---|
| 788 | #"^V" [;** TO-DO insert multi-lines text
|
|---|
| 789 | insert-char f/cursor tmp: first parse read clipboard:// "^/"
|
|---|
| 790 | show f
|
|---|
| 791 | ]
|
|---|
| 792 | #"^F" [search f]
|
|---|
| 793 |
|
|---|
| 794 | ][
|
|---|
| 795 | if all [char? key find key-to-insert key ][
|
|---|
| 796 | insert-char f/cursor e/key
|
|---|
| 797 | recolorize f/cursor
|
|---|
| 798 | ;** auto-scroll horizontaly
|
|---|
| 799 | if f/x * 10 + cursor/xy/x > f/size/x [
|
|---|
| 800 | scroll-x f f/x * 10
|
|---|
| 801 | ]
|
|---|
| 802 | show f
|
|---|
| 803 | ]
|
|---|
| 804 | ]
|
|---|
| 805 | ]
|
|---|
| 806 | ]
|
|---|
| 807 | if select? [
|
|---|
| 808 | either any [e/5 e/6 a = 'up] [
|
|---|
| 809 | expand-selector cursor
|
|---|
| 810 | ][
|
|---|
| 811 | remove-selector cursor
|
|---|
| 812 | ]
|
|---|
| 813 | show f
|
|---|
| 814 | ]
|
|---|
| 815 | ]
|
|---|
| 816 | bold: func [f][
|
|---|
| 817 | f/font-obj/style: either f/font-obj/style [none]['bold]
|
|---|
| 818 | inc-font-size f 0
|
|---|
| 819 | ]
|
|---|
| 820 | search: func [f][
|
|---|
| 821 | ;what: read clipboard://
|
|---|
| 822 | ]
|
|---|
| 823 |
|
|---|
| 824 | split-line: func [f /local tmp str blanks][
|
|---|
| 825 | insert-char f/cursor "^/"
|
|---|
| 826 |
|
|---|
| 827 | tmp: at f/data f/cursor/idx
|
|---|
| 828 | str: tmp/1/2
|
|---|
| 829 |
|
|---|
| 830 | blanks: copy/part str find str any-char
|
|---|
| 831 | insert str: find/tail str newline blanks
|
|---|
| 832 | insert/only next tmp reduce [0 str 0x0]
|
|---|
| 833 |
|
|---|
| 834 | render-text/stay f f/cursor/idx
|
|---|
| 835 | replace/all blanks tab " "
|
|---|
| 836 | f/cursor/xy/x: f/origine-x + f/xy/x + (f/x * length? blanks)
|
|---|
| 837 | down-cursor f/cursor
|
|---|
| 838 | f/save-x: 0
|
|---|
| 839 | ]
|
|---|
| 840 |
|
|---|
| 841 | inc-font-size: func [f inc /local tmp][
|
|---|
| 842 |
|
|---|
| 843 | f/font-obj/size: max 10 min 30 f/font-obj/size + inc
|
|---|
| 844 | f/origine-x: f/origine-x / f/x
|
|---|
| 845 | f/xy/x: f/xy/x / f/x
|
|---|
| 846 | tmp: size-text make face [
|
|---|
| 847 | text: "MM"
|
|---|
| 848 | size: 300x300
|
|---|
| 849 | font: f/font-obj
|
|---|
| 850 | para: f/para
|
|---|
| 851 | ]
|
|---|
| 852 | f/x: to integer! tmp/x / 2
|
|---|
| 853 | f/y: tmp/y + 2
|
|---|
| 854 | f/xy/x: f/xy/x * f/x
|
|---|
| 855 | f/origine-x: f/origine-x * f/x
|
|---|
| 856 | f/cursor/size/y: f/y
|
|---|
| 857 | f/cursor/size-box/y: f/y - 2
|
|---|
| 858 | tmp: f/cursor/xy
|
|---|
| 859 | resize f 0
|
|---|
| 860 | click f tmp
|
|---|
| 861 | ]
|
|---|
| 862 |
|
|---|
| 863 | do-selection: func [
|
|---|
| 864 | f
|
|---|
| 865 | /delete /clip
|
|---|
| 866 | /local cursor data idx old-idx start end str start-col end-col scroll n y
|
|---|
| 867 | ][
|
|---|
| 868 | cursor: f/cursor
|
|---|
| 869 | if clip [clip: make string! 256]
|
|---|
| 870 | idx: cursor/global-idx
|
|---|
| 871 | old-idx: cursor/old-idx
|
|---|
| 872 | get-col cursor
|
|---|
| 873 | either old-idx < idx [
|
|---|
| 874 | set [start end] reduce [old-idx idx]
|
|---|
| 875 | set [start-col end-col] reduce [cursor/old-col cursor/col]
|
|---|
| 876 | either start < index? f/data [
|
|---|
| 877 | scroll: start - index? f/data
|
|---|
| 878 | n: -1 + min start to-integer f/nb-lines / 2
|
|---|
| 879 | scroll: scroll - n
|
|---|
| 880 | y: n * f/y + 2
|
|---|
| 881 | ][
|
|---|
| 882 | y: cursor/xy/y +(start - end * f/y)
|
|---|
| 883 | ]
|
|---|
| 884 | ][
|
|---|
| 885 | set [start end] reduce [idx old-idx]
|
|---|
| 886 | set [start-col end-col] reduce [cursor/col cursor/old-col]
|
|---|
| 887 | ]
|
|---|
| 888 | data: at head f/data start
|
|---|
| 889 | if start = end [
|
|---|
| 890 | set [start-col end-col] sort reduce [start-col end-col]
|
|---|
| 891 | ]
|
|---|
| 892 | if delete [
|
|---|
| 893 | locate-cursor cursor
|
|---|
| 894 | delete: copy/part data/1/2 start-col - 1
|
|---|
| 895 | ]
|
|---|
| 896 | loop end - start [
|
|---|
| 897 | if clip [
|
|---|
| 898 | append clip append copy/part at data/1/2 start-col
|
|---|
| 899 | any [find data/1/2 newline tail data/1/2]
|
|---|
| 900 | newline
|
|---|
| 901 |
|
|---|
| 902 | ]
|
|---|
| 903 | either delete [remove data][data: next data]
|
|---|
| 904 | start-col: 1
|
|---|
| 905 | ]
|
|---|
| 906 |
|
|---|
| 907 | str: data/1/2
|
|---|
| 908 | case/all [
|
|---|
| 909 | clip [
|
|---|
| 910 | append clip copy/part at str start-col at str end-col
|
|---|
| 911 | write clipboard:// clip
|
|---|
| 912 | clip: none
|
|---|
| 913 | ]
|
|---|
| 914 | delete [
|
|---|
| 915 | data/1/2: delete
|
|---|
| 916 | case [
|
|---|
| 917 | scroll [render-text f scroll]
|
|---|
| 918 | start <> end [render-text/stay f 1]
|
|---|
| 919 | 'else [recolorize cursor]
|
|---|
| 920 | ]
|
|---|
| 921 | if y [cursor/xy/y: y]
|
|---|
| 922 | constraint f cursor/xy
|
|---|
| 923 | append delete copy/part at str end-col any [find str newline tail str]
|
|---|
| 924 | recolorize cursor
|
|---|
| 925 | ]
|
|---|
| 926 | ]
|
|---|
| 927 | ]
|
|---|
| 928 |
|
|---|
| 929 | click: func [f offset][
|
|---|
| 930 | ;** We don't use the focus function to avoid this dummy system caret (whe have our own)
|
|---|
| 931 | unless same? system/view/focal-face f [
|
|---|
| 932 | if system/view/focal-face [unfocus]
|
|---|
| 933 | system/view/focal-face: f
|
|---|
| 934 | ]
|
|---|
| 935 |
|
|---|
| 936 | constraint f either offset/x - f/xy/x < f/origine-x
|
|---|
| 937 | [as-pair f/origine-x offset/y][offset]
|
|---|
| 938 | show f/cursor
|
|---|
| 939 | ]
|
|---|
| 940 | expand-selector: func [
|
|---|
| 941 | cursor
|
|---|
| 942 | /local idx f pos curr-idx add-selector del-selector upd-selector str
|
|---|
| 943 | x upd-tail upd-head add-tail add-head calc-tail add-middle upd-middle old-idx
|
|---|
| 944 | ][
|
|---|
| 945 |
|
|---|
| 946 | f: cursor/parent-face
|
|---|
| 947 | idx: cursor/global-idx
|
|---|
| 948 | old-idx: cursor/old-idx
|
|---|
| 949 | curr-idx: index? f/data
|
|---|
| 950 | del-selector: [change pos none]
|
|---|
| 951 | calc-tail: [
|
|---|
| 952 | x: 0
|
|---|
| 953 | parse pos [some [
|
|---|
| 954 | thru 'text skip pair! [set str string! | set str word! (str: get str)]
|
|---|
| 955 | (x: x + length? str)
|
|---|
| 956 | ]]
|
|---|
| 957 | x: x + 1 * f/x
|
|---|
| 958 | ]
|
|---|
| 959 | upd-middle: [cursor/selector-xy: back tail pos/1]
|
|---|
| 960 | upd-tail: [do calc-tail change back tail pos/1 as-pair x f/y + 7]
|
|---|
| 961 | upd-head: [change back tail pos/1 as-pair f/origine-x f/y + 7]
|
|---|
| 962 | add-head: [insert-selector f pos f/origine-x]
|
|---|
| 963 | add-tail: [do calc-tail insert-selector f pos x]
|
|---|
| 964 | add-middle: [print "Beginning of the selection lost, TO DO !!!"]
|
|---|
| 965 |
|
|---|
| 966 | upd-selector: [(
|
|---|
| 967 | either old-idx < idx [
|
|---|
| 968 | case [
|
|---|
| 969 | curr-idx < old-idx del-selector
|
|---|
| 970 | curr-idx > idx del-selector
|
|---|
| 971 | curr-idx = idx upd-middle ;** cover until the position of the cursor
|
|---|
| 972 | 'else upd-tail ;** cover the tail of the line
|
|---|
| 973 | ]
|
|---|
| 974 | ][
|
|---|
| 975 | case [
|
|---|
| 976 | curr-idx < idx del-selector
|
|---|
| 977 | curr-idx > old-idx del-selector
|
|---|
| 978 | curr-idx = idx upd-middle ;** cover until the position of the cursor
|
|---|
| 979 | 'else upd-head ;** cover the head of the line
|
|---|
| 980 | ]
|
|---|
| 981 | ]
|
|---|
| 982 | curr-idx: curr-idx + 1
|
|---|
| 983 | )]
|
|---|
| 984 |
|
|---|
| 985 | add-selector: [(
|
|---|
| 986 | either old-idx < idx [
|
|---|
| 987 | case [
|
|---|
| 988 | curr-idx < old-idx none
|
|---|
| 989 | curr-idx > idx none
|
|---|
| 990 | curr-idx = idx [do add-head do upd-middle] ;** cover tail
|
|---|
| 991 | curr-idx = old-idx [do add-middle 'do upd-tail];** cover middle to tail
|
|---|
| 992 | 'else [do add-head do upd-tail] ;** cover the whole line
|
|---|
| 993 | ]
|
|---|
| 994 | ][
|
|---|
| 995 | case [
|
|---|
| 996 | curr-idx < idx none
|
|---|
| 997 | curr-idx > old-idx none
|
|---|
| 998 | curr-idx = idx [do add-tail do upd-middle] ;** cover tail
|
|---|
| 999 | curr-idx = old-idx [do add-middle 'do upd-head];** cover middle to head
|
|---|
| 1000 | 'else [do add-tail do upd-head] ;** cover the whole line
|
|---|
| 1001 | ]
|
|---|
| 1002 | ]
|
|---|
| 1003 | curr-idx: curr-idx + 1
|
|---|
| 1004 | )]
|
|---|
| 1005 |
|
|---|
| 1006 | parse f/effect/draw [
|
|---|
| 1007 | any [
|
|---|
| 1008 | thru 'push into ['hilight pos: [block! upd-selector | add-selector ] to end]
|
|---|
| 1009 | ]
|
|---|
| 1010 | ]
|
|---|
| 1011 | ]
|
|---|
| 1012 | insert-selector: func [f where x][
|
|---|
| 1013 | ;** append an highlight box in the current block at relative x position
|
|---|
| 1014 | change/only where
|
|---|
| 1015 | compose [pen 255.200.10 fill-pen 250.200.10 box (as-pair x 7) (as-pair x f/y + 7)]
|
|---|
| 1016 | ]
|
|---|
| 1017 | remove-selector: func [cursor /local f tmp][
|
|---|
| 1018 | cursor/selection?: false
|
|---|
| 1019 | parse cursor/parent-face/effect/draw [
|
|---|
| 1020 | any [thru 'push into ['hilight tmp: (change tmp none) to end]]
|
|---|
| 1021 | ]
|
|---|
| 1022 | ]
|
|---|
| 1023 | left-word: func [cursor /local f x str blk pos s-blk][
|
|---|
| 1024 | f: cursor/parent-face
|
|---|
| 1025 | str: get-sub-string cursor
|
|---|
| 1026 | blk: skip s-blk: cursor/pos-blk -2
|
|---|
| 1027 |
|
|---|
| 1028 | case [
|
|---|
| 1029 | find/reverse blk 'edit none ;** not head of line
|
|---|
| 1030 | not head? str none ;** neither
|
|---|
| 1031 | 'else [
|
|---|
| 1032 | cursor/xy/x: 100000
|
|---|
| 1033 | if up-cursor cursor [left-word cursor]
|
|---|
| 1034 | exit
|
|---|
| 1035 | ]
|
|---|
| 1036 | ]
|
|---|
| 1037 | x: 0
|
|---|
| 1038 | foreach stuff reduce [any-char space][
|
|---|
| 1039 | while [
|
|---|
| 1040 | all [
|
|---|
| 1041 | not find/reverse str stuff
|
|---|
| 1042 | blk
|
|---|
| 1043 | blk: find/reverse blk 'edit
|
|---|
| 1044 | ]
|
|---|
| 1045 | ][
|
|---|
| 1046 | x: x - 1 + index? str
|
|---|
| 1047 | str: tail get* blk/3
|
|---|
| 1048 | ]
|
|---|
| 1049 | x: x - length? str
|
|---|
| 1050 | str: any [find/reverse str stuff str]
|
|---|
| 1051 | x: x + length? str
|
|---|
| 1052 | ]
|
|---|
| 1053 | either str/1 = #" " [x: x - 1][x: x + (index? str) - index? head str]
|
|---|
| 1054 | if x = 0 [x: -1 + index? str]
|
|---|
| 1055 | constraint f cursor/xy + as-pair x * negate f/x 0
|
|---|
| 1056 | ]
|
|---|
| 1057 |
|
|---|
| 1058 | get-sub-string: func [cursor][
|
|---|
| 1059 | at head do back change [none] cursor/sub-string cursor/pos-len
|
|---|
| 1060 | ]
|
|---|
| 1061 |
|
|---|
| 1062 | right-word: func [cursor /local x str blk pos][
|
|---|
| 1063 | f: cursor/parent-face
|
|---|
| 1064 | blk: s-blk: cursor/pos-blk
|
|---|
| 1065 | str: get-sub-string cursor
|
|---|
| 1066 |
|
|---|
| 1067 | case [
|
|---|
| 1068 | find blk 'edit none ;** not tail of line
|
|---|
| 1069 | not tail? str none ;** neither
|
|---|
| 1070 | 'else [
|
|---|
| 1071 | cursor/xy/x: f/origine-x + f/xy/x
|
|---|
| 1072 | if down-cursor cursor [right-word cursor]
|
|---|
| 1073 | exit
|
|---|
| 1074 | ]
|
|---|
| 1075 | ]
|
|---|
| 1076 | x: 0
|
|---|
| 1077 | foreach stuff reduce [space any-char][
|
|---|
| 1078 | while [
|
|---|
| 1079 | all [
|
|---|
| 1080 | not find str stuff
|
|---|
| 1081 | blk
|
|---|
| 1082 | blk: find/tail blk 'edit
|
|---|
| 1083 | ]
|
|---|
| 1084 | ][
|
|---|
| 1085 | x: x + length? str
|
|---|
| 1086 | str: get* blk/2
|
|---|
| 1087 | ]
|
|---|
| 1088 | x: x - index? str
|
|---|
| 1089 | str: any [find str stuff str]
|
|---|
| 1090 | x: x + index? str
|
|---|
| 1091 | ]
|
|---|
| 1092 | if str/1 = #" " [x: x + length? str]
|
|---|
| 1093 | if x = 0 [x: length? str]
|
|---|
| 1094 | constraint f cursor/xy + as-pair x * f/x 0
|
|---|
| 1095 | ]
|
|---|
| 1096 |
|
|---|
| 1097 | scroll-x: func [f x][
|
|---|
| 1098 | f/h-scroller/feel/drag f/h-scroller as-pair x 0
|
|---|
| 1099 | ]
|
|---|
| 1100 |
|
|---|
| 1101 | locate-cursor: func [cursor /local x idx f][
|
|---|
| 1102 | f: cursor/parent-face
|
|---|
| 1103 | unless cursor/show? [
|
|---|
| 1104 | either (idx: cursor/global-idx) < index? f/data [
|
|---|
| 1105 | render-text f idx - index? f/data
|
|---|
| 1106 | ][
|
|---|
| 1107 | render-text f idx - f/nb-lines + 1 - index? f/data
|
|---|
| 1108 | ]
|
|---|
| 1109 | ]
|
|---|
| 1110 | x: cursor/xy/x
|
|---|
| 1111 | if any [
|
|---|
| 1112 | x > (f/size/x - f/x)
|
|---|
| 1113 | x < f/x
|
|---|
| 1114 | ][scroll-x f f/x * 20 + f/xy/x + cursor/xy/x - f/size/x ]
|
|---|
| 1115 | ]
|
|---|
| 1116 |
|
|---|
| 1117 |
|
|---|
| 1118 | move-cursor: func [
|
|---|
| 1119 | cursor
|
|---|
| 1120 | /left /right
|
|---|
| 1121 | /local f pos offset len
|
|---|
| 1122 | ][
|
|---|
| 1123 | f: cursor/parent-face
|
|---|
| 1124 | ;** locate-cursor cursor
|
|---|
| 1125 | ;** print remold [cursor/pos-len cursor/sub-string]
|
|---|
| 1126 | case [
|
|---|
| 1127 | left [
|
|---|
| 1128 | if len: either string? cursor/sub-string [
|
|---|
| 1129 | either cursor/pos-len = 1 [1][
|
|---|
| 1130 | cursor/pos-len: cursor/pos-len - 1
|
|---|
| 1131 | cursor/sub-string: back cursor/sub-string
|
|---|
| 1132 | cursor/xy/x: cursor/xy/x - f/x
|
|---|
| 1133 | false
|
|---|
| 1134 | ]
|
|---|
| 1135 | ][
|
|---|
| 1136 | either cursor/pos-len = 1 [1][
|
|---|
| 1137 | cursor/pos-len: 1
|
|---|
| 1138 | cursor/xy/x: cursor/xy/x - (f/x * length? get cursor/sub-string)
|
|---|
| 1139 | false
|
|---|
| 1140 | ]
|
|---|
| 1141 | ][
|
|---|
| 1142 | either pos: find/tail/reverse skip cursor/pos-blk -2 'edit [
|
|---|
| 1143 | either string? pos/2 [
|
|---|
| 1144 | len: length? pos/2
|
|---|
| 1145 | cursor/sub-string: at pos/2 len
|
|---|
| 1146 | ][
|
|---|
| 1147 | cursor/sub-string: pos/2
|
|---|
| 1148 | ]
|
|---|
| 1149 | cursor/pos-len: len
|
|---|
| 1150 | cursor/xy/x: pos/1/1 + (len - 1 * f/x)
|
|---|
| 1151 | cursor/pos-blk: skip pos 1
|
|---|
| 1152 | ][
|
|---|
| 1153 | if cursor/global-idx > 1 [
|
|---|
| 1154 | cursor/xy/x: 100000
|
|---|
| 1155 | up-cursor cursor
|
|---|
| 1156 | ]
|
|---|
| 1157 | ]
|
|---|
| 1158 | ]
|
|---|
| 1159 | ]
|
|---|
| 1160 | right [
|
|---|
| 1161 | if len: either string? cursor/sub-string [
|
|---|
| 1162 | either tail? cursor/sub-string [2][
|
|---|
| 1163 | cursor/pos-len: cursor/pos-len + 1
|
|---|
| 1164 | cursor/sub-string: next cursor/sub-string
|
|---|
| 1165 | cursor/xy/x: cursor/xy/x + f/x
|
|---|
| 1166 | false
|
|---|
| 1167 | ]
|
|---|
| 1168 | ][
|
|---|
| 1169 | either cursor/pos-len > 1 [2][
|
|---|
| 1170 | cursor/pos-len: 1 + length? get cursor/sub-string
|
|---|
| 1171 | cursor/xy/x: cursor/xy/x + (f/x * length? get cursor/sub-string)
|
|---|
| 1172 | false
|
|---|
| 1173 | ]
|
|---|
| 1174 | ][
|
|---|
| 1175 | either pos: find/tail cursor/pos-blk 'edit [
|
|---|
| 1176 | either string? pos/2 [
|
|---|
| 1177 | cursor/sub-string: at pos/2 len
|
|---|
| 1178 | ][
|
|---|
| 1179 | len: 1 + length? get pos/2
|
|---|
| 1180 | cursor/sub-string: pos/2
|
|---|
| 1181 | ]
|
|---|
| 1182 | cursor/pos-len: len
|
|---|
| 1183 | cursor/xy/x: pos/1/1 + (len - 1 * f/x)
|
|---|
| 1184 | cursor/pos-blk: skip pos 1
|
|---|
| 1185 | ][
|
|---|
| 1186 | if cursor/global-idx < index? back tail f/data [
|
|---|
| 1187 | cursor/xy/x: f/origine-x + f/xy/x
|
|---|
| 1188 | down-cursor cursor
|
|---|
| 1189 | ]
|
|---|
| 1190 | ]
|
|---|
| 1191 | ]
|
|---|
| 1192 | ]
|
|---|
| 1193 | ]
|
|---|
| 1194 | ]
|
|---|
| 1195 | delay-show: func [f][
|
|---|
| 1196 | f/ask: 'show ;** delay the show event, speed issue
|
|---|
| 1197 | f/delay: 1 ; wait 2 checks
|
|---|
| 1198 | f/rate: 10 ; check 10 times per second
|
|---|
| 1199 | ]
|
|---|
| 1200 | down-cursor: func [cursor /local f tmp][
|
|---|
| 1201 | f: cursor/parent-face
|
|---|
| 1202 | if cursor/global-idx < index? back tail f/data [
|
|---|
| 1203 | if cursor/idx = f/nb-lines [
|
|---|
| 1204 | delay-show f
|
|---|
| 1205 | render-text f 1
|
|---|
| 1206 | ]
|
|---|
| 1207 | tmp: cursor/xy + third cursor/data
|
|---|
| 1208 | if f/save-x = 0 [f/save-x: tmp/x]
|
|---|
| 1209 | constraint f as-pair f/save-x tmp/y
|
|---|
| 1210 | unless f/ask = 'show [show cursor]
|
|---|
| 1211 | true
|
|---|
| 1212 | ]
|
|---|
| 1213 | ]
|
|---|
| 1214 | up-cursor: func [cursor /local f tmp][
|
|---|
| 1215 | f: cursor/parent-face
|
|---|
| 1216 | if cursor/global-idx > 1 [
|
|---|
| 1217 | if cursor/idx = 1 [
|
|---|
| 1218 | delay-show f
|
|---|
| 1219 | render-text f -1
|
|---|
| 1220 | ]
|
|---|
| 1221 | tmp: cursor/xy - pick cursor/data -2
|
|---|
| 1222 | if f/save-x = 0 [f/save-x: tmp/x]
|
|---|
| 1223 | constraint f as-pair f/save-x tmp/y
|
|---|
| 1224 | unless f/ask = 'show [show cursor]
|
|---|
| 1225 | true
|
|---|
| 1226 | ]
|
|---|
| 1227 | ]
|
|---|
| 1228 |
|
|---|
| 1229 | insert-char: func [cursor char /local f text refresh?][
|
|---|
| 1230 | f: cursor/parent-face
|
|---|
| 1231 | if cursor/selection? [
|
|---|
| 1232 | do-selection/delete f
|
|---|
| 1233 | locate-cursor cursor
|
|---|
| 1234 | refresh?: true
|
|---|
| 1235 | ]
|
|---|
| 1236 | text: cursor/sub-string
|
|---|
| 1237 | either string? text [
|
|---|
| 1238 | insert text char
|
|---|
| 1239 | ][
|
|---|
| 1240 | insert insert
|
|---|
| 1241 | either cursor/pos-len = 1 [cursor/pos-blk][next cursor/pos-blk]
|
|---|
| 1242 | 'new
|
|---|
| 1243 | char
|
|---|
| 1244 | ]
|
|---|
| 1245 | collect cursor
|
|---|
| 1246 | cursor/xy/x: cursor/xy/x + either char = tab [4 * f/x][f/x * length? form char]
|
|---|
| 1247 | if refresh? [
|
|---|
| 1248 | render-text/stay f 1
|
|---|
| 1249 | constraint f cursor/xy
|
|---|
| 1250 | ]
|
|---|
| 1251 | ]
|
|---|
| 1252 |
|
|---|
| 1253 | delete-char: func [cursor /local pos f data str1 str2 end][
|
|---|
| 1254 | text: cursor/sub-string
|
|---|
| 1255 | unless either string? text [
|
|---|
| 1256 | unless tail? text [remove text]
|
|---|
| 1257 | ][
|
|---|
| 1258 | if cursor/pos-len = 1 [remove back cursor/pos-blk] ;**remove the offset
|
|---|
| 1259 | ][
|
|---|
| 1260 | either pos: find/tail cursor/pos-blk 'edit [
|
|---|
| 1261 | either string? pos/2 [
|
|---|
| 1262 | remove pos/2
|
|---|
| 1263 | ][
|
|---|
| 1264 | remove pos ;** remove the offset
|
|---|
| 1265 | ]
|
|---|
| 1266 | ][
|
|---|
| 1267 | regroup-2-lines cursor
|
|---|
| 1268 | exit
|
|---|
| 1269 | ]
|
|---|
| 1270 | ]
|
|---|
| 1271 |
|
|---|
| 1272 | collect cursor
|
|---|
| 1273 | ]
|
|---|
| 1274 | get-col: func [cursor /local col pos][
|
|---|
| 1275 | col: 0
|
|---|
| 1276 | pos: cursor/data/1
|
|---|
| 1277 | while [pos: find/tail pos 'edit][
|
|---|
| 1278 | if same? pos: next pos cursor/pos-blk [break]
|
|---|
| 1279 | col: col + either string? pos/1 [length? head pos/1][1]
|
|---|
| 1280 | ]
|
|---|
| 1281 | col: col + either string? cursor/sub-string
|
|---|
| 1282 | [cursor/pos-len]
|
|---|
| 1283 | [either cursor/pos-len > 1 [2][1]]
|
|---|
| 1284 | cursor/col: col
|
|---|
| 1285 | ]
|
|---|
| 1286 |
|
|---|
| 1287 | collect: func [cursor /local full txt pos][
|
|---|
| 1288 | full: clear {}
|
|---|
| 1289 | add-full: [(full: insert full either word? txt [#"^-"][txt])]
|
|---|
| 1290 | parse cursor/data/1 [
|
|---|
| 1291 | any [thru 'edit opt [
|
|---|
| 1292 | pair!
|
|---|
| 1293 | opt ['new set txt skip add-full]
|
|---|
| 1294 | set txt skip add-full
|
|---|
| 1295 | opt ['new set txt skip add-full]
|
|---|
| 1296 | ]]
|
|---|
| 1297 | ]
|
|---|
| 1298 | poke first at cursor/parent-face/data cursor/idx 2 copy head full
|
|---|
| 1299 | ]
|
|---|
| 1300 | regroup-2-lines: func [cursor][
|
|---|
| 1301 | f: cursor/parent-face
|
|---|
| 1302 | data: at head f/data cursor/global-idx
|
|---|
| 1303 | unless tail? next data [
|
|---|
| 1304 | str1: either end: find data/1/2 newline [copy/part data/1/2 end][data/1/2]
|
|---|
| 1305 | str2: either end: find data/2/2 newline [copy/part data/2/2 end][data/2/2]
|
|---|
| 1306 | append str1 str2
|
|---|
| 1307 | poke data/1 2 str1
|
|---|
| 1308 | remove next data
|
|---|
| 1309 | render-text/stay f cursor/idx
|
|---|
| 1310 | ]
|
|---|
| 1311 | ]
|
|---|
| 1312 |
|
|---|
| 1313 | ;*** Reconstruct a line (draw block) after an insert
|
|---|
| 1314 | ;*** (which contains modified sub-strings)
|
|---|
| 1315 | ;* if the line contains a multi-line string, then other lines below
|
|---|
| 1316 | ;* may be reconstructed too.
|
|---|
| 1317 | recolorize: func [
|
|---|
| 1318 | cursor
|
|---|
| 1319 | /local line f multi-p multi data pos-head
|
|---|
| 1320 | ][
|
|---|
| 1321 | f: cursor/parent-face
|
|---|
| 1322 | data: cursor/data
|
|---|
| 1323 | line: at f/data cursor/idx
|
|---|
| 1324 |
|
|---|
| 1325 | change skip data 2
|
|---|
| 1326 | either colorize f line clear find/tail data/1 string!
|
|---|
| 1327 | [as-pair 0 2 * f/y][as-pair 0 f/y]
|
|---|
| 1328 |
|
|---|
| 1329 | loop f/nb-lines - cursor/idx [
|
|---|
| 1330 | if tail? next line [break]
|
|---|
| 1331 |
|
|---|
| 1332 | multi-p: line/1/1
|
|---|
| 1333 | multi: line/2/1
|
|---|
| 1334 | if any [
|
|---|
| 1335 | all [find [1 2] multi-p find [1 3] multi]
|
|---|
| 1336 | all [find [3 4] multi-p find [2 4] multi]
|
|---|
| 1337 | ][break]
|
|---|
| 1338 |
|
|---|
| 1339 | data: find/tail data 'push
|
|---|
| 1340 | line: next line
|
|---|
| 1341 | change skip data 2
|
|---|
| 1342 | either colorize f line clear find/tail data/1 string!
|
|---|
| 1343 | [as-pair 0 2 * f/y][as-pair 0 f/y]
|
|---|
| 1344 | ]
|
|---|
| 1345 | constraint f cursor/xy
|
|---|
| 1346 | set-y f 5
|
|---|
| 1347 | ]
|
|---|
| 1348 |
|
|---|
| 1349 | constraint: func [
|
|---|
| 1350 | f offset
|
|---|
| 1351 | /local cursor y blk pair text cont? idx save-pair at-tail? len
|
|---|
| 1352 | ][
|
|---|
| 1353 | y: idx: 0
|
|---|
| 1354 | cont?: none
|
|---|
| 1355 | cursor: f/cursor
|
|---|
| 1356 | at-tail?: false
|
|---|
| 1357 | parse f/effect/draw [
|
|---|
| 1358 | some [
|
|---|
| 1359 | thru 'push blk: block! skip set pair pair!
|
|---|
| 1360 | (idx: idx + 1 cont?: if offset/y <= (y + pair/y) ['break])
|
|---|
| 1361 | cont? (y: y + pair/y)
|
|---|
| 1362 | ]
|
|---|
| 1363 | :blk into [
|
|---|
| 1364 | (cont?: none)
|
|---|
| 1365 | thru 'edit set pair pair! pos-head: text: skip
|
|---|
| 1366 | any [
|
|---|
| 1367 | thru 'edit set save-pair pair!
|
|---|
| 1368 | (cont?: if offset/x < save-pair/x ['break])
|
|---|
| 1369 | cont?
|
|---|
| 1370 | text: skip (pair: save-pair)
|
|---|
| 1371 | ]
|
|---|
| 1372 | opt [to 'edit | (at-tail?: true)]
|
|---|
| 1373 | ]
|
|---|
| 1374 | ]
|
|---|
| 1375 | either string? text/1 [
|
|---|
| 1376 | offset: min length? text/1 to integer! offset/x - pair/x / f/x
|
|---|
| 1377 | cursor/xy: as-pair
|
|---|
| 1378 | offset * f/x + pair/x
|
|---|
| 1379 | y + 7
|
|---|
| 1380 | cursor/sub-string: skip text/1 offset
|
|---|
| 1381 | cursor/pos-len: offset + 1
|
|---|
| 1382 | ][
|
|---|
| 1383 | ;** special case, for tags (like tabulations)
|
|---|
| 1384 | len: length? get text/1
|
|---|
| 1385 | len: either offset/x < (f/x * len / 2 + pair/x) [0][len]
|
|---|
| 1386 | cursor/xy: as-pair f/x * len + pair/x y + 7
|
|---|
| 1387 | cursor/sub-string: text/1
|
|---|
| 1388 | cursor/pos-len: 1 + len
|
|---|
| 1389 | ]
|
|---|
| 1390 | cursor/head?: pos-head
|
|---|
| 1391 | cursor/data: blk
|
|---|
| 1392 | cursor/pos-blk: text
|
|---|
| 1393 | cursor/idx: idx
|
|---|
| 1394 | cursor/global-idx: idx - 1 + index? f/data
|
|---|
| 1395 |
|
|---|
| 1396 | case [
|
|---|
| 1397 | cursor/xy/x < 0 [scroll-x f -20 * f/x + cursor/xy/x]
|
|---|
| 1398 | cursor/xy/x > f/size/x [scroll-x f f/x * 20 + f/xy/x + cursor/xy/x - f/size/x]
|
|---|
| 1399 | ]
|
|---|
| 1400 | ]
|
|---|
| 1401 | ]
|
|---|
| 1402 | append init [
|
|---|
| 1403 | data: append/only make block! 1000 reduce [0 ""]
|
|---|
| 1404 | v-scroller: make v-scroller []
|
|---|
| 1405 | h-scroller: make h-scroller []
|
|---|
| 1406 | cursor: make cursor []
|
|---|
| 1407 | pane: reduce [cursor v-scroller h-scroller]
|
|---|
| 1408 | edge: make edge []
|
|---|
| 1409 | data: build-data [""] self
|
|---|
| 1410 | feel/resize self first reduce [size size: 0]
|
|---|
| 1411 | feel/inc-font-size f 0
|
|---|
| 1412 | ;** remove the event handler if found
|
|---|
| 1413 | foreach func system/view/screen-face/feel/event-funcs [
|
|---|
| 1414 | if {area-tc handler} = pick third :func 1 [
|
|---|
| 1415 | remove-event-func :func
|
|---|
| 1416 | ]
|
|---|
| 1417 | ]
|
|---|
| 1418 | insert-event-func :event-func
|
|---|
| 1419 | ]
|
|---|
| 1420 | export: context [
|
|---|
| 1421 | font+: func [f][f/feel/inc-font-size f +1]
|
|---|
| 1422 | font-: func [f][f/feel/inc-font-size f -1]
|
|---|
| 1423 | bold: func [f][f/feel/bold f]
|
|---|
| 1424 | ]
|
|---|
| 1425 | ]
|
|---|
| 1426 | ]
|
|---|
| 1427 | ] ;** end of global context
|
|---|
| 1428 |
|
|---|
| 1429 | ;** TEST
|
|---|
| 1430 | do test: does [
|
|---|
| 1431 | unview/all
|
|---|
| 1432 | view/new/options layout [
|
|---|
| 1433 | across space 2x2 origin 2x2
|
|---|
| 1434 | btn "open" [t/open-file none]
|
|---|
| 1435 | btn "save" [ if request "Save file ? " [ t/save-file]]
|
|---|
| 1436 | btn "dbg" [ do %../Anamonitor.r ] tab space 0x2
|
|---|
| 1437 | btn "+" [t/export/font+ t]
|
|---|
| 1438 | btn "-" [t/export/font- t]
|
|---|
| 1439 | tab btn "B/N" [t/export/bold t]
|
|---|
| 1440 | below t: area-tc 650x500
|
|---|
| 1441 | ][resize]
|
|---|
| 1442 | if exists? %area-tc-03.r [t/open-file %area-tc-03.r]
|
|---|
| 1443 | do-events
|
|---|
| 1444 | ]
|
|---|
| 1445 | halt |
|---|
