Skip to content

Instantly share code, notes, and snippets.

@luce80

luce80/Red-vid-styles.red

Last active April 23, 2024 17:30
Show Gist options
  • Save luce80/433286c66d98997aff6e69fbd6323a35 to your computer and use it in GitHub Desktop.
Save luce80/433286c66d98997aff6e69fbd6323a35 to your computer and use it in GitHub Desktop.
Download ZIP
Some useful Red View/VID styles
Raw
area-plus.red
Red [
title: "Text area with multiple undos"
author: @luce80
Rights: "Copyright (C) 2022 Marco Antoniazzi. All rights reserved."
License: BSL-1
file: %area-plus.red
gist: https://gist.githubusercontent.com/luce80/433286c66d98997aff6e69fbd6323a35/raw/f855edab024f19b1cc71ae9565f29f7403c96408/area-plus.red
gist-view: https://gist.github.com/luce80/433286c66d98997aff6e69fbd6323a35#file-area-plus-red
date: 26-12-2022
version: 0.5.4
history: [
0.0.0 [05-11-2022 "Started"]
0.1.0 [08-11-2022 "Minimum working version"]
0.2.0 [17-11-2022 "Minimum working version with diff"]
0.3.0 [19-11-2022 "fix selection replacement"]
0.4.0 [20-11-2022 "Redone simplified thanks to using on-change, Ctrl+D, indent/outdent"]
0.5.2 [24-11-2022 "indent/outdent, fix compatibilty with user actors, fix auto-sync? (??)"]
0.5.3 [26-11-2022 "fix selected with tab indent/outdent"]
0.5.4 [26-12-2022 "fix when event is none"]
]
Notes: {
Use <Ctrl+Z> as always to undo, use <Ctrl+Shift+Z> to redo.
<Ctrl+D> = duplicate selection
Selection+<Tab> = indent text with tabs
Selection+<Shift+Tab> = outdent text removing tabs
Undoing is done with only removes and insertions, there are no changes. This means that a change is made by a remove followed by an insertion, and this
means that when undoing a change some text will first disappear!
Since currently Red does not permit to move the caret, I am using an ugly-but-better-then-nothing workaround by selecting 1 character.
DISCLAIMER: Use at your own risk. It seems to work on my system.
}
]
probedo: func [code [block!] /local result][print [mold code mold/only result: reduce code] :result]
probedo: func [code [block!] /local result][]
system/view/VID/styles/area-plus: [
default-actor: on-change
template: [
type: 'area
size: 150x150 ; same as default
text: ""
font: make font! [
size: 10
]
selected-range: none
ctrlz: 0
key: none ; cached current key pressed
optimize: true
old-text: copy ""
last-added: copy ""
undos: copy []
redos: copy []
undo: func [][actors/undo self]
redo: func [][actors/redo self]
actors: [
selection: func [text [string!] selection [pair!]][
copy/part at text selection/1 selection/2 - selection/1 + 1
]
indent: func [string [string!] selected [pair!] /local start beg end] [
start: at string selected/1
start: any [find/tail/reverse start newline head string]
beg: index? start
end: selected/2
until [
insert start tab
end: end + 1
start: find/tail start newline
any [
none? start
(index? start) > end
]
]
;head string
as-pair beg end
]
outdent: func [string [string!] selected [pair!] /local start beg end] [
start: at string selected/1
start: any [find/tail/reverse start newline head string]
beg: index? start
end: selected/2
until [
if start/1 = tab [
remove start
end: end - 1
]
start: find/tail start newline
any [
none? start
(index? start) > end
]
]
;head string
as-pair beg end
]
diff: func [string1 [string!] string2 [string!] /local b n1 n2 delta] [
if string1 == string2 [return [i 0 ""]]
n1: length? string1
n2: length? string2
delta: absolute n1 - n2
if find/case/match string1 string2 [return reduce ['r n2 copy/part skip string1 n2 delta]]
if find/case/match string2 string1 [return reduce ['i n1 copy/part skip string2 n1 delta]]
n1: 1
n2: 1
while [(string1/:n1) = (string2/:n2)] [n1: n1 + 1 n2: n2 + 1]
b: n1 - 1
n1: length? string1
n2: length? string2
while [(string1/:n1) = (string2/:n2)] [n1: n1 - 1 n2: n2 - 1]
;print ["b" b "delta" delta "n1" n1 "n2" n2]
reduce either n1 > n2 [
['r b copy/part skip string1 b delta]
] [
['i b copy/part skip string2 b delta]
]
]
add-to-undos: func [face [object!] text [string!] /local new old][
if all [
face/ctrlz <= 1 ; FIXME:
face/text <> face/last-added
;face/text <> ""
] [
new: diff face/last-added face/text
old: any [last face/undos [i -1 ""]]
either all [
face/optimize
new/1 = old/1
new/2 = (old/2 + length? old/3)
][
; optimize by joining insertions
append old/3 new/3
][
append/only face/undos new
]
clear face/redos ; to stop redoing old undos
face/last-added: copy face/text
]
]
undo: func [face [object!] /local act sel asy][
asy: system/view/auto-sync?
loop 2 [ ; prettify indent undo
;system/view/auto-sync?: yes ;@@ ?? turn-on auto-sync but store its state before
if empty? face/undos [exit]
act: take/last face/undos
append/only face/redos act
sel: switch first act [
i ic [face/text: head remove/part skip face/text act/2 length? act/3 (0)] ; if something was inserted, now remove it
r rc [face/text: head insert skip face/text act/2 act/3 (length? act/3)]
;FIXME: c [change at text act/2 act/4 act/3]
]
face/old-text: copy face/text
face/last-added: copy face/text
;@@ fake caret movement with selection :( (until Red will let set the caret position)
sel: sel + act/2
if sel = (length? face/text) [sel: sel + 1] ; a little aesthetic improvement
face/selected: to-pair sel
system/view/auto-sync?: asy
if act/1 <> 'ic [break]
]
if not system/view/auto-sync? [show face]
]
redo: func [face [object!] /local act sel asy][
asy: system/view/auto-sync?
loop 2 [ ; prettify indent redo
;system/view/auto-sync?: yes ;@@ ?? turn-on auto-sync but store its state before
if empty? face/redos [exit]
act: take/last face/redos
append/only face/undos act
sel: switch first act [
i ic [face/text: head insert skip face/text act/2 act/3 (length? act/3)]
r rc [face/text: head remove/part skip face/text act/2 length? act/3 (0)]
;FIXME: c [change at text act/2 act/4 act/3]
]
face/old-text: copy face/text
face/last-added: copy face/text
;@@ fake caret movement with selection :( (until Red will let set the caret position)
sel: sel + act/2
if sel = (length? face/text) [sel: sel + 1] ; a aesthetic improvement
face/selected: to-pair sel
system/view/auto-sync?: asy
if act/1 <> 'rc [break]
]
if not system/view/auto-sync? [show face]
]
; placeholders
on-created: func [face [object!] event [event! none!]][]
on-key: func [face [object!] event [event! none!]][]
on-key-up: func [face [object!] event [event! none!]][]
on-change: func [[trace] face [object!] event [event! none!]][]
]
]
init: [
face: self
face/actors/on-created: func [face [object!] event [event! none!]] head insert body-of :face/actors/on-created [
face/last-added: copy face/text
face/old-text: copy face/text
]
face/actors/on-key: func [face [object!] event [event! none!] /local selected] head insert body-of :face/actors/on-key [
unless none? event [
if char? event/key [face/key: event/key]
either event/key = #"^Z" [
face/ctrlz: face/ctrlz + 1
][
face/ctrlz: 0
]
if all [
pair? selected: face/selected ; also store selected range
event/key = #"^D"
][
face/text: head insert skip face/text face/selected/2 face/actors/selection face/text face/selected
face/selected: selected ; restore selected range
face/optimize: false ; avoid joining last insertions toghether
face/actors/on-change face none
face/optimize: true
]
face/selected-range: face/selected ; also store selected range
if all [
pair? selected: face/selected-range ; also store selected range
event/key = tab
][
either event/shift? [
face/selected-range: face/actors/outdent face/old-text selected
face/selected: face/selected-range + 0x1
][
face/selected-range: face/actors/indent face/old-text selected
face/selected: face/selected-range - 0x1
]
; "manually" add to undos
append/only face/undos reduce ['rc face/selected/1 - 1 face/actors/selection face/text selected ]
append/only face/undos reduce ['ic face/selected/1 - 1 face/actors/selection face/old-text face/selected-range ]
face/last-added: copy face/old-text ; keep this updated
face/optimize: false ; avoid joining last insertions together
]
if all [
event/key = 'up
event/ctrl?
event/shift?
][
; TBD ;probedo ["up"]
]
if not system/view/auto-sync? [show face] ;@@ force update even if auto-sync? is off
] ;unless none?
]
face/actors/on-key-up: func [face [object!] event [event! none!]] head insert body-of :face/actors/on-key-up [
unless none? event [
if all [event/key = #"Z" event/ctrl? not event/shift?] [
face/actors/undo face
]
if all [event/key = #"Z" event/ctrl? event/shift?] [
face/actors/redo face
]
face/key: none
] ;unless none?
]
face/actors/on-change: func [[trace] face [object!] event [event! none!]] head insert body-of :face/actors/on-change [
if odd? face/ctrlz [
face/text: face/old-text ; undo the original undo
]
either all [
pair? face/selected-range
face/key = tab
][
face/text: face/old-text ; undo the tab substitution
face/selected: face/selected-range ; restore selected range
face/optimize: false ; avoid joining last insertions toghether
][
face/actors/add-to-undos face face/text
]
if not system/view/auto-sync? [show face] ;@@ force update even if auto-sync? is off
face/optimize: true
face/old-text: copy face/text
]
]
]
do
[
if any [%area-plus.red = find/last/tail system/options/script "/" ; It's really me ?
system/script/args = "test"] [
;print "" ; open console for debug
system/view/VID/styles/text: [template: [type: 'text size: 0x0]]
win: layout compose/deep [
title "Text area with multiple undos" ;@@ I wish I could do : title (system/script/header/title)
space 4x4
below
text "Try an area with multiple undos"
text "Please forgive 1-char selection used to move the caret ;(" bold
text "If, when undoing, something disappears, try undoing again !"
a+: area-plus 500x400 focus {if 'this-is-a-test [
try any [
Selection + <Tab>
Selection + <Shift+Tab>
]
to indent! (or~ outdent! Selection)
]
also <Ctrl+D> to duplicate! selection
}
across
button "Undo" [a+/undo set-focus a+]
button "Redo" [a+/redo set-focus a+]
]
view win
] ; if
] ; do
Raw
area-rt.red
;Red [Needs: 'View]
Red [
title: "Rich-text Text Area"
file: %area-rt.red
author: @luce80
License: 'PD
gist-view: none
date: 22-04-2024
version: 0.9.4
history: [
0.0.0 [20-01-2024 "Started"]
0.8.0 [19-02-2024 "Main aspects completed"]
0.9.0 [24-02-2024 "Fixes, ADD: read-only"]
0.9.2 [07-03-2024 "ADD: clear-text FIX: use integer!s for scrollers calcs, FIX: undo smaller changes, FIX: immediatly show cursor "]
0.9.3 [10-04-2024 "FIX: hide cursor in read-only mode FIX: wheel scroll with only vert scroller"]
0.9.4 [22-04-2024 "ADD: margins and edge"]
]
Note: {Needs Red 0.6.5 built 17-Feb-2024 or later}
Notes: {
Many things are copied WITHOUT permission from %view-edit.r of Rebol2 SDK. Original header with Copyright note is given below.
Other things are copied from Didier Cadieu and myself.
This style was created because default area does not expose any of its methods!
This style was created with a rich-text drawn on another face because rich-text lacks a "scroll" or "origin" parameter!
IMPORTANT: Undoing is done only with removes and insertions, there are no changes. This means that
a change is made by a remove followed by an insertion, and this means that, sometimes, when undoing a change, some text
will first disappear! But you'll just have to undo again!
There are a few "public" functions:
undo: func ["Undo previous editing action"]
redo: func ["Redo last editing action"]
update: func ["Reshow all"[
insert-text: func [
"Insert given string at given position (0 means tail)"
string [string!] position [integer!]
]
remove-text: func [
"Remove length characters (or 0 to indicate to tail) at given position"
position [integer!] length [integer!]
]
clear-text: func ["Remove all text"]
get-text: func ["Return a copy of the text"]
selected?: func ["Return TRUE if some text is highlighted"][
select: func [
"Use a pair! to highlight a part of the text (index x length) or move the caret (index x 0)"
value [pair!]
]
select-all: func ["Highlight all text"]
Please avoid modifing area text directly, use the provided `insert-text` and `remove-text` instead.
You can also do some "fancy" stuff using face/actors/edit-text which is the main function but only "at your own risk".
You can set some parameters by using `options` VID keyword.
The currently available parameters are:
- flags: a `block!` containing one or more of:
- read-only Prevent user input, You can still select and copy text.
TBD: cambiare colore on-unfocus
paced scrolling
options/themes
word skipping!=selection
word selection on mouse move
better undo optimizations ('-+ '+-)
overwrite mode (is it worth it?)
line-scrolling instead of pixel scrolling
}
view-edit-R2-header: [
Title: "REBOL/View: Text Edit Core"
Version: 2.7.6
Rights: "Copyright REBOL Technologies 2008. All rights reserved."
Home: http://www.rebol.com
Date: 14-Mar-2008
; You are free to use, modify, and distribute this file as long as the
; above header, copyright, and this entire comment remains intact.
; This software is provided "as is" without warranties of any kind.
; In no event shall REBOL Technologies or source contributors be liable
; for any damages of any kind, even if advised of the possibility of such
; damage. See license for more information.
; Please help us to improve this software by contributing changes and
; fixes. See http://www.rebol.com/support.html for details.
]
]
probedo: func [code [block!] /local result][print [mold code mold/only result: reduce code] do :result]
if system/build/date < 12-02-2024 [alert "A more recent version of Red is required !" either empty? gui-console-ctx/terminal/lines [quit][halt]] ; to use recent fixes
area-rt.red-ctx: context [
use: func [words [block!] body [block!]][body: has words body body]
trim-auto: func [
"Auto indents lines relative to first line."
series [series!]
/local firstline firstchar indent
] [
firstline: remove/part series find series complement charset " ^/"
firstchar: find firstline complement charset " ^-"
indent: head copy/part firstline firstchar
replace/all series indent ""
head series
]
trim-auto: func [
"Auto indents lines relative to first line.(4 spaces=1 tab) (modifies)"
string [string!]
/local space non-spaces line start end
] [
space: " "
non-spaces: complement charset " ^-"
; skip initial empty lines
parse string [any newline any [some space some newline] start:]
; trim initial empty lines
string: remove/part string start
; add initial "fake" newline to simplify things
string: head insert string "^/"
; convert initial spaces to tabs
line: [newline start: opt [some [start: [1 3 space tab | 4 space] end: (
change/part start "^-" end
)]] opt [some non-spaces]]
parse string [some line]
; outdent lines
while [find/match string "^/^-"] [replace/all string "^/^-" "^/"]
; remove initial "fake" newline
remove string
]
away?: func [ ;@@ workaround for #5472
face event
][
event/offset <> min max 0x0 event/offset face/size - face/scrollers-size
]
find-window: function [
"Finds a face's window face."
face [object!]
][
if p: face/parent [
while [p/type <> 'window][p: p/parent]
]
p
]
set-focus: func [
"Sets the focus on the argument face"
face [object!]
/local p
][
p: find-window face
if p/selected <> face [
if p/selected [do-actor p/selected none 'unfocus]
do-actor p/selected: face none 'focus
]
]
focused?: function [
"TRUE if face is focused."
face [object!]
][
same? face get in find-window face 'selected
]
system/view/VID/styles/area-rt: [
default-actor: on-change
template: [
type: 'rich-text ; could be also 'base
size: 150x150
color: white ;255.255.200 ;55
;text: copy ""
flags: [scrollable focusable];
tabs: none line-spacing: 'default handles: none ; mandatory fields for a rich-text
menu: [
"Cut Ctrl+X" menu-cut
"Copy Ctrl+C" menu-copy
"Paste Ctrl+V" menu-paste
---
"Undo Ctrl+Z" menu-undo
"Redo Ctrl+Shift+Z" menu-redo
---
"Select All Ctrl+A" menu-select-all
"Duplicate Ctrl+D" menu-duplicate
"lowercase Ctrl+U" menu-lowercase
"UPPERCASE Ctrl+Shift+U" menu-uppercase
"Indent Tab" menu-indent
"Outdent Shift+Tab" menu-outdent
]
selected: 0x0
created: false
old-handler: none ; old global tab handler
down?: false ;@@ workaround for #5475
scrollers-size: system/view/metrics/misc/scroller ; scrollers thickness
us: self
margins: 4x4 ;@@ should this be inside `para`?
para: make para! [
scroll: (0, 0)
wrap?: false
on-change*: func [word old new][
; if not function? :new [prin "PARAC " ?? word ?? new]
switch word [
wrap? [
if object? us/draw/(rt/text)/para [
set-quiet in us/draw/(rt/text)/para 'wrap? new
; set-quiet word old
]
]
scroll [
us/draw/(rt/scroll): new
]
]
]
]
draw: compose/deep [
line-width 2 pen (black + 0.0.0.230) box 0x0 (size) ; edge
clip (margins) (size) ; clip
translate (margins) ; margins
translate (0, 0) ; scroll offset
text (0, 0) (rtd-layout [white bg 0.120.215 " " /bg]) ; main rich.text with colors of highlighted text
; caret
pen black ; caret color
translate (0, 0) ; caret offset
scale 1 1 ; caret width and height
line-width 1
line (0.5, 0) (0.5, 1) ; caret vertical line
]
rt: object [ ;@@ Red "strange" get-word! draw indexing makes me prefer this "indirect" numbers :(
edge: 7
clip-offset: edge + 2
clip: edge + 3
scroll: clip + 4
text: scroll + 3
caret: text
caret-color: caret + 2
caret-offset: caret + 4 ; relative to rich-text offset
caret-width: caret + 6
caret-height: caret + 7
face: none
data: none
font-size: 2 ; index inside rt/face/data
font-color: 3 ; index inside rt/face/data
selection: 4 ; index inside rt/face/data
hi-font-color: 5 ; index inside rt/face/data
hi-color: 7 ; index inside rt/face/data
]
; FIXME: add a "dark" theme? Change depending on OS?
colors: object [
background: white
text: black
highlight: sky ; highlighted background
hi-text: white ; highlighted text
highlight-unfocused: gray ; highlighted background when unfocused
hi-text-unfocused: black ; highlighted text when unfocused
cursor: black
]
values: object [ ; object used to extend VID params and set main control params
flags: copy [] ; 'read-only , TBD 'blinking
]
; public functions
undo: func ["Undo previous editing action"][actors/undo self]
redo: func ["Redo last editing action"][actors/redo self]
update: func [ ;@@ REDEFINED update
"Reshow all"
][
actors/update-scrollers self size size-text self/rt/face
actors/draw-cursor self none ; used also to calc caret/offset
actors/scroll-to-caret self
actors/draw-hilight self
]
;edit
insert-text: func [
"Insert given string at given position (0 means tail)"
string [string! char!] position [integer!]
][
if position = 0 [position: 1 + length? text]
position: min max 1 position 1 + length? text
actors/caret/pos: at text position
;actors/caret/pos:
actors/insert-chars/no-opt self string
update
]
remove-text: func [
"Remove length characters (or 0 to indicate to tail) at given position"
position [integer!] length [integer!]
][
position: min max 1 position length? text
if length = 0 [length: length? text]
length: min max 1 length (1 + length? text) - position
actors/caret/pos: at text position + length
actors/caret/pos: actors/remove-chars self compose [ctrl? (false)] [] reduce [at text position]
update
]
clear-text: func [
"Remove all text"
][
remove-text 1 0
]
get-text: func [
"Return a copy of the text"
][
copy head text
]
selected?: func [
"Return TRUE if some text is highlighted"
][
to logic! all [pair? selected selected/2 > 0]
]
select: func [ ;@@ REDEFINED select
"Highlight a part of the text using a pair! (index x length)"
value [pair!]
][
actors/select self value
]
select-all: func [
"Highlight all text"
][
actors/select self as-pair 1 length? text
]
;
actors: [
us: none
highlight-start: none
highlight-end: none
none none ;@@ workaround for #5488
scroller: make map! 2
caret: make object! [
index: 1 ; integer!
pos: none ; string!
offset: (0, 0) ; relative to rich-text offset
width: 1 ; currently unused
height: 15 ; line height
color: black
blinking: 0:0:0.6
visible: 0
; on-change*: func [word old new][
; if word = 'pos [draw-cursor us none]
; ]
]
flag?: func [face flag [word! block!]] [
to logic! find face/values/flags flag
]
; indent outdent
indent: func [string [string!] selected [pair!] /local start beg end] [
start: at string selected/1
start: any [find/tail/reverse start newline head string]
beg: index? start
end: selected/1 + selected/2
until [
insert start tab
end: end + 1
start: find/tail start newline
any [
none? start
(index? start) >= end
]
]
as-pair beg end - beg
]
outdent: func [string [string!] selected [pair!] /local start beg end] [
start: at string selected/1
start: any [find/tail/reverse start newline head string]
beg: index? start
end: selected/1 + selected/2
until [
if start/1 = tab [
remove start
end: end - 1
]
start: find/tail start newline
any [
none? start
(index? start) >= end
]
]
as-pair beg end - beg
]
;
; undo redo
history: copy []
none ;@@ workaround for #5488
; act is a block in the form: [command where what how-many] (eg. [-- 10 "hi" 2] [++ 10 "HI" 2])
;command is '-- or '++, where is an index, what is a text, how-many is the length
add_to_history: func [act [block! none!] /no-opt] [
if none? act [exit]
;FIXME: do-actor us none 'change
if 10000 < length? history [remove head history] ; if limit exceeded remove 1st
clear history ; erase the future
;try to optimize by grouping actions
either all [
not no-opt
(length? head history) >= 1
act/1 = '++
history/-1/1 = act/1 ; same action
(history/-1/2 + history/-1/4) = act/2 ; consecutive additions
not find word-limits/1 act/3 ; not a separator
history/-1/4 <= 4 ; only small changes
act/4 <= 2 ; only small changes
]
[
append history/-1/3 act/3
history/-1/4: history/-1/4 + act/4
][
history: insert/only tail history act
]
]
undo: func [face [object!] /local act index text len][
if head? history [exit]
loop 2 [ ; used to do 2 consecutive undos
history: back history
set [act index text len] first history
caret/pos: switch act [
++ [remove/part at face/text index len] ; if something was inserted, now remove it
-- [insert at face/text index text]
]
; optimize simple changes by undoing again
if not all [
not head? history
act = '++ history/-1/1 = '-- ; a change
history/-1/2 = index ;
history/-1/4 = len ;
][break]
] ; loop
face/draw/(face/rt/caret-color): caret/color ; momentarily show cursor (also for unfocused area)
unlight-text
face/update
if function? :on-change [any [attempt [on-change face reduce ['type 'key 'key at face/text index]] on-change face none] ]
]
redo: func [face [object!] /local act index text len asy][
if tail? history [exit]
loop 2 [ ; used to do 2 consecutive redos
set [act index text len] first history
history: next history
caret/pos: switch act [
-- [remove/part at face/text index len]
++ [insert at face/text index text]
]
; optimize simple changes by redoing again
if not all [
not tail? history
act = '-- history/1/1 = '++ ; a change
history/1/2 = index ;
history/1/4 = len ;
][break]
] ; loop
face/draw/(face/rt/caret-color): caret/color ; momentarily show cursor (also for unfocused area)
unlight-text
face/update
if function? :on-change [any [attempt [on-change face reduce ['type 'key 'key at face/text index]] on-change face none] ]
]
;
;-- Text highlight functions (but, do not reshow the face):
hilight-text: func [face begin end][
highlight-start: begin
highlight-end: end
]
hilight-all: func [face][
either empty? face/text [unlight-text][
highlight-start: head face/text
highlight-end: caret/pos: tail face/text
]
]
unlight-text: func [] [
highlight-start: highlight-end: none
]
hilight?: func [] [
all [
;object? focal-face
string? highlight-start
string? highlight-end
not zero? offset? highlight-end highlight-start
]
]
hilight-range?: has [start end] [
start: highlight-start
end: highlight-end
if negative? offset? start end [start: end end: highlight-start]
reduce [start end]
]
select: func [ ;@@ REDEFINED select
face [object!]
value [pair!]
][
if any [
not string? face/text
empty? face/text
][
return false
]
; constrain to valid ranges
value/1: min max 1 value/1 1 + (length? face/text)
value/2: min max 0 value/2 1 + (length? face/text) - value/1
unlight-text
hilight-text face (at face/text value/1) (caret/pos: at face/text value/1 + value/2)
face/update
value
]
draw-hilight: function [face [object!]][
start: index? any [highlight-start ""]
end: index? any [highlight-end ""]
if start > end [tmp: start start: end end: tmp]
if start = 0 [start: caret/index]
face/rt/data/(face/rt/selection): as-pair start end - start
if face/selected <> face/rt/data/(face/rt/selection) [
set-quiet in face 'selected face/rt/data/(face/rt/selection) ;@@ use set-quiet to avoid too many reactions
]
;if not system/view/auto-sync? [show face]
]
;
;-- Copy and delete functions:
copy-selected-text: func [face /local start end][
if all [
hilight?
;not flag-face? face hide
][
set [start end] hilight-range?
attempt [write-clipboard copy/part start end]
true
] ; else return none
]
copy-text: func [face] [
if not copy-selected-text face [ ; copy all if none selected (!!! should be line)
hilight-all face
copy-selected-text face
] ; else return none
]
delete-selected-text: func [/local face start end res][
if hilight? [
set [start end] hilight-range?
;if flag-face? face hide [remove/part at face/text index? start offset? start end]
add_to_history reduce ['-- index? start copy/part start end offset? start end]
remove/part start end
caret/pos: start
unlight-text
true
] ; else return none
]
;
;-- Cursor movement:
word-limits: use [cs][
cs: charset " ^-^/^m/[](){}^""
reduce [cs complement cs]
]
; next-word: func [str /local s ns] [
; set [s ns] word-limits
; any [all [s: find str s find s ns] tail str]
; ]
; back-word: func [str /local s ns] [
; set [s ns] word-limits
; any [all [ns: find/reverse back str ns ns: find/reverse ns s next ns] head str]
; ]
words-limits: make bitset! {[]^{^}()-^"^/} ;@@ this is different from word-limits
space: make bitset! " ^-"
;non-space: complement union words-limits space
non-spaces: union words-limits space
non-space: complement non-spaces
none ;@@ workaround for #5488
skip-non-space: func [str inc] [while [find non-space any [str/:inc #" "]][str: skip str inc] str]
skip-space: func [str inc] [while [find space any [str/:inc #"a"]][str: skip str inc] str]
skip-words-limits: func [str inc] [while [find words-limits any [str/:inc #"a"]][str: skip str inc] str]
next-word: func [str /local pos] [
pos: str
if pos = str: skip-space skip-non-space str 1 1 [str: skip-space skip-words-limits str 1 0]
str
]
back-word: func [str /local pos] [
pos: str
if pos = str: skip-non-space skip-space str -1 -1 [str: skip-words-limits str -1]
str
]
end-of-line: func [str /local nstr] [ ;returns at newline
any [find str newline tail str]
]
beg-of-line: func [str /local nstr] [ ;returns just after newline
any [find/reverse/tail str newline head str]
]
move: func [event ctrl plain] [
; Deal with cursor movement, including special shift and control cases.
either event/shift? [any [highlight-start highlight-start: caret/pos]][unlight-text]
caret/pos: either event/ctrl? ctrl plain
if event/shift? [either caret/pos = highlight-start [unlight-text][highlight-end: caret/pos]]
]
move-y: func [face delta /local pos][
; Move up or down a number of lines.
; use caret line offset and sub-rich-text offset
pos: face/draw/(face/rt/caret-offset) + 0x1 + delta ;
caret/index: offset-to-caret face/rt/face pos
caret/pos: at face/text caret/index
]
draw-cursor: func [face event /local pos][
;?? caret/pos
caret/index: index? any [caret/pos face/text]
;?? caret/index
caret/offset: caret-to-offset face/rt/face caret/index
;@@ workaround for wrapped text (para/wrap? = true)
if all [face/para face/para/wrap? event (caret/offset/y > (event/offset/y - face/para/scroll/y - face/margins/y))] [
pos: offset-to-caret face/rt/face event/offset - face/para/scroll - face/margins
caret/offset: as-pair (pick caret-to-offset/lower face/rt/face pos - 1 'x) (pick caret-to-offset face/rt/face pos - 1 'y)
]
;?? caret/offset
;?? face/para/scroll
;face/draw/(face/rt/scroll): face/para/scroll ; sync para/scroll , but using reactions
face/draw/(face/rt/caret-offset): caret/offset
]
;
;-- Character handling:
keys-to-insert: complement charset [#"^A" - #"^(1F)" #"^(DEL)"]
keymap: [ ; a small table, so does not benefit from hashing
#"^(back)" back-char
#"^~" back-char ;@@ Red specific
#"^(tab)" tab-char
#"^(del)" delete
#"^M" enter
#"^A" all-text
#"^C" copy-text
#"^X" cut-text
#"^V" paste-text
#"^T" clear-tail
#"^D" duplicate-text
#"^U" case-text
#"^Z" undo-redo
]
none none ;@@ workaround for #5488
remove-chars: func [face event ctrl plain /local tmp start end][
if none? delete-selected-text [
start: either event/ctrl? ctrl plain
end: caret/pos
if negative? offset? start end [tmp: start start: end end: tmp]
add_to_history reduce ['-- index? start copy/part start end offset? start end]
if function? :on-change [any [attempt [on-change face reduce ['type 'key 'key start]] on-change face none] ]
caret/pos: remove/part start end
]
update-scrollers face face/size size-text face/rt/face
caret/pos
]
insert-chars: func [face chars /no-opt /local len][
delete-selected-text
; For password spoofed text (***), the above may put caret on wrong face.
; Check, and restore proper caret, otherwise we lose a character.
if not same? head face/text head caret/pos [caret/pos: at face/text index? caret/pos]
; The caret may be off the end, so just append if it is.
if error? try [caret/pos: insert caret/pos chars][append caret/pos chars]
len: either char? chars [1][length? chars]
add_to_history/:no-opt reduce ['++ (index? caret/pos) - len to-string chars len]
update-scrollers face face/size size-text face/rt/face
if function? :on-change [any [attempt [on-change face reduce ['type 'key 'key chars]] on-change face none] ]
caret/pos
]
edit-text: func [
face event
/local key liney tmp tmp2 page-up page-down face-size pos
][
key: event/key
;?? key
;probedo [event/shift? event/ctrl? mold key ]
;-- Compute edge and face sizes (less the edge):
face-size: face/size - face/scrollers-size
;-- Fetch the vertical line:
liney: face/actors/caret/height
;-- Most keys insert into the text, others convert to words:
if char? key [
either find keys-to-insert key [
insert-chars face key
][
key: system/words/select keymap key
]
]
;-- Key action handling:
if word? key [
page-up: [move-y face face-size - liney - liney * 0x-1]
page-down: [move-y face face-size - liney * 0x1]
; Most frequent keys are first:
do system/words/select [
back-char [remove-chars face event [back-word caret/pos] [back caret/pos]]
delete [remove-chars face event [next-word caret/pos] [next caret/pos]]
left [move event [back-word caret/pos][back caret/pos]]
right [move event [next-word caret/pos][next caret/pos]]
up [move event page-up [move-y face liney * 0x-1]]
down [move event page-down [move-y face liney * 0x1]]
page-up [move event [head caret/pos] page-up]
page-down [move event [tail caret/pos] page-down]
home [move event [head caret/pos][beg-of-line caret/pos]]
end [move event [tail caret/pos][end-of-line caret/pos]]
enter [insert-chars face newline]
copy-text [copy-text face unlight-text]
cut-text [copy-text face delete-selected-text]
paste-text [
tmp: read-clipboard
if string? tmp [insert-chars/no-opt face tmp]
]
clear-tail [remove-chars face event [end-of-line caret/pos] [end-of-line caret/pos]]
all-text [hilight-all face]
tab-char [
case [
all [event/ctrl? event/shift?] [
set-focus tmp: get-focusable/back find face/parent/pane face
]
event/ctrl? [
set-focus tmp: get-focusable next find face/parent/pane face
]
'else [
either hilight? [
; tab indentation
add_to_history reduce ['-- (index? highlight-start) (copy/part highlight-start highlight-end) (offset? highlight-start highlight-end)]
face/selected: either event/shift? [
outdent face/text face/selected
][
indent face/text face/selected
]
add_to_history reduce ['++ (face/selected/1) (copy/part at face/text face/selected/1 face/selected/2) (face/selected/2)]
][
insert-chars face tab
]
]
]
]
duplicate-text [
either hilight? [
set [tmp tmp2] hilight-range?
unlight-text ; avoid deleting selection
insert-chars/no-opt face copy/part tmp tmp2
; re-highlight
caret/pos: tmp2
hilight-text face tmp tmp2
][
pos: caret/pos ; store caret position
tmp: beg-of-line caret/pos
tmp2: caret/pos: next end-of-line caret/pos
if (first back tmp2) <> newline [insert-chars face newline] ; if we are at the end add also a newline
insert-chars face copy/part tmp tmp2
; reposition caret
caret/pos: pos
]
]
case-text [
if hilight? [
tmp: copy/part highlight-start highlight-end
insert-chars face either event/shift? [uppercase tmp][lowercase tmp]
]
]
undo-redo [either event/shift? [redo face][undo face]]
] key
]
draw-cursor face none ;@@ used to calc caret/offset for scroll-to-caret
;-- Scroll the face to keep caret visible?
scroll-to-caret face
draw-hilight face
]
;
; scroll, scrollers and resize
scroll-to: function [face [object!] pos [integer! string!]][
;TBD
]
scroll-to-caret: func [face /local face-size liney tmp tmp2 scroll][
face-size: face/rt/face/size
;-- Fetch the vertical line:
liney: face/actors/caret/height
; store old value
scroll: face/para/scroll
tmp2: caret/offset - absolute scroll
tmp: face-size - tmp2 - (caret/width * 1x0)
;-- Scroll right if off left side, or left if off right side:
if tmp/x < 0 [face/para/scroll/x: to-integer scroll/x + tmp/x]
if tmp2/x < 0 [face/para/scroll/x: to-integer scroll/x - tmp2/x]
; update scrollers
if scroll/x <> face/para/scroll/x [ON-SCROLL face compose [key track picked (to-integer absolute face/para/scroll/x) orientation horizontal] ]
;-- Scroll up if off bottom, or down if off top:
if (tmp/y - liney) < 0 [face/para/scroll/y: to-integer scroll/y + tmp/y - liney]
if tmp2/y < 0 [face/para/scroll/y: to-integer scroll/y - tmp2/y]
; update scrollers
if scroll/y <> face/para/scroll/y [ON-SCROLL face compose [key track picked (to-integer absolute face/para/scroll/y) orientation vertical] ]
]
scroll: function [face [object!] pos [integer! ] axis [word!]][
face/para/scroll/(axis): to integer! 1 + negate pos ;@@ "1 +" because this must be 0-based
;face/draw/(face/rt/scroll): face/para/scroll ; using reactions
]
; must adjust both scrollers at the same time
update-scrollers: function [face [object!] size [pair! point2D! none!] inner-size [pair! point2D!]][ ; some parts of this function are inspired by one of Anton Rolls
asy: system/view/auto-sync?
system/view/auto-sync?: no
scy: scroller/y
scx: scroller/x
; scrollers widths, add 2 to make it look better and avoid cursor being hidden
y-size: 2 + to integer! system/view/metrics/misc/scroller/y * 96 / system/view/metrics/dpi ;@@ WHAT !!??, really ??
x-size: 2 + to integer! system/view/metrics/misc/scroller/x * 96 / system/view/metrics/dpi
; account also for margins
; do it here because this function is called all over the place
size: size - (face/margins * 2)
visible-y: size/y
total-y: to integer! inner-size/y
visible-x: size/x
total-x: to integer! inner-size/x
; determine if scrollers are necessary to be shown
; subtract here space taken by scrollers, if necessary
if scy-visible?: total-y > visible-y [
; adding a vertical scroller changes horizontal visible size
visible-x: size/x - y-size
]
if scx-visible?: total-x > visible-x [
; adding a horizontal scroller changes vertical visible size
visible-y: size/y - x-size
]
; adding the horizontal scroller might make the vertical scroller necessary
if all [not scy-visible? scy-visible?: total-y > visible-y ] [
; adding a vertical scroller changes horizontal visible size
visible-x: size/x - y-size
]
;scy/max-size: 0 ;@@ workaround to avoid scroller to become disabled !
scy/page-size: 0
scy/page-size: to integer! visible-y
;scy/visible?: none ;@@ workaround
scy/visible?: scy-visible?
scy/max-size: to integer! total-y ; @@ ...must place this here
scy/min-size: to integer! visible-y / 10 ; FIXME hardcoded value
; constrain to allowed range
scy/position: to integer! min max 1 scy/position (total-y - visible-y)
;scx/max-size: 0 ;@@ workaround to avoid scroller to become disbled ! or ...
scx/page-size: 0
scx/page-size: to integer! visible-x
;scx/visible?: none ;@@ workaround
scx/visible?: scx-visible?
scx/max-size: to integer! total-x + 1 ;@@... this MUST be placed after "visible?". @@ + 1 only for 144 dpi but beware that /visible? is setted also by Red !
scx/min-size: to integer! visible-x / 10
; constrain to allowed range
scx/position: to integer! min max 1 scx/position (total-x - visible-x)
; scroll to keep maximum possible visibility
face/actors/scroll face to integer! max 1 min scy/position absolute (total-y - visible-y) 'y
face/actors/scroll face to integer! max 1 min scx/position absolute (total-x - visible-x) 'x
face/scrollers-size: as-pair any [all [scy-visible? y-size] 0] any [all [scx-visible? x-size] 0] ;@@ note REVERSED axes !
face/rt/face/size: size - face/scrollers-size ;@@ margins already subtracted
;show face
system/view/auto-sync?: asy
]
resize: function [face [object!] size [pair! point2D! none!]][
;print ["resize" size]
update-scrollers face size (size-text face/rt/face) + caret/width
; if wrapped text, move cursor to nearest text
if face/para/wrap? [
caret/index: offset-to-caret face/rt/face (caret/offset - face/para/scroll - face/margins)
caret/pos: at face/text caret/index
draw-cursor face none ; used also to calc caret/offset
]
face/draw/(face/rt/edge): size
face/draw/(face/rt/clip): size - face/margins - face/scrollers-size + 2x0
size ; IMPORTANT for reactions !
]
;
created: false
none none ;@@ workaround for #5488
ON-CREATE: func [face][
;print "ON-CREATE"
append face/options [cursor: I-beam]
;face/draw/(face/rt/text)/para/wrap?: face/para/wrap?
face/rt/face/para/wrap?: face/para/wrap?
face/draw/(face/rt/caret-height): face/actors/caret/height: rich-text/line-height? face/rt/face 1
face/actors/caret/pos: head face/text
scroller/x: get-scroller face 'horizontal
scroller/y: get-scroller face 'vertical
update-scrollers face face/size size-text face/rt/face
;?? face
face/actors/created: true
if flag? face 'read-only [face/draw/(face/rt/caret-color): caret/color: 'off]
face/rate: if not flag? face 'read-only [caret/blinking]
]
; ON-FOCUS: func [face event] [print "focus" system/view/capturing?: yes]
; ON-UNFOCUS: func [face event] [print "UNfocus" system/view/capturing?: no]
; ON-DETECT: func [face event] [?? event/type if event/type = 'key [?? event/key 'stop]] ; make this area read-only
ON-KEY-DOWN: func [face event][
;prin "Kdown " ?? event/key
if flag? face 'read-only [exit]
;@@ many workarounds
if all[ event/key = #"^(tab)" event/ctrl?] [edit-text face event] ; FIXME: change handler
if all[ event/key = #"Z" event/shift? event/ctrl?] [ON-KEY face compose [key #"^Z" shift? (true) ctrl? (true)]]
if all[ event/key = #"U" event/shift? event/ctrl?] [ON-KEY face compose [key #"^U" shift? (true) ctrl? (true)]]
]
ON-KEY: func [face event][
;?? event/key
if flag? face 'read-only [
if event/key = #"^C" [edit-text face [key copy-text]]
exit
]
;face/rate: none
face/draw/(face/rt/caret-color): caret/color
edit-text face event
;face/rate: caret/blinking
]
ON-DOWN: func [face event /local tmp][
;print "DOWN "
set-flag face 'all-over
;set-flag/clear face 'focusable
set-focus face
;face/rate: caret/blinking
face/down?: true ;@@ workaround for #5475
; show immediatly the cursor
face/draw/(face/rt/caret-color): caret/color
either event/shift? [
ON-OVER face event
][
unlight-text ; FIXME: if not focused
]
;?? event/offset
caret/index: offset-to-caret face/rt/face (event/offset - face/para/scroll - face/margins)
caret/pos: at face/text caret/index
draw-cursor face event
draw-hilight face
scroll-to-caret face
; face/update
;none
]
ON-OVER: func [face event /local tmp][
;prin "over " ?? event/flags
if not event/down? [return 'done]
if not face/down? [return 'done] ;@@ workaround for #5475
if away? face event [;@@ workaround for #5472
; handle scrolling of area while selecting text.
scroll-to-caret face
]
; handle selection with mouse
tmp: offset-to-caret face/rt/face (event/offset - face/para/scroll - face/margins)
if not-equal? caret/index tmp [
if not highlight-start [highlight-start: caret/pos]
highlight-end: caret/pos: at face/text caret/index: tmp
draw-cursor face event
draw-hilight face
;show face
]
]
ON-UP: func [face event][
set-flag/clear face 'all-over
face/down?: false ;@@ workaround for #5475
; stop scrolling if needed
;face/rate: none; show face]
]
ON-DBL-CLICK: func [face event][
; select word
;edit-text face compose [key right shift? (false) ctrl? (false)]
edit-text face compose [key left shift? (false) ctrl? (true)]
edit-text face compose [key right shift? (true) ctrl? (true)]
]
ON-SCROLL: func [face [object!] event [event! none! block!] /local axis scr pos][ ; function "layout" inspired by @cosacam1 version
;print " scroll"
axis: pick [y x] (any [event/orientation 'vertical]) = 'vertical
; invert orientation if Ctrl is pressed and ...(...IDK!) , this is wrong FIXME
; if all [axis = 'y any [not scroller/y/visible? event/ctrl?]] [axis: 'x] ; FIXME: better use shift ?
scr: scroller/(axis)
pos: scr/position
scr/position: min max 1 switch event/key [
up left [pos - scr/min-size]
down right [pos + scr/min-size]
page-up page-left [pos - scr/page-size]
page-down page-right [pos + scr/page-size]
track [event/picked]
wheel [pos - (scr/min-size * to integer! event/picked)] ; forwarded event by on-wheel
end [pos]
] (scr/max-size - scr/page-size + 1)
scroll face scr/position axis ; use an overwritable function
;if not system/view/auto-sync? [show face]
]
ON-WHEEL: function [face [object!] event [event! none!]][;May-be switch shift and ctrl ?
if scroller/y/visible? [
ON-SCROLL face event ; forward
]
]
ON-MENU: func [face event][
edit-text face compose system/words/select [
menu-copy [key #"^C" shift? (false) ctrl? (true)]
menu-cut [key #"^X" shift? (false) ctrl? (true)]
menu-paste [key #"^V" shift? (false) ctrl? (true)]
menu-undo [key #"^Z" shift? (false) ctrl? (true)]
menu-redo [key #"^Z" shift? (true) ctrl? (true)]
menu-select-all [key #"^A" shift? (false) ctrl? (true)]
menu-duplicate [key #"^D" shift? (false) ctrl? (true)]
menu-lowercase [key #"^U" shift? (false) ctrl? (true)]
menu-uppercase [key #"^U" shift? (true) ctrl? (true)]
menu-indent [key tab-char shift? (false) ctrl? (false)]
menu-outdent [key tab-char shift? (true) ctrl? (false)]
] event/picked
]
ON-TIME: func [face event][
either focused? face [
;face/rate: caret/blinking
face/draw/(face/rt/caret-color): either 0 = caret/visible: 1 - caret/visible [glass][caret/color]
][
face/draw/(face/rt/caret-color): glass
;face/rate: none
]
;if not system/view/auto-sync? [show face]
]
ON-CHANGE: func [face event][
;placeholder
]
]
old-on-change*: :on-change*
on-change*: func [word old new][
old-on-change* word :old :new
switch to word! word [
text [
us/draw/(us/rt/text)/text: new
;try [actors/on-change us none]
if function? :actors/on-change [actors/on-change us none]
]
size [
;?? new
if actors/created [ ;@@ LATER flag
;set-quiet word (probe actors/resize us new);- old
actors/resize us new
]
]
tabs [set-quiet in us/draw/(rt/text) 'tabs new]
; line-spacing [
; set-quiet in us/draw/(rt/text) 'line-spacing new
; probedo [
; us/draw/(rt/caret-height): actors/caret/height: rich-text/line-height? us/draw/(rt/text) 1
; ]
; ] ; FIXME: uncomment when fixed
selected [select new]
]
]
]
init: [
;print "INIT"
; add this font object "LATER"
font: make any [font font!] [
; size: ? 9 ;
; name ? W11 area seem to not use Segoe UI.
; color: glass ; make "main" base text invisible
real-color: black
on-change*: func [word old new][
; if not function? :new [prin "FC " ?? word ?? new ?? us/text]
if us/text = none [try [us/text: clear us/draw/(us/rt/text)/text]] ;@@ workaround to sync reactions and strings
switch word [
size [
if created [ ;@@ LATER flag
us/draw/(rt/text)/data/(rt/font-size): new
]
;try [set-quiet us/draw/(rt/caret-height): rich-text/line-height? us 1] ; FIXME: wrong assignment
if object? us/actors/caret [set-quiet in us/actors/caret 'height us/draw/(rt/caret-height)]
]
color [
;set-quiet us/draw/(rt/color) new
;set-quiet us/draw/(rt/text)/font/color new
;set-quiet in us/draw/(rt/text) data/(rt/font-color) new
;if created [ ;@@ LATER flag
;us/draw/(rt/text)/data/(rt/font-color): new
set-quiet 'real-color new
set-quiet word glass ; keep "main" text invisible
;]
]
name [
if object? us/draw/(rt/text)/font [set-quiet in us/draw/(rt/text)/font 'name new]
]
]
]
]
font/size: any [font/size 9] ;@@ must give a default value, but give it only if not already given
font/real-color: any [font/color black] ; copy and store original color or give a default
font/color: any [font/color black]
created: flags ; store flags
values: make values any [options []]
values/flags: to-block values/flags
set self values
flags: created ; restore flags
;options: union trim to block! options [style: area-rt]
para/scroll: (0, 0) ;@@ ?? must re-set because in previouse Red versions this is set to none somehow
rt/face: draw/(rt/text)
rt/data: rt/face/data
insert rt/data [1x-1 10 255.0.255]
rt/data/(rt/selection): 1x0
draw/(rt/caret-height): actors/caret/height: rich-text/line-height? rt/face 1
draw/(rt/caret-width): actors/caret/width: 1 ; FIXME: hardcoded
draw/(rt/clip): size - margins + actors/caret/width
draw/(rt/edge): size
; add a default para!
rt/face/para: make para! [wrap?: false]
; add a default font!
rt/face/font: make any [font font!] []
; sync font size
rt/data/(rt/font-size): rt/face/font/size
; possibly re-hide main face's color
if font/color <> glass [font/color: glass]
rt/data/(rt/font-color): font/real-color
;@hiiamboris workaround (kludge ;) ) to make tab key work inside face
; insert-event-func 'tab func [face event] also compose/deep [
; if face/type <> 'rich-text [(:system/view/handlers/tab) face event]
; ] remove-event-func 'tab
old-handler: :system/view/handlers/tab
put system/view/handlers 'tab func [face event] [
if attempt [face/options/style <> 'area-rt] [old-handler face event] ;@@ beware this lit-word! does not match for a custom style!
]
]
]
] ; ctx
do
[
if any [%area-rt.red = find/last/tail system/options/script "/" ; It's really me ?
;if any [system/script/title = none ; It's really me ?
system/script/args = "test"] [
;prin "" ; open console for debug
;system/view/auto-sync?: no
system/view/VID/styles/text: [template: [type: 'text size: 0x0]]
win: layout compose/deep [
title "Text area with multiple undos" ;@@ I wish I could do : title (system/script/header/title)
space 4x4
button "Add text" [a+/insert-text "ABCDEFGH" 0]
button "Undo" [a+/undo]
button "Redo" [a+/redo]
return
a+: area-rt 400x200 focus ;font-name system/view/fonts/fixed ;yellow red font-size 20 with [tabs: 40 line-spacing: 30]
{if 'this-is-a-test [
try any [
Selection + <Tab>
Selection + <Shift+Tab>
]
to indent! (or~ outdent! Selection)
]
also try [context-menu for many other [shortcuts!]] + all [classic ones]
}
]
react/later compose [
a+/size: win/size - (win/size - a+/size)
if not system/view/auto-sync? [show win]
]
view/flags win 'resize
] ; if
] ; do
Raw
multi-text-list.red
Red [
title: "Multi column text list"
author: @luce80
Rights: "Copyright (C) 2024 Marco Antoniazzi. All rights reserved."
License: BSL-1
file: %multi-text-list.red
gist-view: https://gist.githubusercontent.com/luce80//433286c66d98997aff6e69fbd6323a35#file-multi-text-list-red
date: 02-01-2024
version: 0.0.0
history: [
0.0.0 [22-01-2023 "Started"]
0.0.1 [28-01-2023 "Using textmin"]
0.0.2 [29-01-2023 "scrolling"]
0.0.3 [04-02-2023 "column size and move"]
0.0.4 [02-01-2024 "adapted to new point2D! datatype and `init` binding"]
]
Notes: {
This is a VID style to make it easier to enter numbers.
To initialize the main value use a string or `data`.
You can set some parameters by using `options` VID keyword.
The currently available parameters are:
-
Since this is a `panel` you can not use a `block!` to have a default action, use `on-enter` and/or `on-click` instead.
Since this is a `panel` you can not use a `number!` to specify the size, you must use a `pair!` instead.
Since this is a `panel` you can not give focus to it, you must use e.g. `set-focus my-spinner/field` instead.
See at bottom of script for a usage example.
}
]
{
Se ordino la vista dei dati , devo ordinare anche i dati?
Se selezione qualche riga , cosa restituisco? Attualmente non prevedo di rendere possibile la selezione della singola cella.
Gli "headers", cioè i titoli delle colonne , fanno parte dei dati? Se sì come li gestisco ?
}
probedo: func [code [block!] /local result][print [mold code mold/only result: reduce code] do :result]
system/view/VID/styles/textmin: [ ; FIXME: multi-text-list-cell
default-actor: on-click
template: [
type: 'text
size: 0x0
color: white
para: make para! [wrap?: false]
extra: object [row: 0]
actors: [
on-over: func [face event] [
;face/color: pick [255.255.255 255.0.0 ] event/away? if not system/view/auto-sync? [show face]]
face/parent/parent/set 'highlighted event/away? face/extra/row
]
]
]
]
system/view/VID/styles/multi-text-list: [
default-actor: on-click
template: [
type: 'panel
size: 100x100
data: [[""]]
flags: [scrollable]
children-span: 0x0 ; -- ALL this fields are reacting targets !?
columns: 1
rows: 1
row-height: 0
visible-columns: 1
visible-rows: 1
max-visible-rows: 1
widths: copy [0]
offsets: copy []
cols: copy []
old-cols: copy []
dest-col-x: 0
headers: none
headers-height: 0
space: 4x0 ; space between columns and rows
data-copy: none
draw-arrow: [
;pen 0.0.0 fill-pen off ;line-wodth 10
;trans: [translate 0x0] scal: scale 1 1 [line -4x2 0x-2 4x2]
circle 10x10 10
]
;flags: copy [] ; reserved by Red
old-text: none
this: none ; self
field: none ; shortcut
old-size: 0x0 ; used to resize incrementally
values: object [ ; object used to extend VID params and set main control params
flags: copy [] ;
colors: object [
back-even: white
back-odd: white
back-headers: silver
text: black
select: cyan
; highlight: select + back / 2 ; or select + 0.0.0.128
; high-select: select + (255 - back) / 2
]
]
get: func [attribute [word!] spec][actors/get self attribute spec]
set: func [attribute [word!] spec value][actors/set self attribute spec value]
actors: [
scroller: make map! 2
; scroller fields
; position: 1 ;@@ a better name could be "scroll" or "amount" or "value" or "data"
; page-size: none ;@@ a better name could be "page" or "visible-part"
; min-size: 1 ; ?? . Used for step scrolling
; max-size: 1 ;@@ a better name could be "total"
; visible?: true
; vertical?: true
; parent: none
; page: 1 ; ??
span?: func [
"Returns a block of [min-pos max-size] bounds for all faces"
root [object!]
/part count [integer!] "Limit the number of faces"
/local origin margin face
][
origin: 100000x100000
margin: 0x0
foreach face root/pane [
if all [count negative? count: count - 1] [break]
origin: min origin face/offset
margin: max margin face/offset + face/size
]
reduce [origin margin - origin]
]
flag?: [ ; will be transformed to a function!
to logic! find values/flags flag
]
get: function [face [object!] attribute [word!] spec][
; columns-order
; columns-widths
switch/default attribute [
column-at-offset [at-offset-column face spec]
column-index [index-column face spec]
column-offset [face/pane/(index-column face spec)/offset/x]
column-right [right-column face spec]
column-width [to integer! face/pane/(index-column face spec)/size/x]
] [do make error! append copy "Unknown multi-column-text-list attribute: " attribute]
]
set: function [face [object!] attribute [word!] spec value][
; columns-order
; columns-widths
switch/default attribute [
column-positions [re-pos-columns face spec value]
column-move [move-column face spec value]
column-move-all [probedo [spec value] move-all-column face spec value]
column-order [order-column face spec value]
column-width [width-column face spec value]
column-width-all [width-all-column face spec value]
highlighted [highlight face spec value]
sort [sorting face spec value]
] [do make error! append copy "Unknown multi-column-text-list attribute: " attribute]
]
; move-column: set at get 'columns-order n at get 'columns-order m
; size-column: change at get 'columns-widths n width
; hide-column: remove at get 'columns-order n
highlight: func [face [object!] state [logic!] row [integer!] /local asy][
asy: system/view/auto-sync?
system/view/auto-sync?: no
if row > face/rows [exit]
row: max 1 row
repeat c face/columns [
face/pane/(c)/pane/(row)/color: pick [255.255.255 255.0.0 ] state
show face/pane/(c)/pane/(row)
]
system/view/auto-sync?: asy
]
index-column: func ["Returns column of given ID" face [object!] which [integer!] /local c][
which: min max 1 which face/columns
; find header with given ID
repeat c face/columns [
if face/pane/(face/columns + c)/extra/column = which [which: c break]
]
which
]
at-offset-column: func ["Returns column at given x offset" face [object!] spec [block!] /local asy pane pos-x min-x offset-x c distance offsets source-x dir][
pane: face/pane
idx: spec/1
pos-x: spec/2
min-x: face/children-span/1/x
max-x: face/children-span/1/x + face/children-span/2/x
;probedo [idx pos-x min-x max-x]
res: none
case [
;pos-x < min-x [res: 1]
;pos-x > max-x [res: face/columns]
'else [
repeat c face/columns [
;?? c
if all [
pos-x >= (pane/(c)/offset/x);
pos-x <= (pane/(c)/offset/x + pane/(c)/size/x + (face/space/x));
idx <> pane/(face/columns + c)/extra/column
]
[
;probedo ["in" c]
res: pane/(face/columns + c)/extra/column
break
]
]
]
]
; probedo [
; face/cols
; index? find face/cols idx
; res
; ]
res
]
re-pos-columns: func ["Repositions columns" face [object!] src [integer!] dst [integer!] /local asy pane pos-x min-x offset-x c distance offsets source-x dir][
;probedo [src dst]
face/cols: copy face/old-cols
;probedo [src dst index? find face/cols src index? find face/cols dst]
move/part find face/cols src find face/cols dst 1
;probedo [src dst face/cols]
;exit
old-offset: face/children-span/1/x ; min left x position
offset: old-offset ;
;if offset = 0 [exit]
foreach idx face/cols [
c: index-column face idx
old-size-x: face/pane/(c)/size/x
either src <> face/pane/(face/columns + c)/extra/column [
; place columns
face/pane/(c)/offset/x: offset
; place col-headers
c: c + face/columns
face/pane/(c)/offset/x: offset
; face/pane/(face/columns + c)/offset/x: face/pane/(face/columns + c)/offset/x - offset
; place col-draggers
c: c + face/columns
face/pane/(c)/offset/x: offset + old-size-x - (face/pane/(c)/size/x / 2)
; face/pane/(face/columns + face/columns + c)/offset/x: face/pane/(face/columns + face/columns + c)/offset/x - offset
][
;probedo [face/pane/(c)/offset/x offset]
face/dest-col-x: offset
]
offset: offset + old-size-x + face/space/x
]
;face/old-cols: face/cols
res
]
right-column: func ["Returns column right of given one" face [object!] curr-face [object!] /local asy offset-x c][
offset-x: curr-face/offset/x + curr-face/size/x + face/space/x
; find column face right of indicated offset and return its ID stored in header /extra
repeat c face/columns [
if face/pane/(c)/offset/x >= offset-x [return face/pane/(face/columns + c)/extra/column]
]
none
]
order-column: func ["Changes columns order" face [object!] which [integer!] order [word!]/local c new-which][
new-which: index-column face which
; pop to top
; pop column
move/part at face/pane new-which at face/pane face/columns 1
; pop col-header
move/part at face/pane (face/columns + new-which) at face/pane (face/columns + face/columns) 1
; pop col-dragger
move/part at face/pane (face/columns + face/columns + new-which) at face/pane (face/columns + face/columns + face/columns) 1
;probedo [new-which which: index-column face which]
;probedo [which: face/columns]
; pop order
;move/part find face/cols which tail face/cols 1
;probedo [face/cols]
]
move-column: func ["Moves a column and its dragger" face [object!] which [integer!] pos-x [integer! float!] /no-show /local asy col-dragger col c r][
asy: system/view/auto-sync?
system/view/auto-sync?: no
; find header with given ID
which: index-column face which
;if not system/view/auto-sync? [show face]
;?? pos-x
face/pane/(which)/offset/x: pos-x
;dump-face face
; move col-dragger
col-dragger: face/pane/(face/columns + face/columns + which)
;col-dragger/offset/x: (face/get 'column-width which) + pos-x - (col-dragger/size/x / 2)
col-dragger/offset/x: pos-x + face/pane/(which)/size/x - (col-dragger/size/x / 2)
unless no-show [show face]
system/view/auto-sync?: asy
]
move-all-column: func ["Moves a column, its dragger and its header" face [object!] which [integer!] pos-x [integer! float!]/local asy old-width col c r][
;where: first at-offset-column face reduce [face pos-x]
;probedo [attempt [where/offset/x]]
move-column/no-show face which pos-x
which: index-column face which
; move col-header
face/pane/(face/columns + which)/offset/x: pos-x
if not system/view/auto-sync? [show face]
]
width-column: func [face [object!] which [integer!] value [integer!] /no-show /local asy old-width col c r span][
asy: system/view/auto-sync?
system/view/auto-sync?: no
which: index-column face which
value: to integer! min max 4 value 100000 ; FIXME: better this ? system/view/screens/1/size/x - 20
; resize column's header
face/pane/(face/columns + which)/size/x: value
col: face/pane/(which)
old-width: col/size/x
; resize column's panel
col/size/x: value
; resize rows's panel
;col/pane/1/size/x: value
; resize column's rows
repeat r face/max-visible-rows [
col/pane/(r)/size/x: value
]
; move others
value: old-width - value
repeat c face/columns [
if face/pane/(c)/offset/x > face/pane/(which)/offset/x [
; move right columns
face/pane/(c)/offset/x: face/pane/(c)/offset/x - value
; move col-headers
face/pane/(face/columns + c)/offset/x: face/pane/(face/columns + c)/offset/x - value
; move col-draggers
face/pane/(face/columns + face/columns + c)/offset/x: face/pane/(face/columns + face/columns + c)/offset/x - value
]
]
face/children-span: second span: span? face
if span/1/x > 0 [do make error! "MCTL wrong layout, too right"]
;probedo [scroller/x/position]
if scroller/x [
;update-scrollers face as-pair (face/size/x) (face/size/y - face/headers-height) as-pair (face/children-span/x) (face/row-height * face/rows) ; this makes GUI flicker a lot :(
update-scrollers face as-pair (face/size/x) (min (face/size/y - face/headers-height) (face/row-height * face/max-visible-rows - 1)) as-pair (face/children-span/x) (face/row-height * face/rows)
]
unless no-show [show face]
system/view/auto-sync?: asy
]
width-all-column: func [face [object!] which [integer!] value [integer!] /local asy old-width col c r span][
which: index-column face which
old-width: face/pane/(which)/size/x
width-column/no-show face which value
value: old-width - value
; move col-dragger
face/pane/(face/columns + face/columns + which)/offset/x: face/pane/(face/columns + face/columns + which)/offset/x - value
show face
]
comp: context [
col: 1
compare-row: func [
a
b
][
any [
attempt [
a/(col) < b/(col)
]
(form a/(col)) < (form b/(col))
]
]
]
sorting: func [face [object!] which [integer!] value [integer! word! none!] /local asy old-width col c r span][
;bisecting-sort face/data-copy which
comp/col: which
sort/stable/compare face/data-copy :comp/compare-row
;?? value
if any [value = 'z-a value = -1] [reverse face/data-copy]
scroll face scroller/y/position 'y ; refresh
show face
]
mini: func [face [object!] start [integer!] r [integer!] c [integer!] /local n minimum][
face/data-copy/(start + r)/(c)
; minimum: face/data/(1)/(c)
; repeat n start + r - 1 [
; ;probedo [n start r c minimum face/data/(n + 1)/(c) ]
; minimum: min minimum face/data/(n + 1)/(c)
; ]
; minimum
]
scroll-to: function [face [object!] pos [pair!]][
;TBD
]
scroll: func [face [object!] value [integer!] axis [word!] /local asy offset old-offset start col c r data][
asy: system/view/auto-sync?
system/view/auto-sync?: no
;if value = 1 [exit] ; no scrollers movement, but we could still have been moved !
value: max 1 value
;probedo ["scroll" value (to-lit-word axis) face/row-height]
either axis = 'y [
start: to integer! value - 1 / (face/row-height + 1e-6) + 1e-6
offset: face/headers-height + to integer! negate modulo value - 1 face/row-height
repeat col face/columns [
c: index-column face col
face/pane/(col)/offset/y: offset
;probedo [start face/visible-rows]
;probedo [face/max-visible-rows face/visible-rows]
repeat r min face/max-visible-rows face/visible-rows [
if (start + r) > face/rows [break]
;?? r
;?? col
;probedo [(start + r) c r]
data: form face/data/(start + r)/(col)
;data: form mini face start r col
face/pane/(c)/pane/(r)/text: either (start + r) <= face/rows [data][" "]
]
]
][
;offset: value - 1 - absolute face/pane/1/offset/x ;@@ "- 1" because this must be 0-based
old-offset: first first span? face ; min left x position
offset: old-offset + value - 1 ;@@ "- 1" because this must be 0-based
if offset = 0 [exit]
repeat c face/columns [
; move columns
face/pane/(c)/offset/x: face/pane/(c)/offset/x - offset
; move col-headers
c: c + face/columns
face/pane/(c)/offset/x: face/pane/(c)/offset/x - offset
; face/pane/(face/columns + c)/offset/x: face/pane/(face/columns + c)/offset/x - offset
; move col-draggers
c: c + face/columns
face/pane/(c)/offset/x: face/pane/(c)/offset/x - offset
; face/pane/(face/columns + face/columns + c)/offset/x: face/pane/(face/columns + face/columns + c)/offset/x - offset
]
]
system/view/auto-sync?: asy
]
on-scroll: func [face [object!] event [event! none!] /local axis][ ; function "layout" inspired by @cosacam1 version
axis: pick [y x] (any [event/orientation 'vertical]) = 'vertical
if all [axis = 'y any [not scroller/y/visible? event/ctrl?]] [axis: 'x] ; FIXME: better use shift ?
scroller/(axis)/position: min max 1 switch event/key [
up left [scroller/(axis)/position - scroller/(axis)/min-size]
down right [scroller/(axis)/position + scroller/(axis)/min-size]
page-up page-left [scroller/(axis)/position - scroller/(axis)/page-size]
page-down page-right [scroller/(axis)/position + scroller/(axis)/page-size]
track [event/picked ]
wheel [scroller/(axis)/position - (scroller/(axis)/min-size * to integer! event/picked)] ; forwarded event by on-wheel
end [scroller/(axis)/position]
] (scroller/(axis)/max-size - scroller/(axis)/page-size)
scroll face scroller/(axis)/position axis
if not system/view/auto-sync? [show face]
]
on-scroll: func [face [object!] event [event! none!] /local axis scr pos][ ; function "layout" inspired by @cosacam1 version
axis: pick [y x] (any [event/orientation 'vertical]) = 'vertical
if all [axis = 'y any [not scroller/y/visible? event/ctrl?]] [axis: 'x] ; FIXME: better use shift ?
scr: scroller/(axis)
pos: scr/position
scr/position: min max 1 switch event/key [
up left [pos - scr/min-size]
down right [pos + scr/min-size]
page-up page-left [pos - scr/page-size]
page-down page-right [pos + scr/page-size]
track [event/picked]
wheel [pos - (scr/min-size * to integer! event/picked)] ; forwarded event by on-wheel
end [pos]
] (scr/max-size - scr/page-size)
scroll face scr/position axis ; use an overwritable function
if not system/view/auto-sync? [show face]
]
on-wheel: function [face [object!] event [event! none!]][;May-be switch shift and ctrl ?
if any [scroller/x/visible? scroller/y/visible?] [
on-scroll face event ; forward
]
]
on-created: func [face [object!] event [event! none!] /locl temp][
scroller/x: get-scroller face 'horizontal
scroller/y: get-scroller face 'vertical
face/children-span: second span? face
;face/child/offset: 0x0 ; align to top-left
face/data-copy: copy face/data
resize face face/size
;face/set 'column-width-all 1 50
;face/set 'column-width-all 2 150
face/set 'column-width-all 3 100
]
entangle: func ["Activate reactions" face1 face2][
;if flag? 'fixed [face1/values/min-child-size: face1/values/max-child-size: face2/size ]
face1/size: face1/actors/resize face1 face1/size
;if not system/view/auto-sync? [show [face1]] ;
]
; must adjust both scrollers at the same time
update-scrollers: function [face [object!] size [pair! none!] inner-size [pair!]][ ; some parts of this function are inspired by one of Anton Rolls
asy: system/view/auto-sync?
system/view/auto-sync?: no
scy: scroller/y
scx: scroller/x
y-size: to integer! system/view/metrics/misc/scroller/y * 96 / system/view/metrics/dpi ;@@ WHAT !!??, really ??
x-size: to integer! system/view/metrics/misc/scroller/x * 96 / system/view/metrics/dpi
;face/child/size: min max face/values/min-child-size size face/values/max-child-size
visible-y: size/y
total-y: inner-size/y
visible-x: size/x
total-x: inner-size/x
; determine if scrollers are necessary to be shown
; subtract here space taken by scrollers, if necessary
if scy-visible?: total-y > visible-y [
;face/children-span/y: min max face/values/min-child-size/y (size/y - x-size) face/values/max-child-size/y
;total-y: face/children-span/y
if scy-visible?: total-y > visible-y [; check again
; adding a vertical scroller changes horizontal visible size
visible-x: size/x - y-size
]
]
if scx-visible?: total-x > visible-x [
;face/children-span/x: min max face/values/min-child-size/x (size/x - y-size) face/values/max-child-size/x
;total-x: face/children-span/x
if scx-visible?: total-x > visible-x [; check again
; adding a horizontal scroller changes vertical visible size
visible-y: size/y - x-size
]
]
; adding the horizontal scroller might make the vertical scroller necessary
if all [not scy-visible? scy-visible?: total-y > visible-y ] [
;face/children-span/y: min max face/values/min-child-size/y (size/y - x-size) face/values/max-child-size/y
;total-y: face/children-span/y
if scy-visible?: total-y > visible-y [; check again
; adding a vertical scroller changes horizontal visible size
visible-x: size/x - y-size
]
]
scy/max-size: 0 ;@@ workaround to avoid scroller to become disbled !
scy/max-size: to integer! total-y
scy/page-size: 0
scy/page-size: to integer! visible-y
scy/visible?: none
scy/visible?: scy-visible?
scy/min-size: to integer! visible-y / 10 ; FIXME hardcoded value
; constrain to allowed range
scy/position: to integer! min max 1 scy/position (total-y - visible-y)
scx/max-size: 0 ;@@ workaround to avoid scroller to become disbled !
scx/max-size: to integer! total-x + 1 ;@@ + 1 only for 144 dpi but beware that /visible? is setted also by Red !
scx/page-size: 0
scx/page-size: to integer! visible-x
scx/visible?: none
scx/visible?: scx-visible?
scx/min-size: to integer! visible-x / 10
;probedo ["1" scx/position (total-x - visible-x) ]
; constrain to allowed range
scx/position: to integer! min max 1 scx/position (total-x - visible-x)
span: span? face
; scroll to keep maximum possible visibility while keeping top-left alignment
face/actors/scroll face to integer! max 1 min scy/position absolute (total-y - visible-y) 'y
;face/actors/scroll face to integer! max 1 min scx/position absolute (total-x - visible-x) 'x
; right align
if (span/2/x + span/1/x) < visible-x [face/actors/scroll face to integer! span/2/x - visible-x 'x]
; fall back to left alignment
if span/2/x < visible-x [face/actors/scroll face 1 'x]
;show face
system/view/auto-sync?: asy
]
resize: function [face [object!] size [pair! point2D! none!]][
;face/visible-rows: 2 + to integer! size/y / (face/row-height + 1e-6) + 1e-6
face/visible-rows: round/ceiling (size/y - face/headers-height) / (face/row-height + 1e-6) + 1e-6 ; FIXME face/space/y
; FIXME: recalc also max-visible-rows because user could have changed screen resolution ?
;span: span? face
face/children-span: second span? face
;update-scrollers face as-pair (face/size/x) (face/size/y - face/headers-height) as-pair (face/children-span/x) (face/row-height * face/rows)
update-scrollers face as-pair (face/size/x) (min (face/size/y - face/headers-height) (face/row-height * face/max-visible-rows - 1)) as-pair (face/children-span/x) (face/row-height * face/rows)
if not system/view/auto-sync? [show face]
size ; IMPORTANT for reactions !
]
]
]
init: [
face: self
;?? face
face/actors/flag?: func [flag [word! block!]] bind face/actors/flag? face ;@@ Do I really have to do this ??
; face/actors/set: func [value [number!] ] bind face/actors/set face
; face/actors/resize: func [size [pair!] /local siz arrw-up arrw-dn] bind face/actors/resize face
face/options: union trim to block! face/options [style: multi-text-list]
;row-height: pick get in make-face/spec 'textmin ["Wfqp"] 'size 2
face/row-height: make-face/spec 'textmin ["Wfqp"]
face/row-height: face/row-height/size/y ;+ row-gap
face/max-visible-rows: 2 + round/ceiling system/view/screens/1/size/y / face/row-height
;?? face/row-height
if none? face/data [face/data: [[""]]]
if empty? face/data [face/data: [[""]]]
if empty? face/data/1 [face/data: [[""]]]
face/columns: length? face/data/1
face/rows: (length? face/data) - 1 ; FIXME: - 1 because 1st row is that of headers
comment [(; cursor image
draw/transparent 21x12 [
anti-alias off
translate 11x6
shape [
pen black fill-pen white
move -11x0
'line 6x-6 0x5 10x0 0x-4 5x5 -5x5 0x-3 -10x0 0x4 -6x-6
]
]
)]
main-pane: compose [ ;@@ I cannot use face/pane because of a reactor ! and I cannot use pane because it is already bounded ?
origin 0x25
space 4x0 ;@@ hardcoded, watch out
across
style col-dragger:
box 8x25 magenta ;255.255.255.254
cursor hand ; placeholder
all-over
with [
actors: object [
on-click: func [face event] [
print "click"
;mtl/actors/update-scrollers mtl mtl/size as-pair (mtl/children-span/x) (mtl/row-height * mtl/rows)
]
on-down: func [face event] [
face/extra/x: event/offset/x
]
on-over: func [face event /local delta mtl col-offset] [
if all [event/down? face/extra/column > 0] [
;system/view/debug?: yes
offset-x: face/offset/x
mtl: face/parent
col-offset: mtl/get 'column-offset (face/extra/column)
;face/offset/x: face/offset/x + event/offset/x - face/extra/x ; move face
face/offset/x: min max (4 + 4 + col-offset) (offset-x + event/offset/x - face/extra/x) (280 + col-offset ) ; move face
delta: to integer! face/offset/x - offset-x
mtl/set 'column-width face/extra/column ((mtl/get 'column-width face/extra/column) + delta)
if not system/view/auto-sync? [show face]
system/view/debug?: no
]
]
]
]
style col-header:
text 80x25 cyan " " center middle no-wrap ; headers
;base 255.255.255.254 80x25 cyan " " center middle no-wrap ; use this to see the "trick" and the circle when clicked
loose
;extra object [origin: 0x0 column: 0 old-column: 0 delta: 0 left: none right: none sort: 0]
;extra object [origin: 0x0 column: (c) old-column: (c) delta: 0 left: none right: none source-x: 0 dest-x: 0 dragged: none inside: none sort: 0]
with [
actors: object [
on-created: func [face event] [
append face/options compose [bounds: (object [min: face/offset - 10000x0 max: face/offset + 10000x0])]
]
on-drag-start: func [face event /local c offsets mtl] [
face/extra/dragged: false
mtl: face/parent
mtl/dest-col-x: face/offset/x
face/extra/origin: face/offset
face/extra/delta: face/offset/x
;probedo[face/extra/right: face/parent/get 'column-right face]
face/extra/source-x: face/offset/x
face/extra/dest-x: face/offset/x
mtl/set 'column-order face/extra/column 'top
face/extra/inside: none
mtl/children-span: mtl/actors/span?/part mtl mtl/columns
]
on-drag: func [face event /local mtl dest dir temp origin-x op distance left-x min-x max-x] [
face/extra/dragged: true
;robedo [face/extra/column]
mtl: face/parent
min-x: 1e7
max-x: -1e7
mtl/set 'column-move face/extra/column face/offset/x
res: mtl/get 'column-at-offset reduce [face/extra/column (face/offset/x + (face/size/x / 2)) ]
if none? res [;print "none"
mtl/old-cols: mtl/cols
exit
]
mtl/set 'column-positions face/extra/column res
]
on-drop: func [face event /local mtl] [
mtl: face/parent
either face/extra/dragged [
mtl/set 'column-move-all face/extra/column mtl/dest-col-x
if not system/view/auto-sync? [show face]
][
print "click"
mtl: face/parent
face/extra/sort: either 0 = order: face/extra/sort [1][negate order]
probedo [face/draw]
face/draw: mtl/draw-arrow
;face/draw/trans/2: 10x10
probedo [face/draw]
show face
;order: pick [a-z z-a] order = 1
mtl/set 'sort face/extra/column face/extra/sort
]
]
]
]
]
color: white
; append columns and cells
repeat c face/columns [
append face/old-cols c
;append main-pane 'panel
; append columns
append main-pane compose/only [
panel (as-pair 80 system/view/screens/1/size/y) yellow (copy [origin 0x0 space 0x0 below])
;col-header with (compose [extra/column: (c)]) ; headers
;col-header extra object [origin: 0x0 column: (c) delta: 0]
;panel ;
]
;p: copy [origin 0x0 space 0x0 below]
; append cells
;repeat r min face/max-visible-rows face/rows [
repeat r face/max-visible-rows [
append last main-pane compose/only [
textmin 60 (color - (c * 30 * 1.1.0)) " " ;(form reduce [c r]);(form face/data/(r)/(c)) ;on-over [face/color: pick [255.255.255 255.0.0 ] event/away?]
with (compose [extra/row: (r)])
]
]
;append/only last main-pane p
;append main-pane [return at 0x0]
;append main-pane [return]
]
append main-pane [return origin 0x0 across]
; append headers
repeat c face/columns [
append main-pane compose/deep [
col-header data (c) extra object [origin: 0x0 column: (c) old-column: (c) delta: 0 left: none right: none source-x: 0 dest-x: 0 dragged: none inside: none sort: 0]
]
]
append main-pane [return origin 76x0 space 76x0 across]
; append draggers
repeat c face/columns [
;append main-pane 'col-dragger ;compose/only [col-dragger with (compose [extra/column: (c - 1)]) ]
append main-pane compose/deep [
col-dragger extra object [column: (c - 0) x: 0 ]
]
]
; append main-pane [base 200x15 0.0.255.200]
;?? main-pane
pane: layout/only/tight main-pane
face/headers-height: face/pane/(face/columns + 1)/size/y
face/headers: copy face/data/1 ; FIXME: parse ...
;@@ remove headers row
remove face/data
; move headers on top by moving them to tail
; repeat c face/columns [
; move face/pane/(c)/pane next face/pane/(c)/pane
; ]
; set cells' texts
repeat c face/columns [
repeat r min face/max-visible-rows face/rows [ ;@@ WARNING: use do because of overwritten `min`!
face/pane/(c)/pane/(r)/text: form face/data/(r)/(c)
]
]
; set headers titles
repeat c face/columns [
face/pane/(face/columns + c)/text: form face/headers/(c)
]
;?? face/pane
;dump-face face
system/view/VID/styles/textmin: none
face/size: 300x150
face/cols: copy face/old-cols
face/color: blue ; to see if resizing is right
react/link/later :face/actors/entangle [face face]
]
]
do
[
if any [%multi-text-list.red = find/last/tail system/options/script "/" ; It's really me ?
system/script/args = "test"] [
print "" ; open console for debug
system/view/auto-sync?: no
system/view/VID/styles/text: [template: [type: 'text size: 0x0]]
{
view [
button "OK" all-over
on-down [x: event/offset/x]
on-over [if event/down? [face/offset/x: face/offset/x + round/floor/to event/offset/x 2 - x]]
]
; options/bounds: object [min: pair! max: pair!]
}
win: layout [
title "Multi column text list examples" ;@@ I wish I could do : title (system/script/header/title)
backdrop brown
across middle
style text: text font-size 10
;{Please do not blame me for a slow or flickering GUI rendering, and for other "hiccups".}
button "insert C"
button "move C2 left" [] ;loose
extra object [column: 1 x: 0]
all-over
with [
actors: object [
on-click: func [face event] [
print "click"
;mtl/actors/update-scrollers mtl mtl/size as-pair (mtl/children-span/x) (mtl/row-height * mtl/rows)
]
on-down: func [face event] [
face/extra/x: event/offset/x
]
on-over: func [face event /local delta] [
if event/down? [
;system/view/debug?: yes
delta: face/offset/x
face/offset/x: min max (mtl/get 'column-offset (face/extra/column)) face/offset/x + event/offset/x - face/extra/x ((180 + mtl/get 'column-offset (face/extra/column)) ) ; move face
delta: face/offset/x - delta
mtl/set 'column-width face/extra/column ((mtl/get 'column-width face/extra/column) + delta)
if not system/view/auto-sync? [show face]
system/view/debug?: no
]
]
]
]
button "append C" loose ;with [options: compose [bounds: (object [min: 0x0 max: 0x0])]];[mtl/insert-column 4 ["Col 4 1" "Col 4 2"]]
extra object [origin: 0x0 column: 3 delta: 0]
on-created [
face/extra/origin: face/offset
face/extra/delta: face/offset/x
append face/options compose [bounds: (object [min: face/offset - 100x0 max: face/offset + 100x0])]
]
on-drag [
mtl/set 'column-move face/extra/column face/offset/x - face/extra/delta
face/extra/delta: face/offset/x
]
on-drop [
face/offset: face/extra/origin
if not system/view/auto-sync? [show face]
]
return
mtl1: multi-text-list data [
;["Name" 80 'A-Z "Column 2" "Column 3"] ;'opt icon <name> [string! image!] <width> [integer! default: 80] <backcolor> [tuple! default: white] <textcolor> [tuple! default: black] align [word! 'left 'center 'right default: 'left] sorting [word! 'A-Z 'Z-A none! default: none] editing [logic! default: true]
["Column 1" "Col 2" "Col 3"]
["Element 1" 10:25 "Comment 31"]
["Element 2" "Column 2" "Comment 32"]
["Element 53" "C 2" "Comment 33"]
["Element 4" "C 2" "Comment 34"]
["Element 5" "C 2" "Comment 35"]
["Element 6" "C 2" "Comment 36"]
["Element 7" "C 2" "Comment 3"]
; ["Element 8" "C 2" "Comment 3"]
; ["Element 9" "C 2" "Comment 3"]
; ["Element 10" "C 2" "Comment 3"]
; ["Element 11" "C 2" "Comment 3"]
; ["Element 12" "C 2" "Comment 3"]
; ["Element 13" "C 2" "Comment 3"]
; ["Element 14" "C 2" "Comment 3"]
; ["Element 15" "C 2" "Comment 3"]
]
]
;dump-face win
view/flags/options win 'resize [
actors: object [
on-create: func [face][face/data: face/size] ; init value
on-focus: func [face event][face/data: face/size] ; store old size
on-resize: func [face event][face/actors/on-resizing face event] ; forward
on-resizing: func [face event /local siz][
siz: face/size - face/data ; compute size difference
face/data: face/size ; store new size
mtl1/size: mtl1/size + (siz * 1x1)
; t-1/offset: t-1/offset + (siz * 1x0)
if not system/view/auto-sync? [show face]
]
]
]
] ; if
] ; do
Raw
numeric-spinner.red
Red [
title: "Numeric spin field"
author: @luce80
Rights: "Copyright (C) 2024 Marco Antoniazzi. All rights reserved."
License: BSL-1
file: %numeric-spinner.red
gist: https://gist.githubusercontent.com/luce80/433286c66d98997aff6e69fbd6323a35/raw/3d8cba0644232748218442467537c8f4e706d361/numeric-spinner.red
date: 02-01-2024
version: 0.6.7
history: [
0.0.0 [18-10-2022 "Started"]
0.1.0 [24-10-2022 "continued"]
0.2.0 [29-10-2022 "Most graphic parts and behaviours"]
0.3.0 [30-10-2022 "Integer flag and reactions"]
0.4.0 [01-11-2022 "cycle, drag, wheel, keys, fixes"]
0.5.1 [05-11-2022 "keep decimal places, docs, changed sizing algorithm, fixes"]
0.5.2 [06-11-2022 {system/script/args = "test", focus}]
0.6.2 [19-11-2022 "Allow math ops, minor enhancement"]
0.6.3 [25-11-2022 "fix (!?) when auto-sync? is off, simplified space-ops"]
0.6.4 [22-01-2023 "Added style: spin-number"]
0.6.5 [20-02-2023 "refactored code a little"]
0.6.6 [29-12-2023 "made compatible with new point2D! datatype"]
0.6.7 [02-01-2024 "removed face/min etc."]
]
Notes: {
This is a VID style to make it easier to enter numbers.
To initialize the main value use a string or `data`.
You can set some parameters by using `options` VID keyword.
The currently available parameters are:
- min: minimum value (lower limit)
- max: maximum value (upper limit)
- step: step by which in/de-crement when clicking arrow buttons
- precision: a number between 0 and 1 used to define number of decimal places displayed. E.g. 0.01 means display 2 decimals
- flags: a `block!` containing one or more of:
- integer numbers are displayed and kept as `integer!`s
- cycle during GUI interaction if upper limit is exceeded the number will restart from lower limit
- read-only field is disabled but arrow buttons will still work
Since this is a `panel` you can not use a `block!` to have a default action, use `on-enter` and/or `on-click` instead.
Since this is a `panel` you can not use a `number!` to specify the size, you must use a `pair!` instead.
Since this is a `panel` you can not give focus to it, you must use e.g. `set-focus my-spinner/field` instead.
See at bottom of script for a usage example.
}
]
probedo: func [code [block!] /local result][print [mold code mold/only result: reduce code] do :result]
system/view/VID/styles/spin-number: [
default-actor: on-enter
template: [
type: 'panel
size: 0x0
;flags: copy [] ; reserved by Red
old-text: none
this: none ; self
field: none ; shortcut
old-size: 0x0 ; used to resize incrementally
values: object [ ; object used to extend VID params and set main control params
min: 0
max: 100
step: 1 ; to in/de-crement
factor: 1 ; when using <ctrl> or <shift> ; TBD
precision: step ;@@ or something else ?
flags: copy [] ; 'integer , 'cycle , 'read-only ;TBD 'percent , 'time , 'money , 'alerts(-on-wrong-validation)
;TBD unit: "" ;"%", " mm" etc. could use @toomasv's units.red
;TBD prefix: "" ; "$"
]
actors: [
no-num: complement charset "1234567890,.-+*/() ^-"
space-ops: func [string [string!]][; add spaces around math ops
if find string no-num [return ""] ; force error!
parse next string [; use next to avoid sign symbol
some [to ["+" | "-" | "*" | "/"] insert " " skip insert " "]
]
head string
]
flag?: [ ; will be transformed to a function!
to logic! find values/flags flag
]
set: [ ; will be transformed to a function!
;prin "set "
;?? value
if flag? 'cycle [value: values/min + mod (value - values/min) (values/max - values/min)]
value: to float! min max values/min value values/max ; force to float!
precision: min max 1e-6 values/precision 1 ; avoid division by 0 and scientific notation
; add decimals to remove them later
value: (round/to value precision) + (precision * 0.1 * sign? value)
text: form value
; keep only desired decimal places
text: head clear skip text (length? text) - pick [1 2] precision < 1
if flag? 'integer [value: to integer! round value]
data: value
old-text: copy text ; store old value to be able to restore it if an error occurs
text
]
change: func [face [object!] event [event! none!] delta [number!]][
; FIXME: use a non-linear (exponential ?) function
set face/data + (face/values/step * delta * factor face/field event)
]
resize: [ ; will be transformed to a function!
siz: size - old-size ; compute size difference
old-size: size ; store new size
arrw-up: pane/2 arrw-dn: pane/3
field/size: field/size + (siz * 1x1)
field/font/size: to integer! size/y / 2
;arrw-up/size: arrw-up/size * (1, 0) + (field/size * (0, 0.5))
;arrw-dn/size: arrw-dn/size * (1, 0) + (field/size/y - arrw-up/size/y + 1 * (0, 1))
arrw-up/size/y: to integer! field/size/y / 2
arrw-up/offset: arrw-up/offset + (siz * 1x0)
arrw-dn/size/y: to integer! field/size/y - arrw-up/size/y + 1
arrw-dn/offset: as-point2D (arrw-up/offset/x) (field/size/y - arrw-dn/size/y + 1)
;size: size ; done by entangle
size ; IMPORTANT for reactions !
]
factor: func [face [object!] event [event! none!]][
; FIXME: hardcoded values
case [
all [event/ctrl? event/shift?] [20]
event/ctrl? [2]
event/shift? [10]
face/extra/shift? [10]
'else [1]
]
]
entangle: func ["Activate reactions" face1 face2][
face2/text: face1/actors/set face1/data
face1/size: face1/actors/resize face1/size
if not system/view/auto-sync? [show [face1 face2]] ;@@ force update even if auto-sync? is off (!!??)
]
on-created: func [face [object!] event [event! none!]][
;?? face
face/old-size: face/size
face/field: face/pane/1
if not number? load face/field/text [face/field/text: form face/min] ; FIXME: or give error! ?
;face/data: load face/field/text
face/actors/set load face/field/text
]
]
]
init: [
face: self
face/actors/flag?: func [flag [word! block!]] bind face/actors/flag? face ;@@ Do I really have to do this ??
face/actors/set: func [value [number!] /local precision] bind face/actors/set face
face/actors/resize: func [size [pair! point2D!] /local siz arrw-up arrw-dn] bind face/actors/resize face
if face/size/x = 0 [face/size/x: 60]
if face/size/y = 0 [face/size/y: 26]
face/pane: face/flags ; store flags
face/values: make face/values any [face/options []]
if not all [face/options face/options/precision] [face/values/precision: face/values/step]
face/values/flags: to-block face/values/flags
set face face/values
face/flags: face/pane ; restore flags
face/options: trim union to block! face/options [style: spin-number]
face/pane: layout/only/tight compose [
space 0x0
across
field (any [all [face/data form face/data] face/text "0"]) (face/size - 13x0) right font-size (any [attempt [face/font/size] 12]) ;
extra object [shift?: false offset: none last-offset: none moving?: false]
on-down [face/extra/offset: face/extra/last-offset: event/offset]
on-up [face/extra/offset: none face/extra/moving?: false]
all-over
on-over [
if any [face/extra/moving? all [ face/extra/offset (absolute (face/extra/offset/y - event/offset/y)) > 10]] [
face/extra/moving?: true
face/parent/actors/change face/parent event either face/extra/offset [face/extra/last-offset/y - event/offset/y] [0]
]
face/extra/last-offset: event/offset
]
on-key [
face/parent/actors/change face/parent event switch/default event/key [up [+1] down [-1]] [exit]
]
on-wheel [
face/parent/actors/change face/parent event event/picked
]
[; action (on-enter)
if none? attempt [face/parent/actors/set do face/parent/actors/space-ops face/text] [face/text: copy face/parent/old-text]
]
below
style arrow: button 13x13 font-size 8 data 1 extra object [shift?: false time: none]
on-time [
face/actors/on-click face event
if all [time? face/extra/time (now/time - face/extra/time) >= 0:0:2] [ ; wait 2 seconds and then speed up even more
face/rate: to-time .02
face/extra/time: 0
]
if none? face/extra/time [
face/rate: to-time .1
face/extra/time: now/time
]
]
on-down [
face/extra/shift?: event/shift? face/rate: to-time .5 ;@@ use face/extra/shift? because time events do not have event/shift?
if not system/view/auto-sync? [show face] ;@@ force update even if auto-sync? is off (!!??)
]
on-up [
face/extra/time: none face/rate: none
if not system/view/auto-sync? [show face] ;@@ force update even if auto-sync? is off (!!??)
]
[ ; action (on-click)
set-focus face/parent/field
face/parent/actors/set face/parent/data + (face/parent/values/step * face/data * face/parent/actors/factor face event)
]
arrow "▲" data +1
arrow "▼" data -1
]
face/pane/1/parent: face
face/pane/2/parent: face
face/pane/3/parent: face
if face/actors/flag? 'read-only [face/pane/1/enabled?: false face/pane/1/flags: [no-border] ];
face/size/x: face/pane/1/size/x + face/pane/2/size/x - 2 ;@@ "-2" because of button's "outline" (is this only Win related?)
face/size/y: face/pane/1/size/y
;face/color: blue ; to see if resizing is right
react/link/later :face/actors/entangle [face face/pane/1]
]
]
do
[
if any [%numeric-spinner.red = find/last/tail system/options/script "/" ; It's really me ?
system/script/args = "test"] [
;print "" ; open console for debug
system/view/VID/styles/text: [template: [type: 'text size: 0x0]]
win: layout [
title "Numeric spinner examples" ;@@ I wish I could do : title (system/script/header/title)
across middle
style text: text font-size 10
; note that spinners can be initialized with a string or with data
sp-1: spin-number "50.0" options [min: 0 max: 100 step: 0.5]
t-1: text "min 0.0 max 100.0 step 0.5"
return
sp-2: spin-number data 50.0 options [min: 0 max: 360 precision: 0.1 flags: [cycle]]
t-2: text "min 0.0 max 360.0 step 1.0 precision 0.1 cycle"
return
sp-3: spin-number 80x25 "2.0" options [min: 0 max: 1000 step: 1 flags: [integer]]
t-3: text "min 0 max 1000 step 1 integer"
return
sp-4: spin-number 150x50 "20.0" options [min: -1000 max: 1000 step: .01]
t-4: text "min -1000 max 1000 step .01"
return
below
space 0x0
style h: h5 bold
h-1: h "Use also (qualified) arrows keys"
h-2: h "Use also (qualified) scroll-wheel"
h-3: h "Try also (qualified) drag up and down inside field"
h-4: h "Also simple math operations are allowed"
]
view/flags/options win 'resize [
actors: object [
on-create: func [face][face/data: face/size] ; init value
on-focus: func [face event][face/data: face/size] ; store old size
on-resize: func [face event][face/actors/on-resizing face event] ; forward
on-resizing: func [face event /local siz][
siz: face/size - face/data ; compute size difference
face/data: face/size ; store new size
sp-1/size: sp-1/size + (siz * 1x0)
t-1/offset: t-1/offset + (siz * 1x0)
]
]
]
] ; if
] ; do
Raw
Red-vid-styles.red
Red []
;%numeric-spinner.red
;%area-plus.red
;%splitter.red
;%scrollable-panel.red
;%%multi-text-list.red
;%area-rt.red
;%spinner-panel.red
;%tipped-button.red
Raw
scrollable-panel.red
Red [
title: "Scrollable panel"
file: %scrollable-panel.red
author: @luce80
License: 'PD
gist-view: https://gist.github.com/luce80/433286c66d98997aff6e69fbd6323a35#file-scrollable-panel-red
date: 27-02-2024
version: 0.6.5
history: [
0.0.0 [10-10-2022 "Started"]
0.0.1 [18-12-2022 "minimum working version"]
0.6.0 [24-12-2022 "working version"]
0.6.1 [06-01-2023 "Better 'fixed checking"]
0.6.2 [28-01-2023 "fixed scrollers update workaround and child size change"]
0.6.3 [29-01-2023 "externalized scroll function"]
0.6.4 [29-12-2023 "fixed for new point2D! datatype"]
0.6.5 [27-02-2024 "fixed to avoid sizing before scrollers are available"]
]
Note: {Needs Red 0.6.4 built 09-Aug-2022 or later}
Notes: {
This is a VID panel with auto-hiding scrollers.
It can have only 1 child face.
The child face size will be adapted to that of the panel.
You can set some parameters by using `options` VID keyword.
The currently available parameters are:
- min-child-size: the minimum size [pair!] (in pixels) that the child gadget can have.
- max-child-size: the maximum size [pair!] (in pixels) that the child gadget can have.
- flags: a `block!` containing one or more of:
- fixed Set min-child-size = max-child-size = initial child size
Note that by setting min-child-size = max-child-size you will have a fixed size child.
Please do not blame me for a slow or flickering GUI rendering, and for other "hiccups".
See at bottom of script for a usage example.
}
]
probedo: func [code [block!] /local result][print [mold code mold/only result: reduce code] do :result]
if system/build/date < 26-11-2022 [alert "A more recent version of Red is required !" either empty? gui-console-ctx/terminal/lines [quit][halt]]
scrollable-panel.red-ctx: context [
system/view/VID/styles/scrollable-panel: [
default-actor: on-down
template: [
type: 'panel
flags: [scrollable]
child: none ; shortcut
values: object [ ; object used to extend VID params and set main control params
min-child-size: 0x0
max-child-size: 100000x100000
flags: copy [] ; 'fixed
]
actors: [
scroller: make map! 2
; scroller fields
; position: 1 ;@@ a better name could be "scroll" or "amount" or "value" or "data"
; page-size: none ;@@ a better name could be "page" or "visible-part"
; min-size: 1 ; ?? . Used for step scrolling
; max-size: 1 ;@@ a better name could be "total"
; visible?: true
; vertical?: true ;@@ a better name could be "orientation" with value 'x or 'y
; parent: none
; page: 1 ; ??
flag?: [ ; will be transformed to a function!
to logic! find values/flags flag
]
scroll-to: function [face [object!] pos [pair!]][
;TBD
]
scroll: function [face [object!] pos [integer! ] axis [word!]][
face/child/offset/(axis): to integer! 1 + negate pos ;@@ "1 +" because this must be 0-based
]
on-scroll: func [face [object!] event [event! none!] /local axis scr pos][ ; function "layout" inspired by @cosacam1 version
axis: pick [y x] (any [event/orientation 'vertical]) = 'vertical
if all [axis = 'y any [not scroller/y/visible? event/ctrl?]] [axis: 'x] ; FIXME: better use shift ?
scr: scroller/(axis)
pos: scr/position
scr/position: min max 1 switch event/key [
up left [pos - scr/min-size]
down right [pos + scr/min-size]
page-up page-left [pos - scr/page-size]
page-down page-right [pos + scr/page-size]
track [event/picked]
wheel [pos - (scr/min-size * to integer! event/picked)] ; forwarded event by on-wheel
end [pos]
] (scr/max-size - scr/page-size)
scroll face scr/position axis ; use an overwritable function
if not system/view/auto-sync? [show face]
]
on-wheel: function [face [object!] event [event! none!]][;May-be switch shift and ctrl ?
if any [scroller/x/visible? scroller/y/visible?] [
on-scroll face event ; forward
]
]
on-created: func [face [object!] event [event! none!] /locl temp][
scroller/x: get-scroller face 'horizontal
scroller/y: get-scroller face 'vertical
if face/values/min-child-size/x > face/values/max-child-size/x [temp: face/values/min-child-size/x face/values/min-child-size/x: face/values/max-child-size/x face/values/max-child-size/x: temp]
if face/values/min-child-size/y > face/values/max-child-size/y [temp: face/values/min-child-size/y face/values/min-child-size/y: face/values/max-child-size/y face/values/max-child-size/y: temp]
if face/values/min-child-size = face/values/max-child-size [face/values/flags: union face/values/flags [fixed]]
if flag? 'fixed [face/values/min-child-size: face/values/max-child-size: min max face/values/min-child-size face/child/size face/values/max-child-size]
face/child/offset: 0x0 ; align to top-left
resize face face/size
]
entangle: func ["Activate reactions" face1 face2][
if flag? 'fixed [face1/values/min-child-size: face1/values/max-child-size: face2/size ]
if not all [scroller/x scroller/y] [exit] ; we are not displayed yet
face1/size: face1/actors/resize face1 face1/size
;if not system/view/auto-sync? [show [face1]] ;
]
; must adjust both scrollers at the same time
resize: function [face [object!] size [pair! point2D! none!]][ ; some parts of this function are inspired by one of Anton Rolls
asy: system/view/auto-sync?
system/view/auto-sync?: no
scy: scroller/y
scx: scroller/x
y-size: to integer! system/view/metrics/misc/scroller/y * 96 / system/view/metrics/dpi ;@@ WHAT !!??, really ??
x-size: to integer! system/view/metrics/misc/scroller/x * 96 / system/view/metrics/dpi
face/child/size: min max face/values/min-child-size size face/values/max-child-size
visible-y: size/y
total-y: face/child/size/y
visible-x: size/x
total-x: face/child/size/x
; determine if scrollers are necessary to be shown
; subtract here space taken by scrollers, if necessary
if scy-visible?: total-y > visible-y [
face/child/size/y: min max face/values/min-child-size/y (size/y - x-size) face/values/max-child-size/y
total-y: face/child/size/y
if scy-visible?: total-y > visible-y [; check again
; adding a vertical scroller changes horizontal visible size
visible-x: size/x - y-size
]
]
if scx-visible?: total-x > visible-x [
face/child/size/x: min max face/values/min-child-size/x (size/x - y-size) face/values/max-child-size/x
total-x: face/child/size/x
if scx-visible?: total-x > visible-x [; check again
; adding a horizontal scroller changes vertical visible size
visible-y: size/y - x-size
]
]
; adding the horizontal scroller might make the vertical scroller necessary
if all [not scy-visible? scy-visible?: total-y > visible-y ] [
face/child/size/y: min max face/values/min-child-size/y (size/y - x-size) face/values/max-child-size/y
total-y: face/child/size/y
if scy-visible?: total-y > visible-y [; check again
; adding a vertical scroller changes horizontal visible size
visible-x: size/x - y-size
]
]
scy/max-size: 0 ;@@ workaround to avoid scroller to become disbled !
scy/max-size: to integer! total-y
scy/page-size: 0
scy/page-size: to integer! visible-y
scy/visible?: none
scy/visible?: scy-visible?
scx/max-size: 0 ;@@ workaround to avoid scroller to become disbled !
scx/max-size: to integer! total-x + 1 ;@@ + 1 only for 144 dpi but beware that /visible? is setted also by Red !
scx/page-size: 0
scx/page-size: to integer! visible-x
scx/visible?: none
scx/visible?: scx-visible?
scy/min-size: to integer! scy/page-size / 10 ; FIXME hardcoded value
scx/min-size: to integer! scx/page-size / 10
; constrain to allowed range
scy/position: to integer! min max 1 scy/position (scy/max-size - scy/page-size)
scx/position: to integer! min max 1 scx/position (scx/max-size - scx/page-size)
; scroll to keep maximum possible visibility while keeping top-left alignment
face/actors/scroll face max 1 min scy/position to integer! absolute (total-y - visible-y) 'y
face/actors/scroll face max 1 min scx/position to integer! absolute (total-x - visible-x) 'x
show face
system/view/auto-sync?: asy
size ; IMPORTANT for reactions !
]
]
]
init: [
face: self
face/actors/flag?: func [flag [word! block!]] bind face/actors/flag? face ;@@ Do I really have to do this binding ??
if (length? face/pane) <> 1 [do make error! "Scrollable panel must contain only 1 face"]
face/child: face/flags ; store flags
face/values: make face/values any [face/options []]
face/values/flags: to-block face/values/flags
;set face face/values
face/flags: face/child ; restore flags
face/child: face/pane/1
if any [not pair? face/values/min-child-size not pair? face/values/max-child-size] [do make error! "Min and max scrollable panel child sizes must be pair!"]
react/link/later :face/actors/entangle [face face/child]
]
]
] ; ctx
do
[
if any [%scrollable-panel.red = find/last/tail system/options/script "/" ; It's really me ?
system/script/args = "test"] [
;print "" ; open console for debug
system/view/VID/styles/textmin: [template: [type: 'text size: 0x0]]
win: layout compose/deep [
title "Scrollable panel" ;@@ I'd like to do : title (system/script/header/title)
below
space 0x4
textmin "Resize the window to see button being resized"
textmin "and auto-scrollers appear when necessary"
sp: scrollable-panel 350x350 magenta [
button 250x200 wrap "Tanto gentile e tanto onesta pare^/la donna mia quand'ella altrui saluta^/ch'ogne lingua deven tremando muta"
] options [min-child-size: 150x130 max-child-size: 300x250]
]
react compose [
sp/size: win/size - (win/size - sp/size)
if not system/view/auto-sync? [show win]
]
view/flags win 'resize
] ; if
] ; do
Raw
spinner-panel.red
Red [
title: "A one-row panel with a spinner used instead of a scroller"
author: @luce80
Rights: "Copyright (C) 2024 Marco Antoniazzi. All rights reserved."
License: BSL-1
file: %spinner-panel.red
gist: none
date: 18-03-2024
version: 0.9.0
history: [
0.0.0 [16-03-2024 "Started"]
0.9.0 [18-03-2024 "main aspects completed"]
]
Notes: {
This is a VID panel meant to contain a row of widgets, it behaves similar to the row of the tabs of a `tab-panel`.
If it's size is smaller then its content, a spinner (that is two arrows) will appear to let you scroll.
Since this is a `panel` you can not use a `block!` to have a default action, use `on-enter` and/or `on-click` instead.
Since this is a `panel` you can not use a `number!` to specify the size, you must use a `pair!` or a `point2D!` instead.
Since this is a `panel` you can not give focus to it, you must use e.g. `set-focus my-panel/field` instead.
See at bottom of script for a usage example.
}
]
probedo: func [code [block!] /local result][print [mold code mold/only result: reduce code] do :result]
spinner-panel.red-ctx: context [
span?: func [
"Returns a block of [min-pos max-size] bounds for all faces in pane"
pane [block!]
/part count [integer!] "Limit the number of faces"
/local origin margin face
][
origin: (100000, 100000)
margin: (0, 0)
foreach face pane [
if all [count negative? count: count - 1] [break]
origin: min origin face/offset
margin: max margin face/offset + face/size
]
reduce [origin margin - origin]
]
system/view/VID/styles/spinner-panel: [
default-actor: on-down
template: [
type: 'panel
size: 200x200
this: self
; shortcuts
bar:
arrows:
arrow-L:
arrow-R:
left-face:
in-size:
margin: none
actors: [
visible-arrows: func [face flag [logic!]] [
face/arrow-L/visible?: flag
face/arrow-R/visible?: flag
face/arrows/visible?: flag
face/arrow-L/enabled?: not head? face/left-face
if not face/arrow-L/enabled? [face/arrow-L/rate: none]
face/arrow-R/enabled?: not tail? next face/left-face
if not face/arrow-R/enabled? [face/arrow-R/rate: none]
]
find-non-visible: func [root bar dir /local pane face][
pane: head root/left-face
forall pane [
face: first pane
either dir = 'left [
if (absolute bar/offset/x) <= (face/offset/x) [return either head? pane [tail pane] [back pane]]
][
if (root/arrows/offset/x) < (face/offset/x + face/size/x + bar/offset/x) [return pane]
]
]
tail pane
]
resize: func [face size [pair! point2D!] /local visibility hid-face][;FIXME: not perfect :(
;FIXME: re-calc in-size if something is added or removed
face/bar/offset/x: min max
negate face/size/x
max (size/x - face/bar/size/x + face/margin/x - face/arrows/size/x) face/bar/offset/x
0
; keep arrows right aligned
face/arrows/offset/x: to-integer size/x - face/arrows/size/x
visible-arrows face visibility: size/x < (face/in-size/x + face/margin/x)
; keep bar left aligned
if not visibility [face/bar/offset/x: 0]
; re-enable if risizing clipped something
face/arrow-L/enabled?: not tail? find-non-visible face face/bar 'left
face/arrow-R/enabled?: not tail? find-non-visible face face/bar 'right
]
]
old-on-change*: :on-change*
on-change*: func [word old new][
old-on-change* word :old :new
switch to word! word [
size [
if old <> new [actors/resize this new]
]
]
]
]
init: [
in-size: second span? pane
left-face: pane ; store "real" pane
margin: left-face/1/offset ;FIXME: size - in-size
pane: layout/tight/only compose [
below right
panel (size) []
;FIXME: hardcoded numbers
style button: button (as-point2D 15 size/y - 2) font-size 8
on-down [face/rate: 0:0:0.2]
on-up [face/rate: none]
on-time [do-actor face none 'click]
pad (as-point2D 0 0 - size/y) ; re-put on top
panel [
origin 0x0 space 0x0
button "◀" ; <-
on-click [
left-face: actors/find-non-visible this bar 'left
bar/offset/x: negate left-face/1/offset/x
actors/visible-arrows this true
]
button "▶" ; ->
on-click [
left-face: actors/find-non-visible this bar 'right
bar/offset/x: arrows/offset/x - (left-face/1/offset/x + left-face/1/size/x)
actors/visible-arrows this true
]
]
]
bar: pane/1
; put original pane in newly created pane
bar/pane: left-face
arrows: pane/2
arrow-L: first arrows/pane
arrow-R: second arrows/pane
; hide arrows
actors/visible-arrows self false
]
]
] ; context
do
[
if any [%spinner-panel.red = find/last/tail system/options/script "/" ; It's really me ?
system/script/args = "test"] [
;
;print "" ; open console for debug
system/view/VID/styles/text: [template: [type: 'text size: 0x0]]
win: layout [
title "Spinner panel example" ;@@ I wish I could do : title (system/script/header/title)
across middle
panel-s: spinner-panel [
button "Hello World"
button "Hello "
button " World"
button "Hello World!"
button "Hi" ;20
check "checker" silver
]
]
view/flags/options win 'resize [
actors: object [
on-create: func [face][face/data: face/size] ; init value
on-focus: func [face event][face/data: face/size] ; store old size
on-resize: func [face event][face/actors/on-resizing face event] ; forward
on-resizing: func [face event /local siz][
siz: face/size - face/data ; compute size difference
face/data: face/size ; store new size
panel-s/size: panel-s/size + (siz * 1x1)
]
]
]
] ; if
] ; do
Raw
splitter.red
Red [
title: "Splitter face"
author: @luce80
Rights: "Copyright (C) 2022-2024 Marco Antoniazzi. All rights reserved."
License: BSL-1
file: %splitter.red
gist-view: https://gist.github.com/luce80/433286c66d98997aff6e69fbd6323a35#file-splitter-red
date: 16-04-2024
version: 0.7.9
history: [
0.0.0 [27-11-2022 "Started"]
0.0.1 [03-12-2022 "minimum working version"]
0.1.0 [04-12-2022 "Cursor arrows, 3D bar, reactions"]
0.7.0 [08-12-2022 "undraggable, fixed, min-size, view-resize, example"]
0.7.1 [11-12-2022 "Added but then removed options/margins"]
0.7.2 [13-12-2022 "Adjusted example faces size"]
0.7.3 [24-12-2022 "Simplified separator drawing block"]
0.7.4 [03-01-2023 "Avoid useless re-showing"]
0.7.5 [15-01-2023 "Improved window example resizing"]
0.7.6 [22-01-2023 "Added style: splitter and style: separator"]
0.7.7 [28-12-2023 "Fixed for new point2d! datatype and `draw that must be outside of init block"]
0.7.8 [05-04-2024 "Fixed cursor images using system images and removed ON-CREATE actor"]
0.7.9 [16-04-2024 "Fixed by no more overwriting ON-CREATED actor"]
]
Note: {Needs Red 0.6.4 built 09-Aug-2022 or later}
Notes: {
This is a VID style to allow two child faces to be resized by the user with a separator bar.
There can be only 2 child faces.
The separator bar width is given by the space between the two child faces.
A good (Windows default ?) width should be 7 pixels.
Orientation is provided by VID: default is `across` or use `below` to have a vertical layout
You can set some parameters by using `options` VID keyword.
The currently available parameters are:
- first-min-size: the minimum size (in pixels) that the first gadget can have.
- second-min-size: the minimum size (in pixels) that the second gadget can have.
- flags: a `block!` containing one or more of:
- separator A 3D-looking separator is drawn in the splitter.
- first-fixed When the splitter gadget is resized, the first gadget will keep its size.
- second-fixed When the splitter gadget is resized, the second gadget will keep its size.
- undraggable The splitter can not be moved to resize the gadgets.
Please do not blame me for a slow or flickering GUI rendering, and for other "hiccups".
See at bottom of script for a usage example.
}
]
probedo: func [code [block!] /local result][print [mold code mold/only result: reduce code] do :result]
use: func [words [block!] body [block!]][body: has words body body] ; FIXME: redefined ?, place in a context ?
view-resize: function [
"Displays a resizable window view from a layout block or from a window face"
spec [block! object!] "Layout block or face object with a root splitter"
/tight "Zero offset and origin"
/options
opts [block!] "Optional features in [name: value] format"
/flags
flgs [block! word!] "One or more window flags"
/with
body [block!] "Do custom code instead of resizing root splitter"
;/modal "Display a modal window (pop-up)"
/no-wait "Return immediately - do not wait"
][
if not options [opts: copy []]
append opts [
actors: object [
; FIXME I should insert instead of overwrite
on-resizing: func [face event /local siz][
siz: event/offset - face/size ; compute size difference (event/offset contains new size)
either face/pane/1/options/style = 'splitter [
face/pane/1/size: face/pane/1/size + (siz * 1x1) ; resizing the main splitter will resize all others
if not system/view/auto-sync? [show face/pane/1]
][
do body ; FIXME do also if root face is a splitter ?
]
]
]
]
view/flags/options spec 'resize opts
]
system/view/VID/styles/splitter: [
default-actor: on-down
template: [
type: 'panel
size: 200x200
; color: 255.255.255.254 ; default transparent
;flags: copy [] ; reserved by Red
face1: none ; shortcut
face2: none ; shortcut
bar: none ; shortcut
ratio: 0
axis: 1
margin: 0x0
bar-size: 0x0
first-min-size: 0
second-min-size: 0
values: object [ ; object used to extend VID params and set main control params
first-min-size: 0
second-min-size: 0
; TBD separator-size, separator-color
; TBD first-weight [percent!]
flags: copy [] ; 'separator , 'first-fixed, second-fixed, undraggable ; TBD transparent, over
]
actors: [
ON-CREATED: func [face [object!] event [event! none!]] [] ;placeholder
]
]
init: [
face: self
;probedo [ "init" face/options]
actors: make actors [
flag?: [ ; will be transformed to a function!
to logic! find values/flags flag
]
resize: func [face [object!] size [pair! point2D!] axis [integer!] /local asy total face1 face2] [
asy: system/view/auto-sync?
system/view/auto-sync?: no
total: size/(axis) - face/bar/size/(axis) - (2 * face/margin/(axis)) ; total fixed size
face1: face/face1
face2: face/face2
case [
flag? 'first-fixed []
flag? 'second-fixed [face1/size/(axis): to integer! max face/first-min-size (total - face2/size/(axis)) ]
'proportional [face1/size/(axis): to integer! max face/first-min-size min (total - face/second-min-size) max face/first-min-size (to integer! round total * face/ratio)]
]
face2/size/(axis): to integer! max face/second-min-size (total - face1/size/(axis))
face/bar/offset/(axis): to integer! face/margin/(axis) + face1/size/(axis)
face2/offset/(axis): to integer! face/bar/offset/(axis) + face/bar/size/(axis)
if flag? 'first-fixed [
face/bar/offset/(axis): to integer! max (face/first-min-size + face/margin/(axis) ) (total + face/margin/(axis) - face2/size/(axis))
face1/size/(axis): to integer! face/bar/offset/(axis) - face/margin/(axis)
]
face1/size/(3 - axis): to integer! face2/size/(3 - axis): to integer! size/(3 - axis) - (2 * face/margin/(3 - axis))
face/bar/size/(3 - axis): to integer! size/(3 - axis)
if all [face/bar/size/(axis) >= 6 flag? 'separator][
face/bar/draw: compose
[
anti-alias off
fill-pen off
pen 255.255.255.100
line (as-pair 3 face/bar/size/y - 2) 3x3 (as-pair face/bar/size/x - 2 3)
pen 0.0.0.200
line (as-pair 2 face/bar/size/y - 2) (as-pair face/bar/size/x - 2 face/bar/size/y - 2) (as-pair face/bar/size/x - 2 3)
]
]
system/view/auto-sync?: asy
;if face/parent/type = 'window [show face/parent]
size ; IMPORTANT for reactions !
]
entangle: func ["Activate reactions" face1 face2][
face1/size: face1/actors/resize face1 face1/size face1/axis
;if not system/view/auto-sync? [show [face1]] ;
]
; add custom actor but avoid overwriting existing one
old-on-created: :on-created
ON-CREATED: func [face [object!] event [event! none!]] [
face/actors/old-on-created face event
face/actors/resize face face/size face/axis
]
]
face/actors/flag?: func [flag [word! block!]] bind face/actors/flag? face ;@@ Do I really have to do this binding ??
;if (length? face/pane) <> 2 [do make error! "Splitter panel must contain only 2 faces"]
system/catalog/errors/script: make system/catalog/errors/script [
splitter-invalid: copy ["Splitter panel must contain only 2 faces"]
]
if (length? face/pane) <> 2 [cause-error 'script 'splitter-invalid ""]
if face/size/x = 0 [face/size/x: 200]
if face/size/y = 0 [face/size/y: 200]
face/ratio: face/flags ; store flags
face/values: make face/values any [face/options []]
face/values/flags: to-block face/values/flags
set face face/values
face/flags: face/ratio ; restore flags
face/options: union trim to block! face/options [style: splitter]
if all [face/actors/flag? 'first-fixed face/actors/flag? 'second-fixed][remove find face/values/flags 'second-fixed]
face/first-min-size: max 0 face/first-min-size ; only positive values
face/second-min-size: max 0 face/second-min-size
use [deltax deltay axis space total] [
deltax: absolute face/pane/2/offset/x - face/pane/1/offset/x
deltay: absolute face/pane/2/offset/y - face/pane/1/offset/y
axis: face/axis: pick [1 2] deltax > deltay
total: face/pane/1/size/(axis) + face/pane/2/size/(axis)
face/ratio: face/pane/1/size/(axis) / (total + 1e-6)
space: face/pane/2/offset - (face/pane/1/offset + face/pane/1/size)
space: pick reduce [space/1 space/2] axis ;FIXME: space: any [face/bar-size...
face/bar-size: max 0x0 as-pair space space
if (face/first-min-size + face/second-min-size) > total [
face/second-min-size: total - face/first-min-size: to integer! total / 2 ; avoid oversize
]
]
face/margin: face/pane/1/offset
append face/pane make-face/offset/spec 'base 0x0 compose [
(face/bar-size) ;
;10x10
;255.0.0.100
(any [face/color system/view/metrics/colors/panel 128.128.128])
(all [not face/actors/flag? 'undraggable 'loose])
cursor (pick [resize-we resize-ns] face/axis)
extra object [origin: 0]
with [
actors: object [
on-drag-start: func [face event] [
face/extra/origin: face/offset/(face/parent/axis)
]
on-drag: func [face event /local asy parent axis delta face1 face2] [
asy: system/view/auto-sync?
system/view/auto-sync?: no
parent: face/parent
axis: parent/axis
face/offset/(3 - axis): 0
face/offset/(axis): to integer! min max (parent/margin/(axis) + parent/first-min-size) face/offset/(axis) (parent/size/(axis) - face/size/(axis) - parent/margin/(axis) - parent/second-min-size)
delta: face/offset/(axis) - face/extra/origin
face1: parent/face1
face2: parent/face2
face1/size/(axis): to integer! max 0 face1/size/(axis) + delta
face1/offset/(axis): to integer! face/offset/(axis) - face1/size/(axis)
face2/size/(axis): to integer! max 0 face2/size/(axis) - delta
face2/offset/(axis): to integer! face/offset/(axis) + face/size/(axis)
face/extra/origin: face/offset/(axis)
show parent
system/view/auto-sync?: asy
]
on-drop: func [face event /local parent axis] [
parent: face/parent
axis: parent/axis
parent/ratio: (parent/face1/size/(axis)) / (parent/face1/size/(axis) + parent/face2/size/(axis) + 1e-6)
]
]
]
]
face/pane/3/options: trim union to block! face/pane/3/options [style: separator]
face/pane/1/parent: face
face/pane/2/parent: face
face/pane/3/parent: face
face/face1: face/pane/1
face/face2: face/pane/2
face/bar: face/pane/3
;face/color: green ; to see if resizing is right
react/link/later :face/actors/entangle [face face/bar]
]
]
do
[
if any [%splitter.red = find/last/tail system/options/script "/" ; It's really me ?
system/script/args = "test"] [
;print "" ; open console for debug
system/view/auto-sync?: no ; speed up resizing a bit
system/view/VID/styles/text: [template: [type: 'text size: 0x0]]
win: layout [
title "Splitter face examples" ;@@ I wish I could do : title (system/script/header/title)
below
h5 "Try to drag the separators (if you can find them ;) ) and resize the window"
across
radio "Simple" on
radio "More" [move p/pane next p/pane show p]
return
p: panel red [
origin 0x0
tspl1: splitter 600x400 [
;origin 0x0
space 6x6
below
splitter [
origin 0x0 space 6x6
below
splitter [
origin 0x0 space 6x6
base 287 sky "face 1^/with proportional width"
base 287 gray "face 2^/with proportional width"
]
splitter [
origin 0x0 space 6x6
base 287 sky "face 1^/with fixed width"
base 287 gray "face 2^/with resizing width"
] options [flags: [first-fixed] ]
]
splitter [
origin 0x0 space 6x6
base 287 sky "face 1^/with resizing width"
base 287 gray "face 2^/with fixed width"
] options [flags: [second-fixed] ]
] ;options [flags: [enlarged]] ; TBD ?
origin 0x0
tspl2: splitter yellow 600x400 [
;origin 0x0
space 7x7
below
splitter [
origin 0x0 space 6x6 across middle
button "button 1"
splitter [
origin 0x0 space 6x6 across middle
button "button 2"
splitter [
origin 0x0 space 6x6 across middle
button "button 3"
button "button 4"
]
]
] options [flags: [ undraggable]]
splitter [
origin 0x0 space 7x7
base sky "min-size: 100"
splitter [
origin 0x0 space 7x7
area {Please do not blame me for a slow or flickering GUI rendering, and for other "hiccups".} wrap
base "min-size: 50"
] options [second-min-size: 50 flags: [second-fixed separator] ]
] options [first-min-size: 100 flags: [first-fixed separator] ]
] options [flags: [first-fixed separator] ]
] ; p
]
move p/pane next p/pane ; swap main panels
view/flags/options win 'resize [
actors: object [
on-create: func [face][face/data: face/size] ; init value
on-focus: func [face event][face/data: face/size] ; store old size
on-resize: func [face event /local siz][
siz: face/size - face/data ; compute size difference
face/data: face/size ; store new size
tspl1/size: tspl2/size: p/size: p/size + (siz * 1x1)
if not system/view/auto-sync? [show win]
]
]
]
] ; if
] ; do
Raw
tipped-button.red
Red [
title: "Tipped button"
author: @luce80
Rights: "Copyright (C) 2024 Marco Antoniazzi. All rights reserved."
License: BSL-1
file: %tipped-button.red
gist-view: none
date: 16-04-2024
version: 0.8.1
history: [
0.0.0 [13-04-2024 "Started"]
0.8.0 [14-04-2024 "Main aspects completed"]
0.8.1 [16-04-2024 "Now using UNDOCUMENTED hint keyword"]
]
Note: {Needs Red 0.6.4 built 09-Aug-2022 or later}
Notes: {
This is a VID style to show a little help text near or over a button.
You can set the text (string!) by using `hint` VID keyword.
The currently (un)available parameters are:
- flags: a `block!` containing one or more of:
- over-face TBD
See at bottom of script for a usage example.
}
TBD: {
Use one global tool-tip face.
Add flag over-face to position tool-tip relative to face
}
]
probedo: func [code [block!] /local result][print [mold code mold/only result: reduce code] do :result]
system-view-tipped-button-ctx: context [
use: func [words [block!] body [block!]][body: has words body body]
inside?-face: func [
"TRUE if point is inside face"
point [pair! point2D!]
face [object!]
][
to logic! all [
point/x >= face/offset/x
point/y >= face/offset/y
point/x < (face/offset/x + face/size/x)
point/y < (face/offset/y + face/size/y)
]
]
find-window: function [
"Find a face's window face."
face [object!]
][
p: face/parent
while [p/type <> 'window][p: p/parent]
p
]
face-offset: function [ ; FIXME merge this func and find-window into one func
"Return a face's offset relative to its window."
face [object!]
/screen "Offset relative to screen"
;/with face2 [object!] ; TBD
][
offset: any [face/offset 0x0]
p: face/parent
while [p/type <> 'window][offset: offset + p/offset p: p/parent ]
max 0x0 either screen [offset + p/offset][offset]
]
system/view/VID/styles/tool-tip: [
template: [
type: 'text
size: 0x0
color: yello + 30
]
]
system/view/VID/styles/tipped-button: [
default-actor: on-click
template: [
type: 'button
size: 60x23 ;@@ ?!
flags: [all-over focusable]
hint: ""
tip: none
mouse-offset: none
values: object [ ; object used to extend VID params and set main control params
flags: copy [] ; TBD 'over-face
]
actors: [
ticks: 0
none none ;@@ workaround for #5488
start_tip: func [face tip] [
if ticks <> 0 [exit]
if not string? face/hint [exit]
face/rate: 0:0:0.5
tip/visible?: false ; hide it
]
open_tip: func [face tip mouse-offset /local win-size] [
tip/offset: mouse-offset + 1x15
win-size: get in find-window face 'size
; keep inside window and away from mouse cursor
tip/offset: min max (0, 0) tip/offset win-size - tip/size
if inside?-face mouse-offset tip [
tip/offset: mouse-offset - tip/size/y + 1x-1
tip/offset: min max (0, 0) tip/offset win-size - tip/size
]
; put on top
move find tip/parent/pane tip tail tip/parent/pane
tip/visible?: true
show tip/parent ; use parent to show it "properly" (!?)
]
close_tip: func [face tip] [
;if tip/size = 100x100 [exit] ; entering here before start_tip
tip/visible?: false ; hide it
ticks: 0
face/rate: none
show tip
]
ON-CREATE: function [face [object!]][
w: find-window face
face/tip/parent: w
; put on top
append w/pane face/tip
]
ON-OVER: func [face [object!] event [event! none!]][
face/mouse-offset: event/offset
either any [event/away? face/tip/visible?] [
close_tip face face/tip
][
start_tip face face/tip
]
]
ON-TIME: func [face [object!] event [event! none!]][
if ticks = 1 [open_tip face face/tip face/mouse-offset + (face-offset face )]
if ticks = 6 [close_tip face face/tip]
ticks: ticks + 1
]
old-on-click: none ;@@ placeholder
none none ;@@ workaround for #5488
ON-CLICK: func [face [object!] event [event! none!]] [
; placeholder
]
]
]
init: [
use [old-flags][
old-flags: flags ; store flags
values: make values any [options []]
values/flags: to-block values/flags
set self values
flags: old-flags ; restore flags
]
tip: make-face/spec 'tool-tip compose [(hint) middle center hidden]
tip/size: tip/size + 6x6
; tip: make-face/spec 'text compose [(help) (yello + 30) middle center hidden]
; add custom actor but avoid overwriting existing one
actors: make actors [
old-on-click: :on-click
ON-CLICK: func [face [object!] event [event! none!]] [
face/actors/close_tip face face/tip
face/actors/old-on-click face event
]
]
]
]
]; context
do
[
if any [%tipped-button.red = find/last/tail system/options/script "/" ; It's really me ?
system/script/args = "test"] [
;prin "" ; open console for debug
win: layout [
title "Tipped button face examples" ;@@ I wish I could do : title (system/script/header/title)
size 200x100
below
tipped-button "place mouse over me" [t1/text: "CLICK"] hint "first help"
tipped-button "or over me" [t1/text: "CROCK"] hint "second help"
t1: text ""
]
view win
] ; if
] ; do
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment