Initial data commit

Task/Algebraic-data-types/Tcl/algebraic-data-types-1.tcl

@@ -0,0 +1,70 @@
+# 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] }
+}

Task/Algebraic-data-types/Tcl/algebraic-data-types-2.tcl

@@ -0,0 +1,30 @@
+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
+        }
+    }
+}