Mimick range and bound syntax

range-pre-load.red

Red [
	Description: "Pre-load to mimic range/bounds syntax"
	Date: 22-May-2020
	Author: @toomasv
]
context [
	default-start: func [stop step][
		case [
			any [percent? stop     percent? :step][1%]
			any [pair?    stop     pair?    :step][1x1]
			any [float?   stop     float?   :step][1.0]
			any [date?    stop     date?    :step][now/date]
			any [time?    stop     time?    :step][now/time]
			any [char?    stop     char?    :step][#"A"]
			any [tuple?   st: stop tuple?   st: :step][
				to-tuple append/dup copy "1" ".1" -1 + length? st
			]
			true [1]
		]
	]
	set 'range function [stop /from start /by step][
		index: 1
		case/all [
			block? :start [index: start/1 start: none]
			not start [start: default-start stop :step]
			all [not block? stop number? :step negative? :step] [
				start: either percent? :step [
					to-percent (stp: to-float stop) - round/down/to stp - to-float start to-float step
				][
					stop - round/down/to stop - start step
				]
				step: absolute step
			]
			block? :step [if not parse step [some scalar!][step: function [] step]]
			not :step [
				step: pick [1% 1] to-logic any [percent? stop percent? start]
			]
			all [not function? :step zero? step] [cause-error 'user 'message ["Range doesn't advance!"]]
			start = stop [return start]
			not block? stop [comp: get cmp: pick either function? :step [[<= >=]][[> <]] start < stop]
		]
		op: get pick [+ -] to-logic any [
			all [not block? stop start <= stop any [not number? :step positive? step]]
			all [not block? stop start > stop all [number? :step negative? step]]
			block? stop
		]
		value: start
		out: collect [
			either function? :step [
				bind body-of :step :range
				;probe reduce [value cmp stop]
				while [
					value: step
					either block? stop [
						stop/1 >= index
					][
						value comp stop
					]
				][
					keep/only value
					index: index + 1
				]
			][
				;probe reduce [value cmp stop]
				until [
					keep value
					value: value op step
					index: index + 1
					either block? stop [
						stop/1 < index
					][
						value comp stop
					]
				]
			]
		]
		out
	]

	set 'sequence function [/to stop /from start /by step][
		index: 1
		;probe reduce [start :step stop]
		case/all [
			block? :start [index: start/1 start: none] ;if start is block!, it contains starting index 
			not start [start: default-start stop :step]
			all [stop not block? stop number? :step negative? :step] [
				start: either percent? :step [
					to-percent (stp: to-float stop) - round/down/to stp - to-float start to-float step
				][
					stop - round/down/to stop - start step
				]
			]
			block? :step [if not parse step [some scalar!][step: function [] step]]
			not :step [
				step: pick [1% 1] to-logic any [percent? stop percent? start]
			]
			all [not function? :step zero? :step] [
				cause-error 'user 'message ["Range doesn't advance!"]
			]
			good-stop: all [stop not block? stop] [comp: pick [>= <=] stop >= start]
		]
		op: pick [+ -] to-logic any [
			all [good-stop start <= stop any [not number? :step positive? step]]
			all [good-stop start > stop all [number? :step negative? step]]
			not stop
			block? stop
		]
		
		either function? :step [
			fn: none
			stp: load mold :step
			context compose/only/deep [
				step: (stp/1) (stp/2) (stp/3)
				value: (start)
				index: (index)
				start: (start) 
				stop: (stop)
				set 'fn func [/reset /ctx /local val][
					either reset [
						index: (index) value: start 
					][
						value: either all [
							value
							val: step
							any [
								not stop 
								either block? stop [
									stop/1 >= index     ;If stop is block, it contains index to stop at
								][
									stop (comp) val
								]
							]
						] [also val index: index + 1][none]
					]
				]
			]
			:fn
		][
			function [/reset] compose/only/deep [
				value: [(start)] start: (start) step: (step) stop: (stop) index: [(index)]
				either reset [
					index: [(index)] value/1: start 
				][
					also first value   value/1: either all [
						value/1 
						val: value/1 (op) step
						index/1: index/1 + 1
						any [
							not stop 
							either block? stop [
								;probe reduce [stop index]
								stop/1 >= index/1
							][
								stop (comp) val
							]
						]
					] [val][none]
				]
			]
		]
	]

	set 'inbounds func [bound1 bound2 value /scope][
		if scope [bound2: bound1 + bound2] 
		min max bound1 bound2 max min bound1 bound2 value
	]
	
	set 'between? func [bound1 bound2 value /scope][
		if scope [bound2: bound1 + bound2] 
		all [value >= min bound1 bound2 value <= max bound1 bound2]
	]

	system/lexer/pre-load: function [src part][
		ws: charset " ^-^/" 
		ws+: [some ws] 
		non: union ws charset {{}"[]|} ;"
		digit: charset "0123456789" 
		alpha: charset [#"A" - #"Z" #"a" - #"z"]
		alnum: union union alpha digit charset "-"
		word: [alpha any alnum]
		char: [{#"} ["^^(" some digit ")" | opt #"^^" skip] {"}]
		int: [opt #"-" some digit]
		num: [int opt [#"." some digit] opt #"%"]
		sym: complement non
		symb: [char | some [not [3 #"." | 2 #"."] sym]]
		idx: [#"[" some digit #"]"]
		sep: charset ".-/"
		is-time?: func [val][parse val [int some [#":" int]]]
		is-date?: func [val][parse val [some digit sep [some digit | some alpha] sep some digit]]
		parse src [
			any [
			   {"..."} 
			|  (d1: d2: d3: none) change [
					opt [copy d1 [idx | symb]] "..." 
					opt [copy d2 [idx | symb]] 
					opt [#"|" (d3: yes)];copy d3 symb]
				] (
				fn: copy "sequence" args: clear [] 
				case/all [
					d1 [append fn "/from" append args d1]
					d2 [append fn "/to" append args d2]
					d3 [append fn "/by"]; append args d3]
				] 
				;probe reduce [d1 d2 d3]
				rejoin [fn " " form args " "]
			  )
			|  (d1: d2: d3: none) change [
					opt [copy d1 [idx | symb]] ".." 
					copy d2 [idx | symb] 
					opt [#"|" (d3: yes)];copy d3 symb]
				] (
				fn: copy "range" args: clear [] 
				case/all [
					d1 [append fn "/from" append args d1]
					d3 [append fn "/by"] ;append args d3]
				] 
				rejoin [fn " " d2 " " form args " "]
			  ) 
			| (d1: d2: d3: none) change [
					#"|" copy d1 symb  ws+ 
					copy d2 symb ws+
					copy d3 symb #"|" 
				] (
					rejoin ["inbounds " d1 " " d2 " " d3]
			  ) 
			| (d1: d2: d3: none) change [
					#"|" copy d1 symb  ws+ 
					copy d2 symb #"|" 
					copy d3 symb
				] (
					rejoin ["between? " d1 " " d2 " " d3]
			  ) 
			| (d1: none) change [#"|" copy d1 [num | word] #"|"] (rejoin ["absolute " d1])
			| skip
			]
		]
	]
]

(Beware, as string contents are not currently excluded from parsing, it may give weird results if similar syntax appears in strings.)

Examples for range:

>> 5..10
== [5 6 7 8 9 10]

>> ..10
== [1 2 3 4 5 6 7 8 9 10]

>> ..10|2
== [1 3 5 7 9]

>> ..10|-2                                 ;Negative step matches tail
== [2 4 6 8 10]

>> 10..1                                   ;Descending
== [10 9 8 7 6 5 4 3 2 1]

>> a: -5 b: 3 c: 2 a..b|c                  ;Symbolic args
== [-5 -3 -1 1 3]

>> ..5%
== [1% 2% 3% 4% 5%]

>> 3%..8.5%|1.5%
== [3% 4.5% 6% 7.5%]

>> 10:00..11:00|00:10
== [10:00:00 10:10:00 10:20:00 10:30:00 10:40:00 10:50:00 11:00:00]

>> ..30-May-2020
== [25-May-2020 26-May-2020 27-May-2020 28-May-2020 29-May-2020 30-May-2020]

>> #"a"..#"f"
== [#"a" #"b" #"c" #"d" #"e" #"f"]

>> ..#"F"
== [#"A" #"B" #"C" #"D" #"E" #"F"]

>> #"0"..#"9"
== [#"0" #"1" #"2" #"3" #"4" #"5" #"6" #"7" #"8" #"9"]

>> 10x10..20x20
== [10x10 11x11 12x12 13x13 14x14 15x15 16x16 17x17 18x18 19x19 20x20]

>> ..5.5.5
== [1.1.1 2.2.2 3.3.3 4.4.4 5.5.5]

;Indexes and functions
>> f: does [value + index] ..10|:f          ; funcs are given by name only
== [2 4 7]

>> f: does [value + index] ..[10]|:f        ;block exposes index -- i.e. "until index 10"
== [2 4 7 11 16 22 29 37 46 56]

>> f: does [index ** 2] ..[10]|:f
== [1 4 9 16 25 36 49 64 81 100]

>> f: does [index ** 2] [5]..[10]|:f        ;Can also be started from given index
== [25 36 49 64 81 100]

>> f: does [2 ** index] ..[10]|:f
== [2 4 8 16 32 64 128 256 512 1024]

;As functions do not have arguments, we can further simplify by giving function's body only
>> f: [seed: [0 1] also seed/1 seed/2: sum reverse seed] ..[10]|:f   ;Fibonacci
== [0 1 1 2 3 5 8 13 21 34]

;To use blocks (or other series) as values
>> f: [val: [0] also copy val append/only val index ** 2] ..[6]|:f
== [[0] [0 1] [0 1 4] [0 1 4 9] [0 1 4 9 16] [0 1 4 9 16 25]]

;And function body can follow |
>> ..[6]| [val: "a" also copy val append val (last val) + 1]
== ["a" "ab" "abc" "abcd" "abcde" "abcdef"]

Examples for sequence:

>> a: 3...6 ()
>> a
== 3
>> a
== 4
>> a
== 5
>> a
== 6
>> a
== none

>> a: ...10 while [b: a][prin [b ""]]
1 2 3 4 5 6 7 8 9 10 

>> a: ...10|2 while [b: a][prin [b ""]]
1 3 5 7 9 

>> a: ...10|-2 while [b: a][prin [b ""]] 
2 4 6 8 10 

>> a: ... loop 8 [prin [a ""]]
1 2 3 4 5 6 7 8 

>> a: 10:00...|00:15 loop 8 [prin [a ""]]
10:00:00 10:15:00 10:30:00 10:45:00 11:00:00 11:15:00 11:30:00 11:45:00 

>> a: ... loop 8 [prin [2 ** a ""]]
2 4 8 16 32 64 128 256 

>> f: does [2 ** index] a: ...|:f loop 8 [prin [a ""]]
2 4 8 16 32 64 128 256 

>> f: does [2 ** index] a: ...300|:f while [b: a][prin [b ""]]
2 4 8 16 32 64 128 256 

>> f: does [2 ** index] a: ...[8]|:f while [b: a][prin [b ""]]
2 4 8 16 32 64 128 256 

>> f: [val: [0] also copy val append val index ** 2] a: ...|:f ()
>> loop 11 [probe a]
[0]
[0 1]
[0 1 4]
[0 1 4 9]
[0 1 4 9 16]
[0 1 4 9 16 25]
[0 1 4 9 16 25 36]
[0 1 4 9 16 25 36 49]
[0 1 4 9 16 25 36 49 64]
[0 1 4 9 16 25 36 49 64 81]
[0 1 4 9 16 25 36 49 64 81 100]
== [0 1 4 9 16 25 36 49 64 81 100]

And small application:

f: does [round/to sine 18 * index .01] 
a: ...|:f
x: 0 view [
    box 500x110 
    draw [translate 0x50 pen gray] 
    rate 10 
    on-time [
        x: x + 5 
        append face/draw reduce ['line as-pair x 0 as-pair x 50 * a]
    ]
    on-down [face/rate: pick reduce [none 10] to-logic face/rate]
]

Additionally, playing with absolute, bounds-check and forcing into bounds:

>> |-5|
== 5
>> |345 678|321
== none
>> |345 678|675
== true
>> |20x20 40x60 50x50|
== 40x50
>> a: 20x20 c: 50x50 b: 40x60 b: |a b c|
== 40x50
>> |10:00 11:00:05 11:00|
== 11:00:00