luce80/action-requesters.red

## action-requesters.red
Red [
	title: "Action requesters"
	author: [@luce80]
	file: %action-requesters.red
	gist-view: https://gist.github.com/luce80/89be16a8d0a3031b41cc49795e6e20b4#file-action-requesters-red
	date: 25-02-2024
	version: 0.7.4
	History: [
		0.0.0 [23-12-2022 "Started"]
		0.7.0 [28-12-2022 "Ok"]
		0.7.1 [31-12-2022 "Fixed /center"]
		0.7.2 [19-03-2023 "Rescaled icons down to 36x36 pixels"]
		0.7.3 [18-01-2024 "Changed title of confirm requester"]
		0.7.4 [25-02-2024 "Added a bit of margin around text"]
	]
	licence: 'PD
	Note: {Needs Red 0.6.4 built 26-Nov-2022 or later}
	Notes: {
		Here are a few functions modeled on those of Rebol2 to open a requester to show a message to the user and possibly let the user make a choice.

		Some parts inspired by @greggirwin requesters.
		These requesters are meant for relativly short messages, better not abuse them.
		WARNING: see workaround for `flash` messages in example below.
		See at bottom of script for usage examples.
	}
]

system-view-action-requesters-ctx: context [
	size-text-face: make-face/size/spec 'rich-text system/view/screens/1/size - 200x200 [wrap font []] ;@@ IMHO this face! should be somewhere inside view object!
	req-red: 180.35.55
	req-yellow: 240.170.0
	req-blue: 0.50.160
	req-green: 35.130.80
	font-25: make font! [style: 'bold size: 25 name: system/view/fonts/serif]
	icons: [
		question: [translate 24x24
			pen off fill-pen radial -10x-10 0 48 55.200.0 req-green  circle 0x0 24
			font font-25 pen white text -8x-20 "?"  ]
		stop: [translate 24x24
			pen off fill-pen radial -10x-10 0 48 230.10.10 req-red
			polygon -24x10 -24x-10 -10x-24 10x-24 24x-10 24x10 10x24 -10x24 ; octagon
			pen white line-width 5 rotate 45 line -16x0 16x0 rotate 90 line -16x0 16x0 ]
		deny: [translate 24x24
			pen req-red line-width 2 fill-pen radial -10x-10 0 48 230.10.10 req-red  circle 0x0 23
			pen white line-width 7 line -16x0 16x0 ]
		prohibit: [translate 24x24
			pen req-red line-width 6 fill-pen white circle 0x0 21
			line-width 5 rotate 45 line -20x0 20x0 ]
		required: [translate 24x24
			pen off fill-pen radial -10x-10 0 58 0.55.200 req-blue circle 0x0 24
			font font-25 pen white text -6x-20 "!" ]
		help: [translate 24x24
			pen off fill-pen radial -10x-10 0 58 0.55.200 req-blue circle 0x0 24
			font font-25 pen white text -8x-20 "?"  ]
		info: [translate 24x24
			pen off fill-pen radial -10x-10 0 58 0.55.200 req-blue  box -24x-24 24x24 8
			font font-25 pen white text -5x-20 "i" ]
		alert: [translate 24x24 ; warning
			pen req-yellow line-width 4 line-join round
			fill-pen radial -10x-10 0 58 240.230.0 req-yellow  triangle 0x-21 -22x21 22x21
			font font-25 pen black text -6x-15 "!" ]
	]
	cycle: func [
		"Cycles through a series"
		series [series! port!]
		/back   ; redefined
		][
		either back [
			system/words/back either head? series [tail series] [series]
		][
			either tail? next series [head series] [next series]
		]
	]
	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]
	]
	; TBD center-face using face-offset
	set 'request function [
		"Displays a message or requests a choice."
		msg [string! block! none!] "Message to display or block with texts"
		/type icon [word!] "One of: question (default), info, required, help, alert, deny, prohibit, stop"
		/only "No buttons"
		/ok "Only ok button"
		/confirm "Only ok and cancel buttons"
		/title string [string!]
		/offset xy [pair!]
		/new "Returns immediately giving window face object as result"
		/center face [object!] "Center over this face"
		/no-modal "Normal non-modal window"
		/timeout timer [number! time!] "Number of seconds or period of time to wait"
	][
		result: none
		text-ok: "OK" text-no: "No" text-bo: "Cancel"
		if block? msg [
			msg: reduce msg
			set/some [msg text-ok text-no text-bo] msg
		]
		msg: any [msg "What is your choice?"]
		text-size: 4x4 + size-text also size-text-face size-text-face/text: msg
		type: any [icon (select [#"." info #"?" help #"!" alert] last msg) 'question]
		title: any [string uppercase/part form type 1]

		win: layout compose/deep [
			title (title)
			space 0x0
			below
			center ;@@ could/should be inside system/view/VID/GUI-rules
			panel [
				across middle
				base 36x36 glass draw [scale .75 .75 (any [icons/(type) icons/question])]
				rich-text glass text-size msg wrap
			]
			panel (either only [0x0][[]]) [
				(either only [[]] [compose [
				b-ok:     button (text-ok) [result: yes  unview] focus
				(either ok [[]] [compose [
				b-no:     button (text-no) [result: no   unview]
				(either confirm [[]] [compose [
				b-cancel: button (text-bo) [result: none unview]
				]])
				]])
				]])
			]
		]
		faces: trim reduce [b-ok b-no b-cancel]
		;if object? b-ok [set-focus b-ok] ; FIXME bug workaround ; bug was fixed
		if xy [win/offset: xy]
		if center [win/offset: (face-offset/screen face) - (win/size - face/size / 2)]
		win/rate: either timer [to time! timer] [8760:0:0] ; is an year enough ?

		flags: compose [
			no-min no-max
			(either no-modal [[]]['modal])
		]
		opts: [
			actors: object [
				on-time: func [face event] [rate: none unview]
				on-key: func [face event] [
					if event/key = #"^(esc)" [unview]
					faces: switch/default event/key [
						right [cycle faces]
						left  [cycle/back faces]
						#"^(tab)" [either event/shift? [cycle/back faces][cycle faces]]
						#"^O" [if object? b-ok [result: yes unview]]
						#"^N" [if object? b-no [result: no unview]]
						#"^C" [if object? b-cancel [result: none unview]]
					] [faces]
					unless empty? faces [set-focus first faces]
				]
			]
		]
		;either new [view/no-wait/flags/options win flags opts] [view/flags/options win flags opts]
		;no-wait: new view/:no-wait/flags/options win flags opts
		;apply 'view/:no-wait/:flags/:options [win new yes flags yes opts]
		apply 'view [win /no-wait new /flags yes flags /options yes opts]
		either new [win][result]
	]
	set 'alert func [
		"Flashes an alert message to the user. Waits for a user response."
		msg [string! block! none!] "Message to display or block with texts"
		][
		request/ok/type msg 'alert
	]
	set 'confirm func [
		"Confirms a user choice."
		question [series!] "Prompt to user"
		/with choices [string! block!]
		][
		question: form question
		request/confirm/title append copy [question] any [choices []] "Please confirm"
	]
	set 'flash func [
		"Flashes a message to the user and continues."
		msg [string! block! none!] "Message to display or block with texts"
		/with face "Center over this face"
		/offset xy
		][
		case [
			offset [request/new/only/title/offset msg "Information" xy]
			with   [request/new/only/title/center msg "Information" face]
			'else  [request/new/only/title msg "Information"]
		]
	]
	set 'notify func [
		"Flashes an informational message to the user. Waits for a user response."
		msg [string! block! none!] "Message to display or block with texts"
		][
		request/ok/type msg 'info
	]

] ; system-view-action-requesters-ctx

do
[
if any [%action-requesters.red = find/last/tail system/options/script "/" ; It's really me ?
        system/script/args = "test"] [

	prin "" ; open console for debug

	probe request/timeout none 1
	probe request/only "Press <Esc> to close this window!"
	probe request/only "Press <Esc> again to close also this window."
	probe request/ok "Hello World."
	probe request/ok "And now?"
	probe request/confirm/type "Is it a good World?" 'question
	probe request/type ["This is a panic situation !" "Stop" "Try" "Forget"] 'stop
	probe alert "You should not have done that !"
	probe confirm "Yes or No ?"
	probe confirm/with "Use A or B ?" ["A" "B"]
	flash "Reading site..."
	read http://www.rebol.com
	do-events/no-wait ;@@ workaround to avoid hanging or premature closing
	unview
	f1: flash "Calculating..."
	wait 1
	do-events/no-wait ;@@ workaround to avoid hanging or premature closing
	unview/only f1
	notify "Job done"
	;alert "Remember to close the console window !"
	if system/script/args <> "test" [quit] ; close console window
] ; if
] ; do
	Red [
	title: "Action requesters"
	author: [@luce80]
	file: %action-requesters.red
	gist-view: https://gist.github.com/luce80/89be16a8d0a3031b41cc49795e6e20b4#file-action-requesters-red
	date: 25-02-2024
	version: 0.7.4
	History: [
	0.0.0 [23-12-2022 "Started"]
	0.7.0 [28-12-2022 "Ok"]
	0.7.1 [31-12-2022 "Fixed /center"]
	0.7.2 [19-03-2023 "Rescaled icons down to 36x36 pixels"]
	0.7.3 [18-01-2024 "Changed title of confirm requester"]
	0.7.4 [25-02-2024 "Added a bit of margin around text"]
	]
	licence: 'PD
	Note: {Needs Red 0.6.4 built 26-Nov-2022 or later}
	Notes: {
	Here are a few functions modeled on those of Rebol2 to open a requester to show a message to the user and possibly let the user make a choice.

	Some parts inspired by @greggirwin requesters.
	These requesters are meant for relativly short messages, better not abuse them.
	WARNING: see workaround for `flash` messages in example below.
	See at bottom of script for usage examples.
	}
	]

	system-view-action-requesters-ctx: context [
	size-text-face: make-face/size/spec 'rich-text system/view/screens/1/size - 200x200 [wrap font []] ;@@ IMHO this face! should be somewhere inside view object!
	req-red: 180.35.55
	req-yellow: 240.170.0
	req-blue: 0.50.160
	req-green: 35.130.80
	font-25: make font! [style: 'bold size: 25 name: system/view/fonts/serif]
	icons: [
	question: [translate 24x24
	pen off fill-pen radial -10x-10 0 48 55.200.0 req-green circle 0x0 24
	font font-25 pen white text -8x-20 "?" ]
	stop: [translate 24x24
	pen off fill-pen radial -10x-10 0 48 230.10.10 req-red
	polygon -24x10 -24x-10 -10x-24 10x-24 24x-10 24x10 10x24 -10x24 ; octagon
	pen white line-width 5 rotate 45 line -16x0 16x0 rotate 90 line -16x0 16x0 ]
	deny: [translate 24x24
	pen req-red line-width 2 fill-pen radial -10x-10 0 48 230.10.10 req-red circle 0x0 23
	pen white line-width 7 line -16x0 16x0 ]
	prohibit: [translate 24x24
	pen req-red line-width 6 fill-pen white circle 0x0 21
	line-width 5 rotate 45 line -20x0 20x0 ]
	required: [translate 24x24
	pen off fill-pen radial -10x-10 0 58 0.55.200 req-blue circle 0x0 24
	font font-25 pen white text -6x-20 "!" ]
	help: [translate 24x24
	pen off fill-pen radial -10x-10 0 58 0.55.200 req-blue circle 0x0 24
	font font-25 pen white text -8x-20 "?" ]
	info: [translate 24x24
	pen off fill-pen radial -10x-10 0 58 0.55.200 req-blue box -24x-24 24x24 8
	font font-25 pen white text -5x-20 "i" ]
	alert: [translate 24x24 ; warning
	pen req-yellow line-width 4 line-join round
	fill-pen radial -10x-10 0 58 240.230.0 req-yellow triangle 0x-21 -22x21 22x21
	font font-25 pen black text -6x-15 "!" ]
	]
	cycle: func [
	"Cycles through a series"
	series [series! port!]
	/back ; redefined
	][
	either back [
	system/words/back either head? series [tail series] [series]
	][
	either tail? next series [head series] [next series]
	]
	]
	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]
	]
	; TBD center-face using face-offset
	set 'request function [
	"Displays a message or requests a choice."
	msg [string! block! none!] "Message to display or block with texts"
	/type icon [word!] "One of: question (default), info, required, help, alert, deny, prohibit, stop"
	/only "No buttons"
	/ok "Only ok button"
	/confirm "Only ok and cancel buttons"
	/title string [string!]
	/offset xy [pair!]
	/new "Returns immediately giving window face object as result"
	/center face [object!] "Center over this face"
	/no-modal "Normal non-modal window"
	/timeout timer [number! time!] "Number of seconds or period of time to wait"
	][
	result: none
	text-ok: "OK" text-no: "No" text-bo: "Cancel"
	if block? msg [
	msg: reduce msg
	set/some [msg text-ok text-no text-bo] msg
	]
	msg: any [msg "What is your choice?"]
	text-size: 4x4 + size-text also size-text-face size-text-face/text: msg
	type: any [icon (select [#"." info #"?" help #"!" alert] last msg) 'question]
	title: any [string uppercase/part form type 1]

	win: layout compose/deep [
	title (title)
	space 0x0
	below
	center ;@@ could/should be inside system/view/VID/GUI-rules
	panel [
	across middle
	base 36x36 glass draw [scale .75 .75 (any [icons/(type) icons/question])]
	rich-text glass text-size msg wrap
	]
	panel (either only [0x0][[]]) [
	(either only [[]] [compose [
	b-ok: button (text-ok) [result: yes unview] focus
	(either ok [[]] [compose [
	b-no: button (text-no) [result: no unview]
	(either confirm [[]] [compose [
	b-cancel: button (text-bo) [result: none unview]
	]])
	]])
	]])
	]
	]
	faces: trim reduce [b-ok b-no b-cancel]
	;if object? b-ok [set-focus b-ok] ; FIXME bug workaround ; bug was fixed
	if xy [win/offset: xy]
	if center [win/offset: (face-offset/screen face) - (win/size - face/size / 2)]
	win/rate: either timer [to time! timer] [8760:0:0] ; is an year enough ?

	flags: compose [
	no-min no-max
	(either no-modal [[]]['modal])
	]
	opts: [
	actors: object [
	on-time: func [face event] [rate: none unview]
	on-key: func [face event] [
	if event/key = #"^(esc)" [unview]
	faces: switch/default event/key [
	right [cycle faces]
	left [cycle/back faces]
	#"^(tab)" [either event/shift? [cycle/back faces][cycle faces]]
	#"^O" [if object? b-ok [result: yes unview]]
	#"^N" [if object? b-no [result: no unview]]
	#"^C" [if object? b-cancel [result: none unview]]
	] [faces]
	unless empty? faces [set-focus first faces]
	]
	]
	]
	;either new [view/no-wait/flags/options win flags opts] [view/flags/options win flags opts]
	;no-wait: new view/:no-wait/flags/options win flags opts
	;apply 'view/:no-wait/:flags/:options [win new yes flags yes opts]
	apply 'view [win /no-wait new /flags yes flags /options yes opts]
	either new [win][result]
	]
	set 'alert func [
	"Flashes an alert message to the user. Waits for a user response."
	msg [string! block! none!] "Message to display or block with texts"
	][
	request/ok/type msg 'alert
	]
	set 'confirm func [
	"Confirms a user choice."
	question [series!] "Prompt to user"
	/with choices [string! block!]
	][
	question: form question
	request/confirm/title append copy [question] any [choices []] "Please confirm"
	]
	set 'flash func [
	"Flashes a message to the user and continues."
	msg [string! block! none!] "Message to display or block with texts"
	/with face "Center over this face"
	/offset xy
	][
	case [
	offset [request/new/only/title/offset msg "Information" xy]
	with [request/new/only/title/center msg "Information" face]
	'else [request/new/only/title msg "Information"]
	]
	]
	set 'notify func [
	"Flashes an informational message to the user. Waits for a user response."
	msg [string! block! none!] "Message to display or block with texts"
	][
	request/ok/type msg 'info
	]

	] ; system-view-action-requesters-ctx

	do
	[
	if any [%action-requesters.red = find/last/tail system/options/script "/" ; It's really me ?
	system/script/args = "test"] [

	prin "" ; open console for debug

	probe request/timeout none 1
	probe request/only "Press <Esc> to close this window!"
	probe request/only "Press <Esc> again to close also this window."
	probe request/ok "Hello World."
	probe request/ok "And now?"
	probe request/confirm/type "Is it a good World?" 'question
	probe request/type ["This is a panic situation !" "Stop" "Try" "Forget"] 'stop
	probe alert "You should not have done that !"
	probe confirm "Yes or No ?"
	probe confirm/with "Use A or B ?" ["A" "B"]
	flash "Reading site..."
	read http://www.rebol.com
	do-events/no-wait ;@@ workaround to avoid hanging or premature closing
	unview
	f1: flash "Calculating..."
	wait 1
	do-events/no-wait ;@@ workaround to avoid hanging or premature closing
	unview/only f1
	notify "Job done"
	;alert "Remember to close the console window !"
	if system/script/args <> "test" [quit] ; close console window
	] ; if
	] ; do