luce80 · February 25, 2024 16:59
diff --git a/action-requesters.red b/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