select-case.red (old experimental dialected dispatch func)

select-case-tests.red

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

select-case.red

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]

	]

]