Instantly share code, notes, and snippets.

@toomasv /rtbox.red
Last active May 21, 2018

Embed
What would you like to do?
Red [
Author: "Toomas Vooglaid"
Started: 2018-05-01
Purpose: "First steps into rich-text box"
]
ctx: context [
env: self
start: end: 1
diff: 0
dbl: no
txt: p: l: style*: none
itext: copy []
sep: charset { ,.!?:;"'`()[]{}/^-^M}
found: found2: found3: dn?: none
appendix: copy []
bind colors: exclude sort extract load help-string tuple! 2 [glass] context [transparent: 0.0.0.254]
pallette: [
title "Select color" origin 1x1 space 1x1
style clr: base 15x15 on-down [dn?: true] on-up [
if dn? [env/color: face/extra unview]
]
]
x: 0
make-pallette: has [j][
foreach j colors [
append pallette compose/deep [
clr (j) extra (to-lit-word j)
]
if (x: x + 1) % 9 = 0 [append pallette 'return]
]
]
make-pallette
color: black
select-color: does [view/flags pallette [modal popup]]
changing!: make typeset! [integer! string! tuple!]
changing?: func [value [any-type!]][
find changing! type? :value
]
set-style: func [face style /color clr][
either face/data/1/y > 0 [
either found: find next face/data face/data/1 [
found2: find next found pair!
style*: pick reduce [type? style style] changing? style
found3: either found2 [find/part found style* found2][find found style*]
if all [style* = tuple! 'backdrop = found3/-1][found3: find next found3 tuple!]
either found3 [
either changing? style [
change found3 style
][
either style = 'backdrop [
change next found3 clr
][
remove found3
]
]
if any [
1 = length? found
attempt [1 = offset? found find next found pair!]
][
remove found
]
][
append clear appendix style
if color [append appendix clr]
either found2 [insert found2 appendix][append found appendix]
]
][
append append clear appendix face/data/1 style
if color [append appendix clr]
append face/data appendix
]
][
]
]
set-caret: func [face start /diff len /wheel][
len: any [len 0]
face/data/1: as-pair start len
either len > 0 [
crt/visible?: no
self/diff: len
][
crt/visible?: face/data/1/x > 0 [yes][no]
self/start: end: face/data/1/x
self/diff: 0
caret/2: caret-to-offset face start
caret/3: as-pair caret/2/x second caret-to-offset/lower face start
unless wheel [
if caret/3/y > face/size/y [scroll face]
if all [
(caret/3/y - rich-text/line-height? face start) <= 0
1 < index? face/text
][scroll/up face]
]
]
]
scroll: func [face /up /wheel /local latest][
either up [; scroll up - text down
attempt [
latest: index? face/text
face/text: at head face/text take itext
set-markers face latest - index? face/text
either wheel [
set-caret/diff/wheel face face/data/1/x face/data/1/y
][
set-caret/diff face face/data/1/x face/data/1/y
]
]
][; scroll down - text up
unless itext/1 = index? face/text [insert itext index? face/text]
face/text: at face/text offset-to-caret face as-pair 0 rich-text/line-height? face 1
set-markers face itext/1 - index? face/text
either wheel [
set-caret/diff/wheel face face/data/1/x face/data/1/y
][
set-caret/diff face face/data/1/x face/data/1/y
]
]
;probe head itext
face/data: face/data
]
set-markers: func [face delta][
parse face/data [some [s: pair! (s/1/x: s/1/x + delta) | skip]]
start: start + delta end: end + delta
]
adjust-markers: func [face type len][
switch type [
key [
parse next face/data [any [s: pair! (
case [
all [s/1/x + 1 < face/data/1/x s/1/x + s/1/y >= face/data/1/x][s/1/y: s/1/y - len + 1]
s/1/x + 2 > face/data/1/x [s/1/x: s/1/x - len + 1]
]
) | skip]]
]
del [
parse next face/data [any [s: pair! (
len: either len > 0 [len][1]
case [
all [s/1/x <= face/data/1/x s/1/x + s/1/y > face/data/1/x][s/1/y: s/1/y - len]
s/1/x + 2 > face/data/1/x [s/1/x: s/1/x - len]
]
) | skip]]
]
ins [
parse next face/data [any [s: pair! (
case [
; marker containes selected text
all [s/1/x + 1 < len/1 s/1/x + s/1/y >= (len/1 + len/2)][s/1/y: s/1/y - len/2 + len/3]
; selection starts before marker and ends inside marker
all [s/1/x + 2 > len/1 s/1/x < (len/1 + len/2) s/1/x + s/1/y >= (len/1 + len/2)][s/1/x: face/data/1/x]
; selection starts inside marker and ends after marker
all [s/1/x + 1 < len/1 len/1 < (s/1/x + s/1/y) s/1/x + s/1/y < (len/1 + len/2)][s/1/y: face/data/1/x - len/3 - s/1/x]
; selection lies before the marker
s/1/x + 2 > len/1 [probe "hi" s/1/x: s/1/x - len/2 + len/3]
]
) | skip]]
]
]
]
view win: layout [
title "Rich-text box"
panel [
origin 0x0
space 5x0
style b: button 24x24 [
set-style sb face/extra
win/selected: sb
]
b "i" extra 'italic
b "b" extra 'bold
b "u" extra 'underline
b "s" extra 'strike
base 24x24 225.225.225 draw [pen 170.170.170 box 0x0 23x23 pen red text 8x4 "T"][
select-color
set-style sb get color
]
base 24x24 225.225.225 draw [pen 170.170.170 fill-pen red box 0x0 23x23 pen black text 8x4 "T"][
select-color
set-style/color sb 'backdrop get color
]
drop-down select 2 40x24
data ["8" "9" "10" "11" "12" "14" "16" "18" "20" "22" "24" "36" "48"]
on-change [set-style sb to-integer pick face/data face/selected]
on-enter [set-style sb to-integer face/text win/selected: sb]
button "X" 24x24 [clear at sb/data 4]
] return
tp: panel [
at 0x0 box white 320x220 ;draw [line 12x2 12x20]
sb: rich-text 300x200 "" focus
cursor I-beam all-over
with [data: [1x0 backdrop silver]]
on-down [
win/selected: face
either event/shift? [
end: offset-to-caret face event/offset
set-caret/diff face min start end absolute end - start
][
start: offset-to-caret face event/offset
]
]
on-over [
if event/down? [
end: offset-to-caret face event/offset
set-caret/diff face min start end absolute end - start
]
]
on-up [
either dbl [dbl: no][
end: offset-to-caret face event/offset
set-caret/diff face min start end absolute end - start
]
]
on-dbl-click [
start: either found: find/reverse at face/text offset-to-caret face event/offset sep [2 + (index? found) - index? face/text][1]
end: either found: find next at face/text start sep [2 + (index? found) - index? face/text][1 + length? face/text]
dbl: yes
set-caret/diff face start end - start
]
on-wheel [
either event/picked > 0 [scroll/up/wheel face][scroll/wheel face]
]
on-key [
either event/ctrl? [
switch event/key [
#"^A" [set-caret/diff face 1 1 + length? face/text]
#"^C" [if face/data/1/y > 0 [write-clipboard copy/part at face/text face/data/1/x face/data/1/y]]
#"^X" [
if face/data/1/y > 0 [
write-clipboard copy/part at face/text face/data/1/x face/data/1/y
remove/part at face/text face/data/1/x len: face/data/1/y
set-caret face face/data/1/x
adjust-markers face 'del len; Unfinished! Check overlapping regions
]
]
#"^V" [
change/part at face/text posx: face/data/1/x txt: read-clipboard len: face/data/1/y
set-caret face face/data/1/x + length? txt
adjust-markers face 'ins reduce [posx len length? txt]
]
#"^B" [set-style face 'bold]
#"^I" [set-style face 'italic]
#"^U" [set-style face 'underline]
#"^S" [set-style face 'strike]
left [
either event/shift? [
either end > start [
end: either found: find/reverse back at face/text face/data/1/x + face/data/1/y sep [2 + (index? found) - index? face/text][1]
set-caret/diff face min face/data/1/x end absolute end - face/data/1/x
][
set-caret/diff face end: either found: find/reverse back at face/text face/data/1/x sep [2 + (index? found) - index? face/text][1]
face/data/1/x + face/data/1/y - end
]
][
set-caret face either found: find/reverse back at face/text face/data/1/x sep [2 + (index? found) - index? face/text][1]
]
]
right [
either event/shift? [
either end < start [
end: either found: find next at face/text face/data/1/x sep [2 + (index? found) - index? face/text][1 + length? face/text]
set-caret/diff face min start end absolute end - start
][
set-caret/diff face face/data/1/x
(end: either found: find next at face/text face/data/1/x + face/data/1/y sep [2 + (index? found) - index? face/text][1 + length? face/text]) - face/data/1/x
]
][
set-caret face either found: find next at face/text face/data/1/x sep [2 + (index? found) - index? face/text][1 + length? face/text]]
]
#"^~" [
remove/part at face/text end: either found: find/reverse back at face/text face/data/1/x sep [2 + (index? found) - index? face/text][1]
(face/data/1/x - end)
set-caret face end
]
delete [
remove/part at face/text face/data/1/x
(either found: find next at face/text face/data/1/x sep
[2 + (index? found) - index? face/text][1 + length? face/text]) - face/data/1/x
set-caret face face/data/1/x
]
end [
either event/shift? [
set-caret/diff face start (1 + length? face/text) - start
][
set-caret face 1 + length? face/text
]
]
home [
if 1 < index? face/text [start: start + index? face/text face/text: head face/text clear itext]
either event/shift? [
set-caret/diff face 1 start - 1
][
set-caret face 1
]
]
down [
found: find next at face/text end #"^M"
either event/shift? [
either found [
set-caret/diff face min start end: 2 + (index? found) - index? face/text absolute end - start
][
set-caret/diff face min start end: (length? face/text) absolute end - start + 1
]
][
either found [set-caret face 2 + (index? found) - index? face/text][set-caret face 1 + length? face/text]
]
]
up [
found: find/reverse back at face/text end #"^M"
unless found [if 1 < index? face/text [start: start + index? face/text face/text: head face/text clear itext]]
either event/shift? [
either found [
set-caret/diff face min start end: 2 + (index? found) - index? face/text absolute end - start
][
set-caret/diff face end: 1 start - 1
]
][
either found [set-caret face 2 + (index? found) - index? face/text][set-caret face 1]
]
]
]
][
switch/default event/key [
#"^H" [
len: diff
either diff > 0 [
remove/part at face/text face/data/1/x face/data/1/y 1
][
remove at face/text face/data/1/x - 1
]
set-caret face face/data/1/x - pick [0 1] diff > 0
adjust-markers face 'del len
]
delete [
len: diff
remove/part at face/text face/data/1/x pick reduce [face/data/1/y 1] diff > 0
set-caret face face/data/1/x
adjust-markers face 'del len
]
left [
either event/shift? [
end: end - 1
set-caret/diff face min start end absolute end - start
][
set-caret face face/data/1/x - pick [0 1] diff > 0
]
]
right [
either event/shift? [
end: end + 1
set-caret/diff face min start end absolute end - start
][
set-caret face face/data/1/x + either 0 = face/data/1/y [1][face/data/1/y]
]
]
down [
p: caret-to-offset face end
l: caret-to-offset/lower face end
end: offset-to-caret face as-pair p/x l/y: l/y + 14
either event/shift? [
set-caret/diff face min start end absolute end - start
][
set-caret face end
]
if l/y > face/size/y [scroll face]
]
up [
p: caret-to-offset face end
l: caret-to-offset/lower face end
if all [1 < index? face/text l/y <= rich-text/line-height? face end][
scroll/up face
]; pooleli!
end: offset-to-caret face as-pair p/x l/y - 1 - rich-text/line-height? face end
either event/shift? [
set-caret/diff face min start end absolute end - start
][
set-caret face end
]
]
end [
end: offset-to-caret face as-pair face/size/x second caret-to-offset face start
unless equal? second caret-to-offset face start second caret-to-offset face end [end: end - 1]
either event/shift? [
set-caret/diff face start end - start
][
set-caret face end
]
]
home [
end: offset-to-caret face as-pair 0 second caret-to-offset face start
either event/shift? [
set-caret/diff face end start - end
][
set-caret face end
]
]
][
change/part at face/text face/data/1/x event/key len: face/data/1/y
set-caret face face/data/1/x + 1
adjust-markers face 'key len
]
]
face/data: face/data
]
at 10x10 crt: box glass 300x200 rate 3
draw [pen black caret: line 0x1 0x16]
on-time [face/draw/2: pick [glass black] face/draw/2 = 'black]
]
]
]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment