Archive version of: simple-spin-number-style.r ... version: 3 ... luce80 30-Aug-2020

Amendment note: fixes, add scroll-wheel support and resizing || Publicly available? Yes

REBOL [
	title: "Spin-number style example"
	file: %simple-spin-number-style.r
	author: "Marco Antoniazzi"
	email: [luce80 AT libero DOT it]
	date: 23-08-2020
	version: 0.8.0
	Purpose: {A quick way to add a simple spin-number to VID GUIs}
	comment: {You are strongly encouraged to post an enhanced version of this script}
	History: [
		0.0.1 [10-05-2020 "Started"]
		0.0.2 [14-05-2020 "Some fixes"]
		0.0.3 [30-07-2020 "ADD: re-form-dec"]
		0.0.4 [30-07-2020 "ADD: shift and ctrl multipliers"]
		0.0.5 [11-08-2020 "FIX: removed do-face from set-face"]
		0.0.6 [20-08-2020 "FIX: returned args position for 'integer"]
		0.0.7 [22-08-2020 "FIX: text input, FIX: face edge, ADD: scroll-wheel support"]
		0.8.0 [23-08-2020 "ADD: resizing"]
	]
	Category: [util vid view]
	library: [
		level: 'intermediate
		platform: 'all
		type: 'how-to
		domain: [gui vid]
		tested-under: [View 2.7.8.3.1]
		support: none
		license: none
		see-also: none
	]
]

stylize/master [
	arrow-btn: btn ; should be a button that acts only on mouse down
		feel [
			engage-super: :engage
			engage: func [face action event][
				engage-super face action event
				case [
					action = 'down [face/start: now/time/precise face/rate: 0:0:0.5 face/act face face/data]
					action = 'up [face/rate: none]
					event/type = 'time [face/rate: either (now/time/precise - face/start) < 0:0:1.5 [0:0:0.1][0:0:0.02] face/act face face/data]
				]
				show face ; update timer
			]
		]
		with [
			start: none
			act: none
			words: [up right down left [new/data: first args args]]
			resize: func [new-size [pair!]][
				size: new-size
				effect/draw/translate: size / 2
				effect/draw/scale: size / 4
			]
			append init [
				act: :action
				action: none ; use none (and "act" instead) to avoid doing action on mouse up
				append effect compose/deep [draw [
					pen none fill-pen (font/color)
					translate (size / 2)
					scale (size / 4)
					rotate (select [right -90 down 0 left 90 up 180] data)
					polygon -1x-1 1x-1 0x1 
				]]
			]
		]
		
	spin-number: box
		feel [
			engage: func [face action event /local factor][
				if find [key scroll-line scroll-page] event/type [
					factor: case [
						event/shift [10]
						event/control [face/step]
						'else [1]
					]
					switch event/key [
						up right [set-face face face/data + factor do-face face none]
						down left [set-face face face/data - factor do-face face none]
					]
					switch event/type [
						scroll-line scroll-page [set-face face face/data - (factor * sign? event/offset/y) do-face face none]
					]
				]
			]
		]
		with [
			style: 'spin-number
			size: 60x20
			low: 0 high: 100 step: 1 ; FIXME: I wish to use "min" and "max" instead of "low" and "high" that are ugly but they would clash with the functions
			this: none ; self
			field: arrow-up: arrow-down: none
			faces-moves: faces-dims: frac-y: 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
				]
				integer [flag-face new 'integer args]
			]
			access: make ctx-access/data-number [
				re-form-dec: func ["Convert scientific to decimal notation. (modifies)"
					number [string!] /local digit pos end sign exp
					][
					sign: 0
					digit: charset "0123456789"
					parse/all number [
						opt ["-" (sign: 1)] any digit pos: opt "." any digit 
						[
							end: "E-" (if pos <> end [remove pos end: back end] pos: remove/part end 2)
							:pos copy exp some digit end: (exp: do exp remove/part pos end)
						]
						| (return number) ; if exponent not found abort
					]
					insert/dup insert skip number sign "0." "0" exp - 1
					number
				]
				set-face*: func [face value [number!]][
					if face/data = value [exit] ; check _before_ the constraints
					value: to decimal! round/to value face/step
					value: min max face/low value face/high
					if flag-face? face 'integer [value: round value]
					face/data: value
					face/field/text: re-form-dec form value
					face/field/old-text: copy face/field/text ; store old value to be able to restore it if an error occurs
					;do-face face value ; in some situations this can cause an infinite loop
				]
				resize-face*: func [face [object!] size [pair!] x [logic!] y [logic!]][
					face/resize size
				]
			]
			resize: func [new-size [pair!] /local siz][
				siz: new-size - size
				foreach [face pair] faces-moves [face/offset: face/offset + (siz * pair)]
				foreach [face pair] faces-dims [face/size: face/size + (siz * pair)]
				; adjust arrows (frac-y is used to compensate for rounding errors when converting to pair!)
				frac-y/1: frac-y/1 + (siz/y * .5)
				arrow-down/offset/y: frac-y/1
				frac-y/2: frac-y/2 + (siz/y * .5)
				arrow-up/resize as-pair arrow-up/size/x frac-y/2
				frac-y/3: frac-y/3 + (siz/y * .5)
				arrow-down/resize as-pair arrow-down/size/x frac-y/3
			]

			append init [
				this: self
				if size/x < 0 [size/x: 60]
				if size/y < 0 [size/y: 20]
				size: size - edge-size? this
				data: any [data low]
				pane: layout/tight [
					space 0x0 below
					field: field "0" (as-pair size/x - 20 size/y)  white white edge [size: 1x1]
						with [
							old-text: none
							feel: make ctx-text/edit [
								engage-super: :engage
								engage: func [face action event /local factor][
									engage-super face action event
									; similar to spin-number feel but not equal
									if any [
											find [up down] event/key
											find [scroll-line scroll-page] event/type
										][
										do-face face face/text ; update this/data
										factor: case [
											event/shift [10]
											event/control [this/step]
											'else [1]
										]
										switch event/key [
											up [set-face this this/data + factor do-face this this/data]
											down [set-face this this/data - factor do-face this this/data]
										]
										switch event/type [
											scroll-line scroll-page [set-face this this/data - (factor * sign? event/offset/y) do-face this this/data]
										]
										; update caret
										focus/no-show face
										unlight-text
										show face
									]
								]
							]
						]
						[; action
							if none? attempt [value: do face/text] [face/text: face/old-text focus face exit]
							face/para/scroll/x: 0 ; restore position for long text
							set-face this value
							do-face this value
						]
					return
					style arrow-btn arrow-btn (as-pair 20 size/y / 2) [
						focus this
						if not number? value [exit]
						value: step * value + get-face this
						set-face this value
						do-face this value
					]
					arrow-up: arrow-btn 'up with [append init [data: 1]]
					arrow-down: arrow-btn 'down with [append init [data: -1]]
				]
				size: pane/size + edge-size? this
				faces-moves: reduce [
					arrow-up 1x0
					arrow-down 1x0
				]
				faces-dims: reduce [
					field 1x1
					this/pane 1x1
					this 1x1
				]
				frac-y: reduce [arrow-down/offset/y arrow-up/size/y arrow-down/size/y]
				user-data: data
				data: none ; force refresh in set-face
				set-face this user-data
			]
		]

]
do ; just comment this line to avoid executing examples
[
	if system/script/title = "Spin-number style example" [;do examples only if script started by us

	insert-event-func func [face event /local siz][
		if event/type = 'active [
			face: event/face
			face/data: face/size          ; store old size
		]
		if event/type = 'resize [
			face: event/face
			siz: face/size - face/data    ; compute size difference
			face/data: face/size          ; store new size

			resize-faces face siz
			show face
		]
		event
	]
	resize-faces: func [window siz [pair!]] [
		foreach [face x y w h] [
			sp-1  0 0   1 0.5
			sp-2  0 0.5 1 0.5
			t-1   1 0   0 0
			t-2   1 0.5 0 0
			h-1   0 1   0 0
			h-2   0 1   0 0
			][
			frac-dims/(face)/x: frac-dims/(face)/x + (siz/x * x)
			frac-dims/(face)/y: frac-dims/(face)/y + (siz/y * y)
			set in get face 'offset as-pair frac-dims/(face)/x frac-dims/(face)/y
			frac-dims/(face)/w: frac-dims/(face)/w + (siz/x * w)
			frac-dims/(face)/h: frac-dims/(face)/h + (siz/y * h)
			either in get face 'resize [
				do in get face 'resize as-pair frac-dims/(face)/w frac-dims/(face)/h
			][
				set in get face 'size as-pair frac-dims/(face)/w frac-dims/(face)/h
				resize-face get face as-pair frac-dims/(face)/x frac-dims/(face)/y
			]
		]
	]

	win: layout [
		across
		sp-1: spin-number 50.0 low 0 high 100 step 0.5
		t-1: text "min 0.0 max 100.0 step 0.5" 
		return
		; note that even if this spinner displays only integers it must be initialized with a decimal!
		sp-2: spin-number 80 2.0 low 0 high 1000 step 1 integer
		t-2: text "min 0 max 1000 step 1 integer" 
		return
		;h3 "Use also <Shift> and <Ctrl> to modify the step"
		h-1: h3 "Use also (qualified) arrows"
		return
		pad 0x-10
		h-2: h3 "Use also (qualified) scroll-wheel"
		return
	]

	; store single faces dimensions in a block
	; see: http://www.rebol.org/view-script.r?script=simple-vid-resizing.r
	; for a better, general implementation
	frac-dims: compose/deep [
		sp-1 [x (sp-1/offset/x) y (sp-1/offset/y) w (sp-1/size/x) h (sp-1/size/y)]
		sp-2 [x (sp-2/offset/x) y (sp-2/offset/y) w (sp-2/size/x) h (sp-2/size/y)]
		t-1 [x (t-1/offset/x) y (t-1/offset/y) w (t-1/size/x) h (t-1/size/y)]
		t-2 [x (t-2/offset/x) y (t-2/offset/y) w (t-2/size/x) h (t-2/size/y)]
		h-1 [x (h-1/offset/x) y (h-1/offset/y) w (h-1/size/x) h (h-1/size/y)]
		h-2 [x (h-2/offset/x) y (h-2/offset/y) w (h-2/size/x) h (h-2/size/y)]
	]

	view/options win 'resize

	] ; if title
]