VID anchors for GUI resizing

stretchy.red

Red [
	title: "VID anchors for GUI resizing"
	author: [@hiiamboris @luce80]
	file: %stretchy.red
	gist-view: https://gist.github.com/luce80/a5bb54f128934140e36c7a1073958455
	date: 17-01-2023
	version: 1.1.2
	History: [
		0.0.0 [01-01-2023 "Started"]
		0.0.1 [02-01-2023 "Minimum working version"]
		1.0.0 [03-01-2023 "Cleaned up"]
		1.0.1 [03-01-2023 "Refactored #resize block check"]
		1.1.0 [04-01-2023 "Added `stretchy-update`"]
		1.1.1 [06-01-2023 "Improved `stretchy-update`"]
		1.1.2 [17-01-2023 "Replaced block! with pair! for params"]
	]
	licence: 'PD
	Note: {Needs Red 0.6.4 built 26-Nov-2022 or later}	
	usage:   {
		#include %stretchy.red
		view/flags stretchy [
			VID face declaration #anchor
			panel #anchor [
				more faces with #anchors or without them
			]
		] 'resize
		
		/no-min  => Defined positions and sizes are not the minimums.

		Supported anchors are:
		- #move-x  follow window vertical borders.
		- #move-y  follow window horizontal borders.
		- #move-xy  follow window vertical and horizontal borders.
		- #resize-x  size is scaled to follow window vertical borders.
		- #resize-y  size is scaled to follow window horizontal borders.
		- #resize-xy  size is scaled to follow window vertical and horizontal borders.
		- #resize <pair> position and size will change according to percentages given in block.
		- #move or #resize <pair> position or size will change according to percentages given in pair.
			<pair> : a pair!
			The numbers indicate percentages, but expressed as integers, of movement or
			scaling relative to window changed dimensions.
			examples:
			  #move 0x0 #resize 0x0 : no movement and no scaling, the face will stay fixed where it was.
			  #move 100x0 : same as #move-x.
			  #resize 0x100 : same as #resize-y.
			  #resize 50x0 : scale width adding (or removing) 50% of added (or removed) window's size.
			  
		IMPORTANT: If you "manually" , using 'loose or other way , change a face's offset or size, then use
		the function `stretchy-update` to update the reacting code.
		STRETCHY-UPDATE face facet
			face [object!] "The face that has changed"
			facet [word!] "'offset or 'size"

		See at bottom of script for a usage example.
	}
	Notes: {
		This is the Red version of a similar Rebol2 script I did in 2013 but using reactions.
		
		Some parts taken from @hiiamboris elasticity and only slightly modified.
		TODO: it would be nice to have some widgets being "attached" to their neighbours to keep their
			relative distances so not to have to explicitly set #move- when not necessary
			
		Beware that some style sizes depend also on screen's dpi.

		See at bottom of script for a usage example.
	}
]

system-view-VID-stretchy-ctx: context [
	probedo: func [code [block!] /local result][print [mold code  mold/only result: reduce code] do :result]
	anchors*: [move-x move-y move-xy resize-x resize-y resize-xy]
	anchors**: [move resize]
	styles: none
	groups: none
	emit-path: func [
		paths
		a
		b
		n
		][
		append/only paths a
		append/only paths b
		append/only paths append to path! 'pane n
	]

	; function copied from elastic by @hiiamboris with minor modifications
	prep-stretchy: func [												;-- recursive: enters panel
		"Preprocess layout block containing anchors accumulating paths"
		layout [block!]
		paths [block!]
		/local w a b with style n path
		][
		n: 0 ; == reset counter

		parse layout [
			any [
				'style set w set-word! (put styles to word! w yes)			;-- a new style declared - consider it too
			|	'with set with block!										;-- use provided `with` block instead of overriding it
			|	['data | 'extra] opt 'object skip							;-- skip data blocks and words
			|	set w word! if (styles/:w)									;-- found a new widget
				(
					n: n + 1     ; == increment counter
					style: w 
					with: none 
				)							;-- reset the style and accumulators
			|	remove [set a issue! if (attempt [find anchors* a: to word! a])]	;-- acceptable anchor found; attempt defends against #608-like issues
				(emit-path paths a [] n)
			|	remove [set a issue! if (attempt [find anchors** a: to word! a]) set p pair!]	;-- acceptable anchor found; attempt defends against #608-like issues
				(emit-path paths a p n)
			|	if (find groups style) set b block!
				(
					emit-path paths a: copy [] [] n
					prep-stretchy b a				;-- recursively process panels
				)
			|	skip
			]
			;end
		]
		layout															;-- chain the result into view or whatever
	]

	; templates for reaction rules
	reacts: [
		;move [	_/offset: max (_/offset) _/parent/size - (_/parent/size) * 100x100 / 100x100 + (_/offset) ]; #move
		move-x 		[offset: max (offset) parent/size - (parent/size) * 100x0 / 100x100 + (offset) ]; #move-x
		move-y		[offset: max (offset) parent/size - (parent/size) * 0x100 / 100x100 + (offset) ]; #move-y
		move-xy		[offset: max (offset) parent/size - (parent/size) * 100x100 / 100x100 + (offset) ]; #move-xy
		move		[offset: max (offset) parent/size - (parent/size) * 100x100 / 100x100 + (offset) ]; #move
		resize-x	[size:   max (size)   parent/size - (parent/size) * 100x0 / 100x100 + (size)]
		resize-y	[size:   max (size)   parent/size - (parent/size) * 0x100 / 100x100 + (size)]
		resize-xy	[size:   max (size)   parent/size - (parent/size) * 100x100 / 100x100 + (size)]
		resize		[size:   max (size)   parent/size - (parent/size) * 100x100 / 100x100 + (size)]
	]

	rules: none
	
	emit-rule: func [
		word [word!]
		path [path!]
		pair [pair! block!]
		/local rule
		][
		rule: copy/deep any [reacts/(word) []]
		; ?? rule
		rule/1: rule/3/1: rule/12/1: append copy path rule/3/1
		rule/4: rule/6/1: append copy path rule/4
		rule/1: to set-path! rule/1
		if pair? pair [rule/8: pair]
		if no-min* [remove/part at rule 2 2]
		; collect rules and prettify block inserting newlines
		append rules '<
		append rules rule
		append rules '>
		new-line find/last/tail rules '< true
		new-line find/last rules '> true
	]
	emit-reactions: func [
		paths [block!]
		root [word! path!]
		/local word pair path rule
		][
		
		foreach [word pair path] paths [
			path: to path! append to block! root to block! path
			either block? word [
				emit-reactions word path   ; recurse
			][
				emit-rule  word path pair
			]
		]
		remove-each item rules [any [item = '< item = '>]]  ; clear temporary markers
		head rules
	]
	
	path-face: function [
		"Returns a face's path"
		face [object!]
		root [word!] "The face's window id"
		][
		block: copy []
		p: face
		while [p/type <> 'window][
			p: p/parent
			insert insert block 'pane index? find/same p/pane face
			face: p
		]
		insert block root
		to path! head block
	]
	set 'stretchy-get func [
		"Retrieve a face's stretchy rule."
		face [object!] "The face that has changed"
		facet [word!] "'offset or 'size"
		][
		if not find [offset size] facet [return none] ; FIXME: better rise an error! ?
		; FIXME: support multiple windows (with different rules)
		find/only rules  to set-path! append path-face face 'win facet
	]
	set 'stretchy-update func [
		"Update stretchy reactions when a face's offset or size change."
		face [object!] "The face that has changed"
		facet [word!] "'offset or 'size"
		;/keep "Keep current minimums"
		/with x [integer! none!] y [integer! none!] "New percentages pair"
		/local rule a b p c no-min
		][
		if not find [offset size] facet [exit] ; FIXME: better rise an error! ?
		; FIXME: support multiple windows (with different rules)
		no-min: not to logic! find rules 'max
		rule: stretchy-get face facet
		if none? rule [exit]
		set [a b p c] either no-min [[0 4 6 10]][[3 6 8 12]]
		if not any [no-min ] [rule/(a): min rule/(a) get in face facet]
		rule/(b): face/parent/size
		if x [rule/(p)/1: x]
		if y [rule/(p)/2: y]
		rule/(c): get in face facet
	]

	no-min*: false
	win: none
	; function derived from elastic by @hiiamboris with minor modifications
	; main function
	set 'stretchy func [
		"Manage VID anchors to provide GUI resizing"
		lay [block!] "VID block"
		/no-min "Defined positions and sizes are not the minimums."
		/no-react "Do not create reactions"
		;TBD /react "Re apply reactions"
		;TBD /stop "Stop reactions"
		/local items
		][
		rules: copy []
		no-min*: no-min
		styles: copy system/view/VID/styles
		groups: collect [
			foreach [name spec] styles [
				if spec/template/type = 'panel [keep to word! name]
			]
		]
		lay: prep-stretchy lay items: copy []
		; ?? items
		win: layout lay
		; populate rules with reaction relations
		emit-reactions items 'win
		append rules [if not system/view/auto-sync? [show win]]
		rules: compose rules
		unless no-react [
		react/later compose/only [ 
			win/size ;@@ main reacting facet !
			do (rules)
		]
		]
		no-min*: false ; restore

		win
	]
] ; system-view-VID-stretchy-ctx

do
[
if any [%stretchy.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]] ; nicer default text
	
	win: compose [
		title "Stretchy example"
		space 4x4
		across
			field (400 - 30 - 4 - 2) #resize-x
			button 30 "+" #move-x
		return
			text-list 400x100 #resize-xy data ["Try to resize the window"]
		return
			middle
			field 160 #move 0x100 #resize 50x0
			textmin "Filter:" #move 50x100
			drop-list 110 #move 50x100 data ["All files (*.*)" "Red files (*.red)"] with [selected: 2]
			field #move 50x100 #resize 50x0
		return
			pad (as-pair 400 - 250 - 12 - 2 / 2 0)
			panel #move 25x100 #resize 50x0 gray [
				origin 4x4 space 4x4
				button 125 "left" #move 0x100 #resize 50x0 ; follow y and stretch half width of parent
				button 125 "right" #move 50x100 #resize 50x0
			]
		return
			check "Show hidden files" #move-y
			pad (as-pair 77 0)
			button 150 "Drag me" loose #move-y #resize 75x0
				on-drop [stretchy-update face 'offset] ; necessary to update reactions
			button 50 "Cancel" #move 75x100 #resize 25x0 [unview]
	 ]
	view/flags stretchy win 'resize
	;if system/script/args <> "test" [quit] ; close console qindow
] ; if
] ; do