Skip to content

Instantly share code, notes, and snippets.

@toomasv
Last active June 23, 2020 05:29
Show Gist options
  • Save toomasv/097b92820f3e7a9d2bbf97dbd2cb304a to your computer and use it in GitHub Desktop.
Save toomasv/097b92820f3e7a9d2bbf97dbd2cb304a to your computer and use it in GitHub Desktop.
Mimick range and bound syntax
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
]
]
]
]
@toomasv
Copy link
Author

toomasv commented May 25, 2020

(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

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment