Algebraic data types: Difference between revisions
Content added Content deleted
Underscore (talk | contribs) (Omitted Perl and Python.) |
(Added Tcl implementation) |
||
Line 150:
T (B,a,y,b)
end
</lang>
=={{header|Tcl}}==
{{trans|Haskell}}
Tcl doesn't have algebraic types built-in, but they can be simulated using tagged lists, and a custom pattern matching control structure can be built:
<lang tcl># From http://wiki.tcl.tk/9547
package require Tcl 8.5
package provide datatype 0.1
namespace eval ::datatype {
namespace export define match matches
namespace ensemble create
# Datatype definitions
proc define {type = args} {
set ns [uplevel 1 { namespace current }]
foreach cons [split [join $args] |] {
set name [lindex $cons 0]
set args [lrange $cons 1 end]
proc $ns\::$name $args [format {
lreplace [info level 0] 0 0 %s
} [list $name]]
}
return $type
}
# Pattern matching
# matches pattern value envVar --
# Returns 1 if value matches pattern, else 0
# Binds match variables in envVar
proc matches {pattern value envVar} {
upvar 1 $envVar env
if {[var? $pattern]} { return [bind env $pattern $value] }
if {[llength $pattern] != [llength $value]} { return 0 }
if {[lindex $pattern 0] ne [lindex $value 0]} { return 0 }
foreach pat [lrange $pattern 1 end] val [lrange $value 1 end] {
if {![matches $pat $val env]} { return 0 }
}
return 1
}
# A variable starts with lower-case letter or _. _ is a wildcard.
proc var? term { string match {[a-z_]*} $term }
proc bind {envVar var value} {
upvar 1 $envVar env
if {![info exists env]} { set env [dict create] }
if {$var eq "_"} { return 1 }
dict set env $var $value
return 1
}
proc match args {
#puts "MATCH: $args"
set values [lrange $args 0 end-1]
set choices [lindex $args end]
append choices \n [list return -code error -level 2 "no match for $values"]
set f [list values $choices [namespace current]]
lassign [apply $f $values] env body
#puts "RESULT: $env -> $body"
dict for {k v} $env { upvar 1 $k var; set var $v }
catch { uplevel 1 $body } msg opts
dict incr opts -level
return -options $opts $msg
}
proc case args {
upvar 1 values values
set patterns [lrange $args 0 end-2]
set body [lindex $args end]
set env [dict create]
if {[llength $patterns] != [llength $values]} { return }
foreach pattern $patterns value $values {
if {![matches $pattern $value env]} { return }
}
return -code return [list $env $body]
}
proc default body { return -code return [list {} $body] }
}
</lang>
We can then code our solution similar to Haskell:
<lang tcl>
datatype define Color = R | B
datatype define Tree = E | T color left val right
# balance :: Color -> Tree a -> a -> Tree a -> Tree a
proc balance {color left val right} {
datatype match $color $left $val $right {
case B [T R [T R a x b] y c] z d -> { T R [T B $a $x $b] $y [T B $c $z $d] }
case B [T R a x [T R b y c]] z d -> { T R [T B $a $x $b] $y [T B $c $z $d] }
case B a x [T R [T R b y c] z d] -> { T R [T B $a $x $b] $y [T B $c $z $d] }
case B a x [T R b y [T R c z d]] -> { T R [T B $a $x $b] $y [T B $c $z $d] }
case col a x b -> { T $col $a $x $b }
}
}
# insert :: Ord a => a -> Tree a -> Tree a
proc insert {x s} {
datatype match [ins $x $s] {
case [T _ a y b] -> { T B $a $y $b }
}
}
# ins :: Ord a => a -> Tree a -> Tree a
proc ins {x s} {
datatype match $s {
case E -> { T R E $x E }
case [T col a y b] -> {
if {$x < $y} { return [balance $col [ins $x $a] $y $b] }
if {$x > $y} { return [balance $col $a $y [ins $x $b]] }
return $s
}
}
}
</lang>
Line 158 ⟶ 268:
{{Omit from|Perl}}
{{Omit from|Python}}
| |||