ranged switch

Richard Suchenwirth 2005-12-19 - As an example for custom control structures in Tcl, here is a range-aware lookalike to switch. A range (numeric or strings) can be given as from..to, and the associated scriptlet gets executed if the tested value lies inside that range. Like in switch, fall-through collapsing of several cases is indicated by "-", and "default" as final condition fires if none else did. Different from switch, numbers are compared by numeric value, no matter whether given as decimal, octal or hex.


 proc rswitch {value body} {
   set go 0
   foreach {cond script} $body {
      if {[regexp {(.+)\.\.(.+)} $cond -> from to]} {
           if {$value >= $from && $value <= $to} {incr go}
      } else {
          if {$value == $cond} {incr go}
      }
      if {$go && $script ne "-"} { #(2)
          uplevel 1 $script
          break
      }
   }
   if {$cond eq "default" && !$go} {uplevel 1 $script} ;#(1)
 }

Testing:

 % foreach i {0 1 2 3 4 5 6 7 8} {puts $i;rswitch $i {1 {puts yes} 2..5 {puts maybe} 6..8 {puts no}}}
 0
 1
 yes
 2
 maybe
 3
 maybe
 4
 maybe
 5
 maybe
 6
 no
 7
 no
 8
 no

Due to polymorphic comparison (numeric or string), this also works:^)

 % foreach i {A K c z 0 7} {
   puts $i;rswitch $i {A..Z {puts upper} a..z {puts lower} 0..9 {puts digit}}
 }
 A
 upper
 K
 upper
 c
 lower
 z
 lower
 0
 digit
 7
 digit
 % rswitch 0x2A {42 {puts magic} default {puts df}}
 magic

* Ok, that's useful stuff.. but what about multi-digit numbers? -- Sy / jrandomhacker.info e.g., using:

 rswitch 100 {A..Z {echo upper} a..z {echo lower} 0..999 {echo digit}}

RS Yup, my bug. ".." in regular expressions match any char, so the original version

      if {[regexp (.+)..(.+) $cond -> from to]} {

was over-eager - in 0..99, it matched "0." as from, and "9" as to. Fixed above, so multi-digit numbers work (and added a line for default treatment at #(1)). Another enhancement at #(2) is fall-through treatment (a - b - c ...} just like in switch. Thanks for testing!

JAK Try this version to allow the "alternate" switch syntax:

 proc rswitch {value args} {
   set go 0
   if {[llength $args] == 1 } {
        set body [concat $args]
   } else {
        set body [list $args]
   }
   foreach {cond script} [join $body] {
     if {[regexp {(.+)\.\.(.+)} $cond -> from to]} {
           if {$value >= $from && $value <= $to} {incr go}
      } else {
          if {$value == $cond} {incr go}
      }
      if {$go && $script ne "-"} { #(2)
          uplevel 1 $script
          break
      }
   }
   if {$cond eq "default" && !$go} {uplevel 1 $script} ;#(1)
 }

Sy adds:

Ok, so with the first rswitch I can do great things like:

 rswitch $variable {
   3..19 {# <perform action here>}
   20..30 {# <perform action here>}
 }

However, I cannot do this and have both items fire off:

 rswitch $variable {
   3..19 {# <perform action here>}
   15..19 {# <perform action here>}
 }

PWQ 17 Mar 06, My feeling is that having a regexp et al inside a control structure is not efficient. This is due to untcl like use of n...n, should be not push for a tcl like syntax of {min max}.

Also one note about comments within the code that uses a ranged switch:

 rswitch $variable {
   # This is not a good place for a comment
   3..19 {# <perform action here>;# In here is a good place for a comment}
   15..19 {# <perform action here>}
 }

RS: (1) Multiple evaluation: normal switch doesn't do that either

 switch a {a - b {puts hello} a - c {puts world} default {puts nix}}
 hello

But you might try just commenting out the break above... (2) Comments in Tcl are tricky sometimes. You are safe only if the # is at the first position where a command is expected, and no unbalanced braces till end-of-line... Original switch has the same feature:

 proc try x {
   switch -- $x {
      # This is not a comment
      a {puts hello}
      b {puts world}
   }
 }
 % try #
 invalid command name "This"
 % try is
 invalid command name "not"
 % try a
 invalid command name "comment"

As you can see, "#", "is", "a" are taken as cases, and the following word is the associated body.

 proc try x {
   switch -- $x {
      # {#This is a comment}
      a {puts hello}
      b {puts world}
   }
 }
 % try #

TR - A general approach would also include arbitrary expressions as 'patterns'. You can easily do things like

 set myVar 2.5
 switch 1 \
   [expr {$myVar<3 && $myVar>0}] {set res "smaller then 3, but positive"} \
   [expr {$myVar <= 0}]          {set res "smaller or equal zero"} \
   [expr {$myVar==3}]            {set res "equal 3"} \
   [expr {$myVar > 3}]           {set res "greater than 3"}
 puts "$myVar is $res"

Putting this into a nice little proc could look like this:

 proc exprSwitch {switches} {
        #
        # a switch command using 'expr'-essions instead of patterns:
        #
        # switches -> an even list consisting of:
        #   1. expressions to test
        #   2. bodies to execute, if expression is true
        #
        # Returns: the result of the evaluation of the body
        #
        set l [llength $switches] 
        if {$l % 2 != 0} {return -code error "exprSwitch: extra switch without body"}
        set  count 0
        foreach {expr body} $switches {
                incr count 2
                if {$expr eq "default" && $count == $l} {
                        return [uplevel 1 $body]
                }
                if {[uplevel 1 [list expr $expr]]} {return [uplevel 1 $body]}
        }
 }

and the above example would become:

 set myVar 2.5
 exprSwitch {
   {$myVar<3 && $myVar>0} {set res "smaller then 3, but positive"}
   {$myVar <= 0}          {set res "smaller or equal zero"}
   {$myVar==3}            {set res "equal 3"}
   {$myVar > 3}           {set res "greater than 3"}
 }
 puts "$myVar is $res"

This is quite handy if you have ranges of real numbers or more complicated expressions that need to be distinguished.

Lars H: Isn't that just if with less syntactic sugar? An alternative implementation is

  proc exprSwitch2 {switches} {
     set cmd ""
     foreach {expr body} $switches {lappend cmd elseif $expr then $body}
     uplevel 1 [lreplace $cmd 0 0 ::if]
  }

Arts and crafts of Tcl-Tk programming | Category Control Structure