day 5 tcl solution

day05/sol.tcl

@@ -0,0 +1,79 @@
+#!/usr/bin/env tclsh
+source ../prelude.tcl
+
+proc solve input {
+    must_regexp {^seeds: ([\d ]+)$} [gets $input] _ seeds
+    gets $input ;# blank line
+    while {! [eof $input]} {
+        must_regexp {^([a-z\-]+) map:$} [gets $input] line name
+        parse_map $name $input
+    }
+    set locs [lmap s $seeds {seed2loc $s 1}]
+    foreach s $seeds l $locs {
+        puts "$s => $l"
+    }
+    puts "-"
+    set locs {}
+    foreach {s n} $seeds {
+        set l [seed2loc $s $n]
+        puts "$s $n => $l"
+        lappend locs [lmap {a b} $l {set a}]
+    }
+    puts [min {*}[join $locs]]
+}
+
+proc seed2loc {seed count} {
+    set r [list $seed $count]
+    foreach name {
+            seed-to-soil
+            soil-to-fertilizer
+            fertilizer-to-water
+            water-to-light
+            light-to-temperature
+            temperature-to-humidity
+            humidity-to-location
+    } {
+        set r [join [lmap {a b} $r {lookup $name $a $b}]]
+    }
+    return $r
+}
+
+proc parse_map {name input} {
+    set m {}
+    while {[gets $input line] >= 0} {
+        if {$line eq ""} break
+        lappend m $line
+    }
+    set ::map($name) [join $m]
+    puts "$name => $m"
+}
+
+proc lookup {name a n} {
+    set r {}    ;# (start count)
+    set used {} ;# (start end)
+    set end [expr {$a+$n}]
+    foreach {dst src count} $::map($name) {
+        if {$end <= $src || $src+$count <= $a} continue ;# no overlap
+        set b [expr {max($a,$src)}]
+        set c [expr {min($end,$src+$count)}]
+        lappend used $b $c
+        lappend r [expr {$b-$src+$dst}] [expr {$c-$b}]
+    }
+    # unused values translate to themselves
+    set used [lsort -integer $used]
+    #puts "$a $end used: $used"
+    foreach {b c} $used {
+        if {$a < $b} {
+            lappend r $a [expr {$b-$a}]
+        } elseif {$a > $b} {
+            error "a > b: $a > $b"
+        }
+        set a $c
+    }
+    if {$a < $end} {
+        lappend r $a [expr {$end-$a}]
+    }
+    return $r
+}
+
+solve stdin

prelude.tcl

@@ -16,3 +16,8 @@ proc lmul {list} {
     return $p
 }
 
+proc must_regexp args {
+    if {! [uplevel [concat regexp $args]]} {
+        error "regexp failed"
+    }
+}