Archive version of: color-requester.r ... version: 1 ... luce80 4-Jul-2020

Amendment note: new script || Publicly available? Yes

REBOL [
	title: "Choose and convert colors"
	needs: "Recent versions of %feel-loose.r, %simple-spin-number.r, %simple-pop-down.r"
	Date: 21-06-2020
	Version: 0.8.1
	File: %color-requester.r
	Author: "Marco Antoniazzi"
	Rights: "Copyright (C) 2020 Marco Antoniazzi"
	Purpose: "Requests a color or modify or convert it"
	eMail: [luce80 AT libero DOT it]
	History: [
		0.0.1 [09-05-2020 "Started"]
		0.8.1 [21-06-2020 "Mature enough"]
	]
	Category: [util vid gfx]
	library: [
		level: 'advanced
		platform: 'all
		type: 'function
		domain: [gui VID]
		tested-under: [View 2.7.8.3.1]
		support: none
		license: 'BSD
		see-also: none
	]
]
; misc
	script-version: func [
		source [string!]
		/local version spaces chars
		][
		version: 0.0.0
		chars: complement spaces: charset " ^-^/"
		parse/all source [
			thru "REBOL [" thru "version:" some spaces
			copy version some chars
		]
		to-tuple version
	]
	undirize: func ["Returns a copy of the path turned into a file."
		path [file! url! string!]
		][
		path: copy path
		while [find "/\" path: back tail path] [remove path]
		head path
	]
	choose_file: func [filter [string!]/local file-name] [
		until [
			file-name: request-file/keep/only/filter filter
			if none? file-name [return none]
			exists? file-name
		]
		to-rebol-file file-name
	]
	download: func [
		url [url!]
		/local lo bar cbk-fn data
		][
		view/new lo: center-face layout [
			lbl "Downloading"
			text (form url)
			bar: progress
		]
		cbk-fn: func [total bytes][
			set-face bar bytes / total
		]
		data: read-net/progress url :cbk-fn
		unview/only lo
		data
	]
	load-script-thru: func ["Load a script from www.rebol.org thru the cache"
		name [file! url!]
		/flash "Flash a message to the user while downloading"
		/warn "Alert user if script not found"
		/from path [file! url!] "Optional path where to search for the script"
		/version ver [tuple!] "Minimum version required"
		/local cache-name modul check-ver
		][
		check-ver: func [name /local modul][if ver > script-version modul: read name [modul: none] modul]

		if not value? 'view-root [view-root: either system/version/4 = 3 [%/C/Users/Public/Documents] [%/tmp]]
		cache-name: view-root/:name
		ver: any [ver 0.0.0]
		modul: any [
			attempt [check-ver rejoin [undirize path "/" name]] ; try optional dir 
			attempt [check-ver cache-name] ; try the cache
			attempt [check-ver name] ; try current dir
			attempt [ ; try loading it or downloading it from www.rebol.org
				switch request [rejoin [form name " not found or wrong version, load it, download it from www.rebol.org or quit?"] "Load" "Download" "Quit"] [
					#[none] [quit]
					#[true] [check-ver choose_file "*.r"]
					#[false] [
						modul: rejoin [http://www.rebol.org/download-a-script.r?script-name= name]
						modul: as-string either flash [download modul][read modul]
						if not find modul "REBOL [" [make error! "Script not found"]
						if ver > script-version modul [make error! "Script version too small"] ; FIXME: errors are silenced by attempt [...
						write cache-name modul
						modul
					]
				]
			]
		]
		if all [not modul warn] [alert rejoin ["Script <" name "> not found or version too small."]]
		modul
	]
;
if error? try [ ; use "do load" to avoid executing examples
	do load load-script-thru/flash/warn/from/version %feel-loose.r %../ 0.2.0
	do load load-script-thru/flash/warn/from/version %simple-spin-number.r %../simple 0.0.2
	do load load-script-thru/flash/warn/from/version %simple-pop-down.r %../simple 0.0.4
	][
	quit
]

; color spaces conversions
color-conv-ctx: context [
	to-tuple-color: func [color [block!]][
		(1.0.0 * round color/1 * 255) + (0.1.0 * round color/2 * 255) + (0.0.1 * round color/3 * 255)
	]
	rgb-to-hexadecimal: func [
		"Converts RGB value to hexadecimal number" 
		rgb [block!] "values in range 0-1"
		/local bin
		][
		remove remove to-hex to-integer to-binary to-tuple-color rgb
	]
	hexadecimal-to-rgb: func [
		"Converts hexadecimal number to RGB." 
		hex [issue! string!] "values in range 00-FF"
		][
		if "#" = first hex [remove hex]
		hex: debase/base form hex 16
		reduce [hex/1 / 255 hex/2 / 255 hex/3 / 255]
	]

	rgb-to-hsv: func [
		"Converts RGB value to HSV (hue, saturation, value). Values in range 0-1" 
		rgb [block!] "values in range 0-1"
		/local r g b chroma h v
		][
		set [r g b] rgb
		v: max max r g b
		chroma: v - min min r g b
		if chroma = 0 [return reduce [0 0 v]] ; achromatic gray
		h: case [
			v = r [g - b / chroma + 0]	; between yellow & magenta
			v = g [b - r / chroma + 2]	; between cyan & yellow
			v = b [r - g / chroma + 4]	; between magenta & cyan
		]
		if h < 0 [h: h + 6]
		reduce [h / 6 chroma / v v]
	]
	hsvf: func [h a b c /local k][
		k: abs (mod (6 * h + c) 6) - 3 
		k: min max 0 k - 1 1
		k: k * a + b 
	]
	hsv-to-rgb: func [
		"Converts HSV (hue, saturation, value) to RGB. Values in range 0-1" 
		hsv [block!] "values in range 0-1"
		/local h s v a b
		][
		set [h s v] hsv
		if s = 0 [return reduce [v v v]] ; achromatic grey
		a: v * s
		b: v - a

		reduce [hsvf h a b 0 hsvf h a b 4 hsvf h a b 2]
	]

	rgb-to-hsl: func [
		"Converts RGB value to HSL (hue, saturation, lightness). Values in range 0-1" 
		rgb [block!] "values in range 0-1"
		/local r g b chroma h v L
		][
		set [r g b] rgb
		v: max max r g b
		chroma: v - L: min min r g b
		if chroma = 0 [return reduce [0 0 v]] ; achromatic gray
		L: v + L
		h: case [
			v = r [g - b / chroma + 0]	; between yellow & magenta
			v = g [b - r / chroma + 2]	; between cyan & yellow
			v = b [r - g / chroma + 4]	; between magenta & cyan
		]
		if h < 0 [h: h + 6]
		reduce [h / 6 chroma / (1 - abs L - 1) L / 2]
	]
	hslf: func [h a b c /local k][
		k: mod (12 * h + c) 12
		k: min max -1 min (k - 3) (9 - k) 1
		k: k * a + b 
	]
	hsl-to-rgb: func [
		"Converts HSL (hue, saturation, lightness) to RGB. Values in range 0-1" 
		hsl [block!] "values in range 0-1"
		/local h s a L 
		][
		set [h s L] hsl
		if s = 0 [return reduce [L L L]] ; achromatic gray
		a: 0 - (s * min L 1 - L)

		reduce [hslf h a L 0 hslf h a L 8 hslf h a L 4]
	]

	rgb-to-hwb: func [
		"Converts RGB value to HWB (hue, whiteness, blackness). Values in range 0-1" 
		rgb [block!] "values in range 0-1"
		/local r g b chroma h v w
		][
		set [r g b] rgb
		v: max max r g b
		chroma: v - w: min min r g b
		if chroma = 0 [return reduce [0 0 v]] ; achromatic gray
		h: case [
			v = r [g - b / chroma + 0]	; between yellow & magenta
			v = g [b - r / chroma + 2]	; between cyan & yellow
			v = b [r - g / chroma + 4]	; between magenta & cyan
		]
		if h < 0 [h: h + 6]
		reduce [h / 6  w  1 - v]
	]
	hwbf: func [h c /local k][
		k: abs (mod (6 * h + c) 6) - 3 
		k: min max 0 k - 1 1
	]
	hwb-to-rgb: func [
		"Converts HWB (hue, whiteness, blackness) to RGB. Values in range 0-1" 
		hwb [block!] "values in range 0-1"
		/local h w b rgb scale
		][
		set [h w b] hwb
		scale: 1 - w - b

		rgb: reduce [hwbf h 0 hwbf h 4 hwbf h 2]
		reduce [rgb/1 * scale + w rgb/2 * scale + w rgb/3 * scale + w]
	]
	
	rgb-to-hsi: func [
		"Converts RGB value to HSI (hue, saturation, intensity). Values in range 0-1" 
		rgb [block!] "values in range 0-1"
		/local r g b w h s i
		][
		set [r g b] rgb
		i: r + g + b / 3
		s: either i = 0 [0][1 - ((min min r g b) / i) ]
		if s = 0 [return reduce [0 0 i]]
		{
		w: 0.5 * (r - g + r + b) / square-root (((r - g) * (r - g)) + ((r - b) * (g - b)))
		w: min max -1 w 1
		h: arccosine/radians w
		if b > g [h: 2 * pi - h]
		}
		h: arctangent/radians 1.73205080756888 * (g - b) / (r - g + r - b) ; ... (sqrt 3) * ...
		if h < 0 [h: h + pi]
		if b > g [h: h + pi]

		reduce [h / (2 * pi) s i]
	]
	hsi-to-rgb: func [
		"Converts HSI (hue, saturation, intensity) to RGB. Values in range 0-1" 
		hsi [block!] "values in range 0-1"
		/local h s i r g b
		][
		set [h s i] hsi
		if s = 0 [return reduce [i i i]]
		h: h * 360 ; h in 0-360 range
		case [
			h < 120 [
				b: 1 - s * i
				r: (s * cosine h) / (cosine (60 - h)) + 1 * i
				g: 3 * i - b - r
			]
			h < 240 [
				h: h - 120
				r: 1 - s * i
				g: (s * cosine h) / (cosine (60 - h)) + 1 * i
				b: 3 * i - r - g
			]
			h <= 360 [
				h: h - 240
				g: 1 - s * i
				b: (s * cosine h) / (cosine (60 - h)) + 1 * i
				r: 3 * i - g - b
			]
		]
		reduce [r g b]
	]

	rgb-to-cmy: func [
		"Converts RGB value to CMY (cyan, magenta, yellow). Values in range 0-1" 
		rgb [block!] "values in range 0-1"
		/local r g b
		][
		set [r g b] rgb
		reduce [1 - r 1 - g 1 - b]
	]
	cmy-to-rgb: func [
		"Converts CMY (cyan, magenta, yellow) to RGB. Values in range 0-1" 
		cmy [block!] "values in range 0-1"
		/local c m y
		][
		set [c m y] cmy
		reduce [1 - c 1 - m 1 - y]
	]

	rgb-to-cmyk: func [
		"Converts RGB value to CMYK (cyan, magenta, yellow, black). Values in range 0-1" 
		rgb [block!] "values in range 0-1"
		/local r g b c m y k
		][
		set [r g b] rgb
		set [c m y] reduce [1 - r 1 - g 1 - b]
		k: min min c m y
		if k = 1 [return copy [0 0 0 1]]
		reduce [c - k / (1 - k)   m - k / (1 - k)   y - k / (1 - k)   k]
	]
	cmyk-to-rgb: func [
		"Converts CMYK (cyan, magenta, yellow, black) to RGB. Values in range 0-1" 
		cmyk [block!] "values in range 0-1"
		/local c m y k
		][
		set [c m y k] cmyk
		k: 1 - k
		reduce [1 - c * k  1 - m * k  1 - y * k]
	]

	; values from http://www.brucelindbloom.com/index.html?Eqn_RGB_to_XYZ.html
	rgb-to-XYZ-sRGB-D65: [
		[0.4124564  0.3575761  0.1804375]
		[0.2126729  0.7151522  0.0721750]
		[0.0193339  0.1191920  0.9503041]
	]
	XYZ-to-rgb-sRGB-D65: [
		[ 3.2404542 -1.5371385 -0.4985314]
		[-0.9692660  1.8760108  0.0415560]
		[ 0.0556434 -0.2040259  1.0572252]
	]
	dot: func [
		row [block!]
		col [block!]
		][
		(row/1 * col/1) + (row/2 * col/2) + (row/3 * col/3)
	]
	rgb-to-xyz: func [
		"Converts RGB value to XYZ. Values in range 0-1" 
		rgb [block!] "values in range 0-1"
		/space ws [word! string!]
		/white ref [word! string!]
		/local mat gamma-correct
		][
		gamma-correct: func [rgb][
			repeat u 3 [

				rgb/(u): either rgb/(u) <= 0.04045 [
					rgb/(u) / 12.92
				][
					power (rgb/(u) + 0.055) / 1.055 2.4
				]
			]
			rgb
		]

		ws: form any [ws "sRGB"]
		ref: form any [ref "D65"]
		mat: get bind to-word join "rgb-to-XYZ-" [ws "-" ref] self
		rgb: gamma-correct copy rgb
		reduce [dot mat/1 rgb dot mat/2 rgb dot mat/3 rgb]
	]
	xyz-to-rgb: func [
		"Converts XYZ to RGB. Values in range 0-1" 
		xyz [block!] "values in range 0-1"
		/space ws [word! string!]
		/white ref [word! string!]
		/local mat gamma-correct rgb
		][
		gamma-correct: func [rgb][
			repeat u 3 [

				rgb/(u): either rgb/(u) <= 0.0031308 [
					rgb/(u) * 12.92
				][
					(1.055 * power rgb/(u) (1 / 2.4)) - 0.055
				]
			]
			rgb
		]

		ws: form any [ws "sRGB"]
		ref: form any [ref "D65"]
		mat: get bind to-word join "XYZ-to-rgb-" [ws "-" ref] self
		rgb: reduce [dot mat/1 xyz dot mat/2 xyz dot mat/3 xyz]
		gamma-correct rgb
	]
	rgb-to-YPbPr-SDTV: [
		[ 0.299  0.587  0.114]
		[-0.169 -0.331  0.500]
		[ 0.500 -0.419 -0.081]
	]
	YPbPr-to-rgb-SDTV: [
		[ 1.000  0.000  1.402]
		[ 1.000 -0.344 -0.714]
		[ 1.000  1.722  0.000]
	]
	rgb-to-YPbPr: func [
		"Converts RGB value to YPbPr with values in range [0 1] and [-.5 +.5]" 
		rgb [block!] "values in range 0-1"
		/tv video [word! string!]
		/local mat
		][

		video: form any [video "SDTV"]
		mat: get bind to-word append copy "rgb-to-YPbPr-" video self
		reduce [dot mat/1 rgb dot mat/2 rgb dot mat/3 rgb]
	]
	YPbPr-to-rgb: func [
		"Converts YPbPr with values in range [0 1] and [-.5 +.5] tp RGB values in range [0 1]" 
		YPbPr [block!] "values in range [0 1] and [-.5 +.5]"
		/tv video [word! string!]
		/local mat
		][

		video: form any [video "SDTV"]
		mat: get bind to-word append copy "YPbPr-to-rgb-" video self
		reduce [dot mat/1 YPbPr dot mat/2 YPbPr dot mat/3 YPbPr]
	]
	rgb-to-YCbCr-full: [
		[ 0.299  0.587  0.114]
		[-0.169 -0.331  0.500]
		[ 0.500 -0.419 -0.081]
	]
	YCbCr-to-rgb-full: [
		[ 1.000  0.000  1.400]
		[ 1.000 -0.343 -0.711]
		[ 1.000  1.765  0.000]
	]
	rgb-to-YCbCr: func [
		"Converts RGB value to YCbCr with values in range [0 1]" 
		rgb [block!] "values in range 0-1"
		/tv video [word! string!]
		/local mat
		][

		video: form any [video "full"]
		mat: get bind to-word append copy "rgb-to-YCbCr-" video self
		reduce [dot mat/1 rgb 0.5 + dot mat/2 rgb 0.5 + dot mat/3 rgb]
	]
	YCbCr-to-rgb: func [
		"Converts YCbCr with values in range [0 1] tp RGB values in range [0 1]" 
		YCbCr [block!] "values in range [0 1]"
		/tv video [word! string!]
		/local mat
		][
		YCbCr/2: YCbCr/2 - .5
		YCbCr/3: YCbCr/3 - .5

		video: form any [video "full"]
		mat: get bind to-word append copy "YCbCr-to-rgb-" video self
		reduce [dot mat/1 YCbCr dot mat/2 YCbCr dot mat/3 YCbCr]
	]
	rgb-to-yuv-atv: [
		[ 0.299  0.587  0.114]
		[-0.147 -0.289  0.436]
		[ 0.615 -0.515 -0.100]
	]
	yuv-to-rgb-atv: [
		[ 1.000  0.000  1.140]
		[ 1.000 -0.395 -0.581]
		[ 1.000  2.032  0.000]
	]
	rgb-to-yuv: func [
		"Converts RGB value to YUV with values in range [0 1] [-0.436 +0.436] [-0.615 +0.615]" 
		rgb [block!] "values in range 0-1"
		/local mat
		][

		mat: rgb-to-yuv-atv
		reduce [dot mat/1 rgb dot mat/2 rgb dot mat/3 rgb]
	]
	yuv-to-rgb: func [
		"Converts YUV with values in range [0 1] [-0.436 +0.436] [-0.615 +0.615] tp RGB values in range [0 1]" 
		yuv [block!] "values in range [0 1] [-0.436 +0.436] [-0.615 +0.615]"
		/local mat
		][

		mat: yuv-to-rgb-atv
		reduce [dot mat/1 yuv dot mat/2 yuv dot mat/3 yuv]
	]
	rgb-to-CIELAB: func [
		"Converts RGB value to CIE L*a*b* with values in range [0 100] and [-128 128]" 
		rgb [block!] "values in range [0 1]"
		/local xyz value
		][
		xyz: rgb-to-xyz rgb
		; observer = 2°, illuminant = D65
		xyz/1: xyz/1 * 100 / 95.047
		xyz/2: xyz/2 * 100 / 100.0
		xyz/3: xyz/3 * 100 / 108.883
		forall xyz [
			value: xyz/1
			xyz/1: either value > 0.008856 [
				power value (1 / 3)
			][
				7.787 * value + (16 / 116)
			]
		]
		reduce [116 * xyz/2 - 16  500 * (xyz/1 - xyz/2)  200 * (xyz/2 - xyz/3)]
	]
	CIELAB-to-rgb: func [
		"Converts CIE L*a*b* with values in range [0 100] and [-128 128] to RGB values in range [0 1]"
		Lab [block!] "values in range [0 100] and [-128 128]"
		/local x y z xyz value
		][
		y: Lab/1 + 16 / 116
		x: Lab/2 / 500 + y
		z: y - (Lab/3 / 200)

		xyz: reduce [x y z]
		forall xyz [
			value: power xyz/1 3
			xyz/1: either value > 0.008856 [
				value
			][
				xyz/1 - (16 / 116) / 7.787
			]
		]
		; observer = 2°, illuminant = D65
		xyz/1: xyz/1 * 95.047 / 100
		xyz/2: xyz/2 * 100.0 / 100
		xyz/3: xyz/3 * 108.883 / 100
		xyz-to-rgb xyz
	]

]

if not value? 'color-req-ctx [

color-req-ctx: context [
	tab-chain: none

	; series
		cycle: func [
			"Cycles through a series"
			series [series! port!]
			/back
			][
			either back [
				system/words/back either head? series [tail series] [series]
			][
				either tail? next series [head series] [next series]
			]
		]
		fry: func [
			series [series!]
			items [series!]
			/with
				marker [word!]
			][
			marker: any [marker '_]
			items: copy items
			replace/all copy series marker does [take items]
		] 
	;
	; control
		eat_events: func [;{derived from flush_events 12-May-2007 Anton Rolls}
			"Allow GUI messages to be processed faster then wait."
			/skip events [block!] "types of events to skip. Default: [move]"
			/local evt
			] [
			events: any [events [move]]
			; Remove the event-port
			remove find system/ports/wait-list system/view/event-port
			
			; Clear the event port of queued events
			while [evt: pick system/view/event-port 1][if not find events evt/type [do evt]] ; fixed by luce80
			
			; Re-add the event-port to the wait-list
			insert system/ports/wait-list system/view/event-port
		]
	;
	; math
		atan2: func [; author: Steeve Antoine 2009, modified by luce80
			"Angle of the vector (0,0)-(x,y) with arctangent y / x. The resulting angle is in range 0 360"
			x [number!] y [number!]
			][
			if x = 0 [x: 1e-10]
			;mod add arctangent y / x pick [0 180] x > 0 360 ; 0 at east
			90 + add arctangent y / x pick [0 180] x > 0 ; 0 at north
		]
		rotate-point: func [p [pair!] sina [decimal!] cosa [decimal!] /local px py][
			px: p/x
			py: p/y
			p/x: (px * cosa) - (py * sina)
			p/y: (px * sina) + (py * cosa)
			p
		]
		rotate-point-around-point: func [p [pair!] sina [decimal!] cosa [decimal!] center [pair!] /local px py cx cy][
			px: p/x
			py: p/y
			cx: center/x
			cy: center/y
			p/x: (px * cosa) - (py * sina) - (cx * cosa) + (cy * sina) + cx
			p/y: (px * sina) + (py * cosa) - (cx * sina) - (cy * cosa) + cy
			p
		]
		re-form-dec: func [dec [string!] /local pos][
			pos: dec
			while [pos: find pos "E-2"][
				remove/part pos 3
				insert back pos "0.0"
			]
			pos: dec
			while [pos: find pos ".0."][
				remove pos
				move back pos 3
			]
			pos: dec
			while [pos: find pos "E-3"][
				remove/part pos 3
				insert back pos "0.00"
			]
			pos: dec
			while [pos: find pos ".0."][
				remove pos
				move back pos 4
			]
			dec
		]
	;
	; tuple<->block
		normalize-color: func [color [tuple!]] [
			reduce [(color/1 / 255) (color/2 / 255) (color/3 / 255)]
		]
		to-tuple-color: func [color [block!]][
			(1.0.0 * round color/1 * 255) + (0.1.0 * round color/2 * 255) + (0.0.1 * round color/3 * 255)
		]
		scale-block: func [color [block!] scale [block!]] [
			color: copy color
			foreach [mult rnd] scale [
				color/1: round/to color/1 * mult rnd
				color: next color
			]
			head color
		]
	;

	color-styles: stylize [
		grad-slider: box
			edge [size: 1x1 color: none]
			feel [
				engage: func [face action event][
					if action = 'key [
						switch event/key [
							up right [set-face face face/step + get-face face]
							down left [set-face face 0 - face/step + get-face face]
						]
					]
				]
			]
			with [
				data: 0
				low: 0 high: 1 step: none
				words: [low high step [
					if not number? second args [make error! reduce ['script 'expect-set "number!" type? second args]]
					set in new first args second args next args]
				]
				knob-w_2: 7
				width-in: 255
				box-slide: none
				box-knob: none
				main: none
				main-colors: none
				this: self
				access: make ctx-access/data-number [
					set-face*: func [face value][
						if face/data = value [exit]
						face/data: value: min max face/low value face/high
						face/box-knob/offset/x: round width-in * (value - face/low) / (face/high - face/low + 1e-10)
						do-face face value
					]
				]

				init: [
					this: self
					if none? step [step: (high - low) / 100]
					main-colors: any [colors [0.0.0 255.0.0]]
					colors: none
					color: none
					main: layout [
						origin as-pair knob-w_2 0
						at as-pair knob-w_2 4
						box-slide: box width-in * 1x0 + 0x20 edge none
							;effect reduce ['gradient 1x0 main-colors/1 main-colors/2]
							feel [
								engage: func [face action event /local offs][
									offs: face/offset/x - knob-w_2
									box-knob/offset/x: min max offs offs + event/offset/x offs + width-in
									do box-knob/feel/action
									if action = 'down [
										focus this
										;focus box-knob
										;system/view/caret: none ; feel-loose prevents the face to loose focus even if there is this !
										box-knob/edge/size: 3x3
									]
									if action = 'up [box-knob/edge/size: 2x2]
									show box-knob
								]
							]
						at 0x0
						box-knob: box (knob-w_2 * 2x0 + 0x28)
							with [flags: [no-focus]]
							edge [size: 2x2 color: gray]
							feel [
								engage: func [face action event][
									if action = 'down [focus this box-knob/edge/size: 3x3]
									if action = 'up [box-knob/edge/size: 2x2]
									show box-knob
								]
							]
							loose [
								step: 1x0
								range-x: as-pair box-slide/offset/x - knob-w_2 box-slide/offset/x - knob-w_2 + width-in
								action: [
									this/data: box-knob/offset/x / box-slide/size/x
									this/data: min max 0 this/data 1
									this/data: this/data * (this/high - this/low) + this/low
									this/action this this/data
								]
							]
					] ; layout
					size: main/size + (edge/size * 2)
					pane: get in main 'pane
					if all [effect not find effect 'gradient] [insert effect [gradient 1x0 230.230.230 230.230.230]]
					box-slide/effect: effect
					effect: none
					user-data: data
					data: none ; force refresh in set-face
				] ; init
			] ; with
		

		palette-mixer: box
			font [size: 14]
			effect [draw [translate 2x2]]
			feel [
				engage: func [face action event /local pos cell] [
					if action = 'up [
						pos: event/offset
						cell: min max 1x1 pos - 2x2 - face/edge/size / face/swatch-size + 1x1 7x6
						case [
							cell/y <= 3 [face/source: none face/dest: cell]
							cell/y  = 4 [face/source: none face/dest: none]
							cell/y <= 6 [
								either face/dest [
									face/source: cell face/mix face/dest: none
								][
									face/dest: cell
								]
							]
						]
						either face/dest [
							face/effect/draw/("evpen"): white
							face/effect/draw/("evpos"): face/swatch-size * face/dest
							do-face face face/effect/draw/(form face/dest)
						][
							face/effect/draw/("evpen"): none
						]
						show face
					]
				]
			]
			with [
				access: make ctx-access/data-number [
					set-face*: func [face value][
						face/dest: value/1
						face/data: value/2
					]
				]
				colors: [ ; my own "balanced" palette (inspired by McBeth colors)
					234.184.142 255.255.0  160.187.37 204.249.218 189.186.214 241.137.163  255.255.255
					255.0.0     255.102.0  0.156.19   0.171.128   0.164.227   175.44.116   128.128.128
					143.48.29   89.44.16   0.79.0     37.96.165   36.49.131   117.34.118   0.0.0
				]
				source: none
				dest: none
				swatch-size: 50x30
				orig: 0x0
				mix: func [/local draw lft mid rgt cell swatch][
					draw: effect/draw
					if none? source [exit]
					if none? dest [exit]
					draw/(form source): either dest = 0x0 [data] [draw/(form dest)]
					mid: source
					source/x: 1
					lft: draw/(form source)
					rgt: draw/(form mid)
					for cell mid/x - 1 2 -1 [
						swatch: form as-pair mid/x - cell + 1 source/y
						lft/1: round rgt/1 - lft/1 / cell + lft/1
						lft/2: round rgt/2 - lft/2 / cell + lft/2
						lft/3: round rgt/3 - lft/3 / cell + lft/3
						draw/(swatch): lft
					]

					lft: draw/(form mid)
					source/x: 7
					rgt: draw/(form source)
					for cell 7 - mid/x 2 -1 [
						swatch: form as-pair 7 - cell + 1 source/y
						lft/1: round rgt/1 - lft/1 / cell + lft/1
						lft/2: round rgt/2 - lft/2 / cell + lft/2
						lft/3: round rgt/3 - lft/3 / cell + lft/3
						draw/(swatch): lft
					]
				]
				append init [
					orig: 0x0
					repeat r 6 [
						repeat c 7 [
							append effect/draw compose [
								pen (either r = 4 [none][black])
								fill-pen (form as-pair c r) (pick colors (r - 1 * 7 + c))
								box (orig) (orig + swatch-size)
							]
							orig/x: orig/x + swatch-size/x
						]
						orig/x: 0
						orig/y: orig/y + swatch-size/y
					]
					append effect/draw compose [font (font) text (swatch-size * 3 + 10 * 0x1 + 4x0) "Pick a color and select a box below"]
					append effect/draw compose [
						pen "evpen" none line-width 2 fill-pen none
						translate "evpos" (swatch-size * 1x1)
						box (1x1) (0x0 - swatch-size - 1x1)
					]
					effect/draw/("1x5"): white
					effect/draw/("7x5"): black
					effect/draw/("1x6"): black
					effect/draw/("7x6"): white
					source: 1x5 dest: 1x5 mix
					source: 1x6 dest: 1x6 mix
					source: dest: none
					size: edge/size * 2 + as-pair swatch-size/x * 7 + 1 + 4 swatch-size/y * 6 + 1 + 4
				]
			]

	]

	ctx-rgb: context [
		gs-1:
		gs-2:
		gs-3:
		spin-1:
		spin-2:
		spin-3:
		none
		refresh: func [
			comp
			gs
			/local chg-grad
			][
			chg-grad: func [face comp][
				face/box-slide/effect/3: face/box-slide/effect/4: box-sample/color
				face/box-slide/effect/3/(comp): 0
				face/box-slide/effect/4/(comp): 255
				show face
			]
			if not value? 'box-sample [exit]
			update_sample comp get-face gs
			; always change ALL gradients because they depend on all 3 components
			chg-grad gs-1 1
			chg-grad gs-2 2
			chg-grad gs-3 3
		]
		update_sample: func [comp value][
			if not value? 'box-sample [exit]
			set-face box-sample head change at copy get-face box-sample comp value / 255
		]
		rgb: layout/tight [
			styles color-styles
			style grad-slide grad-slider 128 low 0 high 255 step 1 effect [gradient 1x0 0.0.0 255.0.0]
			style spin spin-number 70x22 128.0 integer low 0 high 255
			space 0x-4
			across
			gs-1: grad-slide [refresh 1 face]
			pad 0x4
			spin-1: spin [update_sample 1 get-face face]
			h3 "R" feel none
			return
			gs-2: grad-slide [refresh 2 face]
			pad 0x4
			spin-2: spin [update_sample 2 get-face face]
			h3 "G" feel none
			return
			gs-3: grad-slide [refresh 3 face]
			pad 0x4
			spin-3: spin [update_sample 3 get-face face]
			h3 "B" feel none
			do [tab-chain: reduce [spin-1/field spin-2/field spin-3/field]]
		]
	]

	ctx-hsl-g: context [
		hsl-gizmo:
		spin-1:
		spin-2:
		spin-3:
		none
		update_sample: func [/local hsl][
			if not value? 'box-sample [exit]
			hsl: reduce [((get-face spin-1) / 360)  (min max 1e-10 (get-face spin-2) / 100 1 - 1e-10) (min max 1e-10 (get-face spin-3) / 100 1 - 1e-10)]
			set-face box-sample color-conv-ctx/hsl-to-rgb hsl
		]
		hsl-giz: layout/tight [
			hsl-gizmo: box 200x200
				effect compose/deep [draw [
					; HSL gizmo
					; H
					pen none
					fill-pen conic 100x100 0 360 90 1 1
					red yellow green cyan blue magenta red
					circle 100x100 100
					fill-pen "G" (white + 0.0.0.255) ; grayness (saturation)
					circle 100x100 100
					fill-pen "D" (black + 0.0.0.255) ; darkness (value)
					circle 100x100 100
					fill-pen white
					circle 100x100 75

					pen 220.220.220
					; S
					fill-pen 
					conic 100x100 10 360 170 1 1
					black "S0" gray "S1" red
					arc 100x100 70x70 190 160 closed
					; L
					fill-pen 
					conic 100x100 200 360 -10 1 1
					white "L.5" red black
					arc 100x100 70x70 10 160 closed

					fill-pen white
					circle 100x100 45
					pen none
					; old (optional)
					fill-pen "old" black
					arc 100x100 40x40 180 180 closed
					; new
					fill-pen "new" red
					arc 100x100 40x40 0 180 closed

					pen black fill-pen none
					circle 100x100 40

					; knobs
					translate "KH" 100x12
					pen white line-width 2.5 fill-pen none
					circle 0x0 11.5
					pen black line-width 2
					circle 0x0 10
					reset-matrix
					translate "KS" 100x42
					pen white line-width 2.5
					circle 0x0 11.5
					pen black line-width 2
					circle 0x0 10
					reset-matrix
					translate "KL" 100x157
					pen white line-width 2.5
					circle 0x0 11.5
					pen black line-width 2
					circle 0x0 10
					reset-matrix
				]]
				feel [
					engage: func [face action event /local k pos radius angle col][
						if find [down over away] action [
							pos: event/offset - 100x100
							radius: 1e-10 + square-root (pos/x * pos/x) + (pos/y * pos/y)
							angle: atan2 pos/x pos/y
						]
						case [
							action = 'down [
								face/k: case [
									radius <= 40 [
										exit
									]
									radius <= 70 [
										face/orbit: 58
										case [
											all [100 < angle angle < 260] [face/ang-min: 100 face/ang-max: 260 "KL"]
											any [280 < angle angle <  80] [face/ang-min: 100 face/ang-max: 260 angle: mod angle - 180 360 "KS"]
											'else [none]
										]
									]
									radius <= 101 [
										face/orbit: 88
										face/ang-min: 0 face/ang-max: 360
										"KH"
									]
									'else [
										none
									]
								]
								if face/k [
									if radius <> face/orbit [
										pos: pos * (face/orbit / radius) ; re-put on orbit
									]
								]
							]
							find [over away] action [
								if none? face/k [exit]
								if face/k = "KS" [angle: mod angle - 180 360]
								if radius <> face/orbit [
									pos: pos * (face/orbit / radius) ; re-put on orbit
								]
								if angle < face/ang-min [
									pos: either face/k = "KS" [-57x-11][56x11] ; "hardcoded" to avoid rounding errors
									angle: face/ang-min
								]
								if angle > face/ang-max [
									pos: either face/k = "KS" [56x-11][-57x11] ; "hardcoded" to make it more stable
									angle: face/ang-max
								]
								;?? angle
							]
							action = 'up [
								face/k: none
							]
						]
						if find [down up over away] action [
							if face/k [
								face/effect/draw/(face/k): pos + 100x100
								switch face/k [
									"KH" [face/data/1/1: angle / 360]
									"KS" [face/data/1/2: min max 1e-10  ((angle - 100) / (260 - 100))  1 - 1e-10]
									"KL" [face/data/1/3: min max 1e-10  1 - ((angle - 100) / (260 - 100))  1 - 1e-10]
								]
								face/update_grads
								do-face face face/data/1
							]
						]
					]
				]
				with [
					data: copy/deep [[0 0 0] [0 0 0]] ; new and optional default
					k: none
					orbit: 88
					ang-min: 0
					ang-max: 360
					modify?: false
					update_grads: func [/local col draw rgb][
						col: copy data/1
						draw: effect/draw
						rgb: color-conv-ctx/hsl-to-rgb col
						draw/("new"): to-tuple-color rgb
						if not modify? [draw/("old"): draw/("new")]
						draw/("G")/4: second to-tuple-color color-conv-ctx/rgb-to-hsv rgb ; note the use of HSV instead of HSL
						draw/("D")/4: third to-tuple-color color-conv-ctx/rgb-to-hsv rgb
						col/2: 0
						draw/("S0"): to-tuple-color color-conv-ctx/hsl-to-rgb col
						col/2: 1
						draw/("S1"): to-tuple-color color-conv-ctx/hsl-to-rgb col
						col/2: data/1/2
						col/3: 0.50
						draw/("L.5"): to-tuple-color color-conv-ctx/hsl-to-rgb col
						face
					]
					update_knobs: func [/local angle pos][
						angle: data/1/1 * 360
						pos: rotate-point 0x-88 sine angle cosine angle
						effect/draw/("KH"): pos + 100x100

						angle: data/1/2 * (170 - 10) + 10
						pos: rotate-point -58x0 sine angle cosine angle 
						effect/draw/("KS"): pos + 100x100

						angle: negate data/1/3 * (260 - 100) + 10
						pos: rotate-point -58x0 sine angle cosine angle 
						effect/draw/("KL"): pos + 100x100
					]
					access: make ctx-access/data-number [
						set-face*: func [face value][
							if all [2 = length? value face/data = value] [exit]
							if face/data/1 = value [exit]
							face/data: copy/deep value
							face/update_grads
							face/update_knobs
						]
					]
				]
				[ ; action
					set-face box-sample color-conv-ctx/hsl-to-rgb face/data/1
				]
			return
			here: at
			across
			guide
			at here
			pad 37x0
			guide
			space 0x8
			style spin spin-number 70x22 50.0 low 0 high 100
			spin-1: spin 90.0 low 0 high 360 step 0.5 [update_sample]
			h3 "H" feel none
			return
			spin-2: spin 50.0 [update_sample]
			h3 "S" feel none
			return
			spin-3: spin 50.0 [update_sample]
			h3 "L" feel none
			do [append tab-chain reduce [spin-1/field spin-2/field spin-3/field]]
		]
	]

	update_all: func [/local comp mult rgb hsl old-hsl][
		rgb: box-sample/norm-color

		box-sample/set?: false ; avoid infinite loop and "bouncing"
		hsl: color-conv-ctx/rgb-to-hsl rgb
		foreach [face comp mult] reduce [
				ctx-hsl-g/spin-1 1 360 
				ctx-hsl-g/spin-2 2 100
				ctx-hsl-g/spin-3 3 100
				] [
			set-face face round/to hsl/(comp) * mult 0.01
		]
		set-face ctx-hsl-g/hsl-gizmo compose/deep [[(hsl)]]

		box-sample/set?: true
		foreach [face comp mult] reduce [
				ctx-rgb/gs-1 1 255
				ctx-rgb/gs-2 2 255
				ctx-rgb/gs-3 3 255
				ctx-rgb/spin-1 1 255
				ctx-rgb/spin-2 2 255
				ctx-rgb/spin-3 3 255
				] [
			set-face face rgb/(comp) * mult
		]
		
		set-face info-rgb box-sample/color
		do-face choice-conv none
	]

	svv/vid-face/color: snow ; background color of all windows ; FIXME: make this settable (light/dark)

	color-win: [
		styles color-styles
		origin 4x4
		panel-pal: panel snow [
			pal-mix: palette-mixer [set-face box-sample normalize-color value]
			pad 2x0

			box-sample: box start-color
				feel [
					engage: func [face action event][
						if action = 'up [set-face pal-mix compose [0x0 (face/color)] ]
					]
				]
				with [
					norm-color: none
					set?: true
					access: make object! [
						set-face*: func [face value /local comp col chg][;print [ "box-samp-set" face/norm-color]
							if not set? [exit]
							if value = face/norm-color [exit]
							face/norm-color: value
							do-face face face/norm-color
						]
						get-face*: func [face][
							face/norm-color
						]
					]
					append init [
						norm-color: normalize-color color
					]
				] 
				[ ; action function
					face/color: to-tuple-color face/norm-color
					show face
					update_all
				]
		]
		at 4x4
		panel-slides: panel snow [
			sliders-rgb: box with [pane: ctx-rgb/rgb/pane append init [size: ctx-rgb/rgb/size + (edge/size * 2)]]
			pad 25x0
			sliders-hsl-giz: box with [pane: ctx-hsl-g/hsl-giz/pane append init [size: ctx-hsl-g/hsl-giz/size + (edge/size * 2)]]
		]
		do [panel-pal/size: panel-slides/size]
		return
		space 4x4
		across
		btn 100 "Palette & Mixer..." with [data: "Color sliders..."] [
			value: face/data
			face/data: face/text
			face/text: value
			
			move color-lay/pane 1 ; switch between sliders and palette panels
			show color-lay
		] 
		pad 50x0
		btn 100 "OK" [result: box-sample/color hide-popup]
		btn 100 "Cancel" escape [hide-popup]
		return
		below
		at 262x200
		text 100 "RGB" bold center
		info-rgb: info "0.0.0" 100
		pad -40x0
		choice-conv: choice-btn 140x24 "hexadecimal" data ["hexadecimal" "CIELab" "CMY" "CMYK" "HSI" "HSL" "HSV" "HWB" "XYZ" "YCbCr" "YPbPr" "YUV"] [
			use [rgb col-space col] [
				rgb: box-sample/norm-color
				col-space: get-face face
				col: color-conv-ctx/(to-word append copy "rgb-to-" col-space) rgb
				set-face info-conv re-form-dec switch col-space [
					"hexadecimal" [mold col]
					"CIELab" [fry "_  _  _" scale-block col [1 0.01 1 0.01 1 0.01]]
					"HSL" [fry "_° _% _%" scale-block col [360 0.01 100 0.01 100 0.01]]
					"HSV" [fry "_° _% _%" scale-block col [360 0.01 100 0.01 100 0.01]]
					"HSI" [fry "_° _% _%" scale-block col [360 0.01 100 0.01 100 0.01]]
					"HWB" [fry "_° _% _%" scale-block col [360 0.01 100 0.01 100 0.01]]
					"CMY" [fry "_ / _ / _" scale-block col [100 1 100 1 100 1]]
					"CMYK" [fry "_ / _ / _ / _" scale-block col [100 1 100 1 100 1 100 1]]
					"XYZ" [fry "_  _  _" scale-block col [1 0.01 1 0.01 1 0.01]]
					"YCbCr" [fry "_  _  _" scale-block col [1 0.001 1 0.001 1 0.001]]
					"YPbPr" [fry "_  _  _" scale-block col [1 0.01 1 0.01 1 0.01]]
					"YUV" [fry "_  _  _" scale-block col [1 0.01 1 0.01 1 0.01]]
				]
				show info-conv
			]
		]
		info-conv: info "" 140

	]
	insert-event-func func [face event][
		if event/key = tab [
			if attempt [face: find tab-chain system/view/focal-face][
				do-face first face get-face first face
				face: first either event/shift [cycle/back face][cycle face]
				focus face
				return none
			]
		]
		if event/type = 'move [eat_events] ; speedup movement by avoiding following all events
		event
	]

	; main
		start-color: 148.128.108

		result: none
		color-lay: none

		set 'request_color func [
			"Requests a color value." 
			/color clr [tuple!] "Start with this color" ; FIXME: better use /with as name ?
			/offset xy [pair!] "Offset of requester window"
			/modify "Modify the given color"
			][
			if none? :color-lay [
				color-lay: layout color-win
			] 
			box-sample/norm-color: normalize-color any [clr start-color]
			do-face box-sample none
			ctx-hsl-g/hsl-giz/pane/1/modify?: modify
			result: none

			do pick [inform/title inform/title/offset] not offset color-lay "Choose a color" xy

			; restore defaults
			box-sample/norm-color: normalize-color start-color
			do-face box-sample none
			ctx-hsl-g/hsl-giz/pane/1/modify?: false
			result
		]

] ; color-req-ctx
] ; value?

do ; just comment this line to avoid executing examples
[
	if system/script/title = "Choose and convert colors" [;do examples only if script started by us

	;probe request-color/color red
	probe request_color
	probe request_color/color crimson
	probe request_color/modify
	probe request_color/modify/color crimson

	halt
] ; if title
] ; do