rebol [
Title: "resize-vid.r"
Author: "Romano Paolo Tenca"
Date: 31/03/2004
Version: 0.1.8.5
Beta: true
Copyright: {
   resize-vid.r (C) 2002-2003 Romano Paolo Tenca

    This software is provided 'as-is', without any express or implied
    warranty.  In no event will the author be held liable for any damages
    arising from the use of this software.

    Permission is granted to anyone to use this software for any purpose,
    including commercial applications, and to alter it and redistribute it
    freely, subject to the following restrictions:

    1. This notice may not be removed or altered.
    2. The origin of this software must not be misrepresented; you must not
    claim that you wrote the original software. If you use this software
    in a product, an acknowledgment in the product documentation would be
    appreciated but is not required.
    3. Altered source versions must be plainly marked as such, and must not be
    misrepresented as being the original software.
}
History: [
	31/03/2004 0.1.8.5 "fixed global auto-resize, new context resize-vid-ctx"
	14/01/03 0.1.8.4 "corretected slider and scroller style code for flags"
	19/11/02 0.1.8.3 "cosmetic changes, added and removed resize-font, changed the view dialect from sizex -> size x..., added map = [] to group for proportional map "
	0.1.8.1 "use flag value instead of resize-data field, changed anchor-# to the end corner re added resize-of, added reset of anchor face"
	0.1.8 "rimosso anchor-group"
	0.1.6 "cambiato significato valore size con o senza /nosize, aggiunto anchor-to anchor-group, rimosso anchor e non piu' flag resize-alone on anchor-, aggiunto resize-d/code e tolto il supporto per function? pane"
	0.1.5 "first version published on developer"
	0.1.4 "debugged version"
	0.1.3 "working version"
	0.1.2 "new version"
]
]

resize-vid-ctx: context [
	resize-mutual: [resize-x resize-y resize-xy resize-none]
	fresize: compose [resize-x 1 resize-y 2 resize-xy 3 (none) 3 resize-none (none)]
	fresize-e: extract fresize 2
	select-fresize: func [flags][select fresize pick intersect flags fresize-e 1]
	fanchor: [anchor-x 1x0 anchor-y 0x1 anchor-xy 1x1]
	fanchor-e: extract fanchor 2
	falone: join fanchor-e 'resize-alone
	resize-ob: make object! [resize-d: size: list: user-group: anchor: anchor-to: act: code: none]
	fake-ob: make object! [type: 'fake size: offset: 0x0 style: axis: extend: data: map: none]
	system/words/get-rd: func [face][
		all [in face 'flags face: face/flags face: find face 'resize-d get first face]
	]
	system/words/check-rd: func [face][
		if in face 'flags [any [get-rd face make resize-ob [resize-d: self flag-face face resize-d]]]
	]
	make-fake: function [comm [word!] xy [integer!] value [object! block!]][origin sz][
		either block? value [
			origin: 2147483647x2147483647 sz: 0x0
			foreach x value [origin: min origin x/offset sz: max sz x/offset + x/size]
			sz: sz - origin value: copy value
		][origin: value/offset sz: value/size value: reduce [value]]
		make fake-ob [style: comm offset: origin size: sz axis: xy data: value]
	]
	system/words/do-resize: function [
		{Execute the resize}
		face [object!] size [pair!] offset [pair!]
		/nosize
	][map xy tot lens tmp resto axis resize-d data][
		resize-d: get-rd face
		either nosize [size: face/size - resize-d/size resize-d/size: face/size][
			either in face 'resize [face/resize face/size + size][face/size: face/size + size]
			face/offset: face/offset + offset
		]
		if resize-d [
			if resize-d/anchor [
				foreach [home axis word] resize-d/anchor [
					do-resize first reduce reduce [word] 0x0 (size * home) + offset * axis
				]
			]
			if resize-d/list [foreach x resize-d/list [do-resize x size 0x0]]
			if get in resize-d 'act [resize-d/act face size offset]
		]
		if face/type = 'fake [
			xy: pick [1x0 0x1 1x1] axis: face/axis
			switch face/style [
				size [foreach x face/data [do-resize x size * xy 0x0]]
				shift [foreach x face/data [do-resize x 0x0 offset * xy]]
				do [face/data face size offset]
				group [
					data: face/data map: face/map
					either axis = 3 [
						foreach x data [
							do-resize x size * map/1 / 100x100 offset
							map: next map
						]
					][
						lens: copy []
						tot: size/:axis
						foreach x map [
							if 2 = axis [x: reverse x]
							insert tail lens tmp: size * x / 100x100
							tot: tot - tmp/:axis
						]
						resto: either positive? tot [xy][negate xy]
						foreach x map [
							if all [tot <> 0 x/1 <> 0][
								lens/1: lens/1 + resto
								tot: tot - resto/:axis
							]
							do-resize first data lens/1 offset
							offset: xy * lens/1 + offset
							lens: next lens data: next data
						]
					]
				]
			]
		]
	]
	;=============== View resize code ===================
	layout-resize: function [
		"Creates the resize list"
		[catch]	blk [block!]
	][res rule arg x map faces tmp extend][
		res: copy []
		rule: [
			set x set-word! (set x tail res)
			|[
				(arg: extend: 100x0)
				['across (arg: 1) | 'below (arg: 2)]
				opt ['extend (extend: 100x100) | 'none | none]
				set map block!
				into [
					(faces: copy [])
					some [
						x: ['across | 'below] 2 thru block! tmp:
						(insert tail faces layout-resize copy/part x tmp)
						| set x [word! | path! | object!] (insert tail faces reduce reduce [x])
					]
					(tmp: make-fake 'group arg faces
					 either empty? map [create-map tmp][tmp/map: map] tmp/extend: extend)
				]
				| 'do set arg block!
				 (tmp: make fake-ob [style: 'do axis: 1 data: func [face delta delta-offset] copy/deep arg]);????????
				| set arg ['size | 'shift] set x ['x | 'y | 'xy] set tmp block!
				 (tmp: make-fake arg select [x 1 y 2 xy 3] x reduce tmp)
			] (insert tail res tmp)
		]
		if not parse blk [some rule][throw make error! join "*** Invalid rule: " mold blk]
		res
	]
	;=============== VID resize code ===================
	sort-offset: function [pane [block!] x [integer!]][y][
		any [x <> 3 x: 1]
		y: 3 - x
		sort/compare pane func [a b][
			either a/offset/:x < b/offset/:x [-1][
				either a/offset/:x > b/offset/:x [1][
					either a/offset/:y < b/offset/:y [-1][
						either a/offset/:y > b/offset/:y [1][0]
					]
				]
			]
		]
	]
	overlap?: function [a b xy [integer!]][][
		either xy = 3 [
			all [
				b/offset/x + b/size/x > a/offset/x a/offset/x + a/size/x > b/offset/x
				b/offset/y + b/size/y > a/offset/y a/offset/y + a/size/y > b/offset/y
			]
		][all [b/offset/:xy + b/size/:xy > a/offset/:xy a/offset/:xy + a/size/:xy > b/offset/:xy]]
	]
	create-map: function [fake][tmp table tot resto map extend xy][
		xy: fake/axis
		table: pick [[100x0 0x100 100x100 0x0][0x100 100x0 100x100 0x0]] xy <> 2
		fake/map: map: copy []
		tot: 0 extend: 0x0
		foreach x fake/data [
			extend: extend + tmp: either x/type = 'face [
				either all [in x 'flags tmp: select-fresize x/flags][pick table tmp][0x0]
			][
				either (xy <> 2) xor (x/axis = 2) [x/extend][reverse x/extend]
			]
			if all [xy <> 3 tmp/1 > 0][tot: x/size/:xy + tot]
			insert tail map tmp
		]
		fake/extend: min 100x100 100x100 * extend
		if all[tot > 0 xy <> 3][
			resto: 100
			foreach x fake/data [
				if map/1/1 > 0 [map/1/1: x/size/:xy * 100 / tot  resto: resto - map/1/1]
				map: next map
			]
			if resto > 0 [
				map: head map
				while [all [not tail? map resto > 0]][
					if map/1/1 > 0 [map/1/1: map/1/1 + 1 resto: resto - 1]
					map: next map
				]
			]
		]
	]
	find-groups: function [pane xy [integer!]][start group fake face safe-pane][
		safe-pane: pane
		while [1 < length? safe-pane][
			pane: safe-pane
			insert group: clear [] start: first pane
			remove pane
			until[
				face: first pane
				all [
					fake: either (xy <> 3) xor found? overlap? start face xy [
						make fake-ob [
							style: 'group axis: xy
							size: (max start/offset + start/size face/offset + face/size) - offset: min start/offset face/offset
						]
					][none]
					xy <> 3
					foreach x head pane [any [x = face not overlap? fake x 3 fake: none break]]
				]
				tail? pane: either fake [
					insert tail group either face/type = xy [face/data][face]
					start: fake
					remove pane
				][next pane]
			]
			safe-pane: either 1 = length? group [insert safe-pane group next safe-pane][
				sort-offset start/data: copy group xy
				create-map start
				head insert safe-pane start
			]
		]
		clear group
	]
	system/words/auto-resize: function [[catch] face [object!]][pane resize-d tmp][
		pane: reduce [face]
		foreach x pane [
			all [word? x x: get x]
			if resize-d: get-rd x [
				resize-d/anchor: none
				;delete anchor from the 'to face also
				;if it not a subface
				if resize-d/anchor-to [
					foreach [home axis target] resize-d/anchor-to [
						all [
							object? tmp: either target = 'panel [x/parent-face][get target]
							tmp: get-rd tmp
							tmp/anchor
							remove/part find tmp/anchor reduce [pair! pair! x] 3
						]
					]
				]
			]
			any [function? tmp: get in x 'pane not tmp insert tail pane tmp]
		]
		auto-resize face
	]
	auto-resize: function [face [object!]][
		resize-d x-resize-d pane backd oldlen tmp x groups end axis name target
	][
		any [resize-d: check-rd face return face]
		resize-d/size: face/size
		if resize-d/code [resize-d/list: do resize-d/code return face]
		if any [in face 'resize	none? tmp: get in face 'pane function? :tmp][return face]
		insert pane: copy [] tmp
		backd: copy []
		groups: copy []
		while [not empty? pane][
			either in auto-resize x: first pane 'flags [
				x-resize-d: get-rd x
				either empty? intersect x/flags falone [
					either all [x-resize-d name: x-resize-d/user-group][
						any [tmp: select groups name insert tail groups reduce [name tmp: copy []]]
						insert tail tmp x
						remove pane
					][
						either find x/flags 'resize-next [
							insert tail groups reduce [<next> tmp: reduce [x]]
							remove pane
							while [not tail? pane][
								insert tail tmp auto-resize x: first pane
								remove pane
								any [find x/flags 'resize-next break]
							]
						][pane: next pane]
					]
				][
					remove pane
					if tmp: select-fresize x/flags [insert tail backd make-fake 'size tmp x]
					any [
						empty? intersect x/flags fanchor-e
						foreach [home axis target] x-resize-d/anchor-to [
							tmp: check-rd either target = 'panel [face][get target]
							insert tail any [tmp/anchor tmp/anchor: copy []] reduce [home axis x]
						]
					]
				]
			][pane: next pane]
		]
		pane: head pane
		insert tail groups reduce [<main> pane]
		foreach [name pane] groups [
			if 1 < length? pane [
				sort-offset pane 2
				find-groups pane 3
				until [
					oldlen: length? pane
					foreach xy [2 1][find-groups pane xy]
					any [1 = length? pane all [oldlen = length? pane throw make error! join "invalid group: " to string! name]]
				]
			]
			any [name = <main> insert tail groups/<main> pane]
		]
		while [not tail? pane][
			pane: either all [pane/1/type = 'face in pane/1 'flags][
				either tmp: select-fresize pane/1/flags [
					change pane make-fake 'size tmp pane/1
				][remove pane]
			][next pane]
		]
		resize-d/list: head insert pane backd
		face
	]
	flag-resize: function [face flag][tmp][
		if find resize-mutual flag [foreach x resize-mutual [remove find face/flags x]]
		do compose [flag-face face (flag)]
	]
	;install
	insert-event-func func [face event][
		if all [event/type = 'resize flag-face? event/face resize-d][
			do-resize/nosize event/face 0x0 0x0
			show event/face
		]
		event
	]
	;============== auto-resize patch: new facets
	insert tail svv/facet-words reduce [
		'resize-none 'resize-alone 'resize-x 'resize-y 'resize-xy 'resize-next func [new args][
			flag-resize new first args args
		]
		'resize-of func [new args][
			set in check-rd new 'user-group second args next args
		]
		'resize-do func [new args][
			set in check-rd new 'act func [face delta delta-offset] copy/deep second args next args
		]
		'anchor-x 'anchor-y 'anchor-xy func [new args][
			flag-resize new first args
			new: check-rd new
			any [new/anchor-to new/anchor-to: copy []]
			insert tail new/anchor-to reduce [third args select fanchor first args second args]
			next next args
		]
	]
	;=============== Style resize code ===================
	;all the following stuff should be done by style coder, this is a patch of some of existing styles
	use [styles style h flag] [
		styles: svv/vid-styles
		parse [
			backdrop backtile 'resize-alone
			arrow sensor key button toggle check radio btn btn-cancel btn-help btn-enter tog led 'resize-none
			field choice info text vtext txt body banner vh1 vh2 vh3 vh4 label lbl title rotary h1 h2 h3 h4 h5 tt code 'resize-x
			logo-bar 'resize-y
		][
			some [
				to word! set style word! h: to lit-word! set flag lit-word!
				(if object? style: select styles style [
					append style/init bind compose/deep [
						if any [not find resize-mutual (:flag) empty? intersect flags resize-mutual][
							append flags (:flag)
						]
					] in style 'self
				]):h
			]
		]
		foreach [name blk][
			list [
				set in check-rd self 'code [
					auto-resize subface
					layout-resize [size x [subface]]
				]
			]
			slider [
				if empty? intersect flags resize-mutual [append flags either size/y > size/x [[resize-y]][[resize-x]]]
				set in check-rd self 'code [none]
			]
			scroller [
				if empty? intersect flags resize-mutual [append flags select [y [resize-y] x [resize-x]] axis]
			]
			text-list [
				set in check-rd self 'code [
					layout-resize [
						size x [iter] size xy [pane] across extend [100x100 0x100] [sub-area sld]
						do [lc: to integer! size/y / iter/size/y sld/redrag lc / max 1 length? head lines]
					]
				]
			]
		][if name: select styles name [insert tail name/init bind blk in name 'self]]
	]
]