Skip to content

Instantly share code, notes, and snippets.

@greggirwin
Created November 4, 2020 18:19
Show Gist options
  • Save greggirwin/5020d92e4e8f3785b307785cacdab5ce to your computer and use it in GitHub Desktop.
Save greggirwin/5020d92e4e8f3785b307785cacdab5ce to your computer and use it in GitHub Desktop.
select-case.red (old experimental dialected dispatch func)
Red []
do %select-case.red
test: func [val] [print mold :val]
a: 15
test select-case a [15 [OK]]
test select-case a [1 [a] 5 [b] 15 [OK]]
test select-case a [1 to 5 [a] 6 to 14 [b] 15 [OK]]
test select-case a [1 to 5 [a] 6 to 14 [b] 15 to 25 [OK]]
test select-case a [1 to 5 [a] 15 to 25 [OK] 6 to 14 [c]]
test select-case a [1 2 3 4 5 [a] 6 9 11 14 [b] 15 18 to 25 [OK]]
test select-case a [
case 1 [a]
case 5 [b]
case is > 10 [OK]
]
test select-case a [1 [a] 5 [b] is lesser? 18 [OK]]
test select-case a [
to 15 [OK]
5 [b]
is lesser? 18 [c]
]
; test select-case a [
; < 15 [a]
; 5 [b]
; is lesser? 18 [OK]
; ]
test select-case a [
is < 15 [a]
5 [b]
is lesser? 18 [OK]
]
test select-case a [from 1 to 5 [a] from 6 to 14 [b] from 15 to 25 [OK]]
test select-case a [to 15 [OK]]
test select-case/default 15 [to 14 [a]][OK]
test select-case 0:15:0 [
case from 0:0:1 to 0:5:0 [a]
case from 0:6:0 to 0:14:0 [b]
case is > 1:0:0 [c]
]
print {The above test returns NONE because the value isn't handled by any case.
So the result is actually OK. :)
}
;print "-"
test select-case 0:15:0 [
case 0:0:1 to 0:5:0 [a]
0:6:0 to 0:14:0 [b]
case else [OK]
]
;test select-case 15 [[3 * 5 =] [OK]]
test select-case a [[find [3 5 9 15 18] value] [OK]]
valid-data?: func [value] [value = 15]
test select-case a [[valid-data? value] [OK]]
test select-case a [:valid-data? [OK]]
test select-case a [[valid-data? value] [OK] is < 10 [b] is > 10 [c]]
print "<"
test select-case a [< 10 [a] > 10 [OK] [valid-data? value] [c]]
; Differing rule for get-word syntax isn't good. Need consistency I think.
test select-case a [:negative? [aa] lesser? 10 [a] greater? 10 [OK] [not valid-data? value] [c]]
print ">"
print ""
test select-case/default "James" ["J" to "K" [OK]] [FAIL]
test select-case/default "James" [between "J" and "K" [OK]] [FAIL]
test select-case/default "James" [between "J" "K" [OK]] [FAIL]
print ""
foreach val reduce [-1 2 6 15 16 21 23 25 24 26 1001 250 none] [
res: select-case val [
;:negative? value [negative]
:negative? [negative]
case is < 5 [< 5]
6 to 10 [6 to 10]
between 11 and 15 [11 to 15]
from 16 to 20 [16 to 20]
21 23 25 [one-of 21 23 25]
[find [22 24] value] [found in [22 24]]
between 26 100 [26 to 100]
case is > 1000 [> 1000]
;#[none] [none]
200 #[none] [implied val** none]
case else [else]
]
print [val tab res]
]
halt
Red []
select-case-ctx: context [
between?: func [
"Returns TRUE if value is between the two boundaries, as an open-right interval"
value
bound-1
bound-2
][
to logic! all [
value >= min bound-1 bound-2
value < max bound-1 bound-2
]
]
;between? 10 0 20
;between? 100 0 20
;TBD - need to allow for paren's in cases
set 'select-case func [
"Selects a choice and returns the block that follows it"
[throw]
value "Value to use in condition tests"
cases [block!] "Dialected condition-block pairs" ;"Block of cases to search [any [spec stmts]]"
/default "Specify a default block, if no conditions are true"
def "Default block to return"
/local
spec-rules result set-result
from* to* val* val** op* spec block ; parse vars
][
set-result: does [result: block] ;[if not result [result: block]]
spec-rules: [
some [
(val**: none)
['else end] (set-result)
| [
opt 'from set from* any-type! 'to set to* any-type!
| 'between set from* any-type! opt 'and set to* any-type!
] (
attempt [if between? value from* to* [set-result]]
)
; Should we support both TO and THRU, with < and <= semantics respectively?
| 'to set to* any-type! (
attempt [if between? value make to* none to* [set-result]]
)
| 'is set op* word! set val* any-type! (
attempt [if do get op* value val* [set-result]]
)
| set op* get-word! opt 'value ( ; allow both "negative? []" and "negative? value []"
attempt [if do get op* value [set-result]]
)
; | set op* paren! (
; if compose op* [set-result]
; )
| set op* block! (
;if do join op* value [set-result]
attempt [if do bind op* 'value [set-result]]
)
; | set val* any-type! (
; if equal? val* value [set-result]
; )
; This is a bit odd, and could be done differently. We check for
; an optional second value (val**) to support the op/action/function
; case. If it's just values, we have to check both of them in the
; other case.
| set val* any-type! opt [set val** any-type!] (
either all [word? :val* find [op! action! function!] type?/word get val* val**] [
if do get val* value val** [set-result]
][
if equal? val* value [set-result]
if all [val** equal? val** value] [set-result]
]
)
]
]
; This is overhead, but allows the user to use 'value in their 'cases
; block for convenience.
;cases: bind/copy cases 'value
if not parse cases [
any [
opt 'case
[set spec block! (spec: compose/deep [[(spec)]]) | copy spec to block!]
set block block!
(if not result [parse spec spec-rules])
]
] [return none] ; TBD throw error
either result [result] [def]
]
]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment