Build a solver for the "N balls on a scale" problem
Tcl, 455 426

proc weight n {
   set num [expr {int(log($n*2-1)/log(3))+1}]
   set len [expr {$n/3}]
   set pn 0
   set pri {2 5 7 11 13 17 19 23 29 31 37 41 43 59 61 67}
   for {set i 0} {$i &lt; $num} {incr i} {
       set a {}
       while {![llength $a]} {
           set a {}
           set b {}
           set c {}
           while {
               ($n+1)%[lindex $pri $pn]==0
             ||($n-1)%[lindex $pri $pn]==0
             ||$n%[lindex $pri $pn]==0} {incr pn; puts $pn}
           set cpn [lindex $pri $pn]
           for {set j 0} {$j &lt; $len} {incr j} {
               set tmp [expr {($j*$cpn)%$n}]
               lappend a $tmp
               incr tmp 1
               if {$tmp in $a} {set a {}; break}
               lappend b $tmp
           }
           incr pn
       }
       for {set j 0} {$j &lt; $n} {incr j} {
           if {$j ni $a &amp;&amp; $j ni $b} {lappend c $j}
       }
       puts "[lsort -integer $a] VS [lsort -integer $b] - Which is havier? -1 = left, 0 = equal, 1 = right"
       set idx [expr {[gets stdin] + 1}]
       if {$i == 0} {
           if {$idx == 1} {
               set p1 $c
               set p2 $c
           } elseif {$idx == 0} {
               set p1 $a
               set p2 $b
           } else {
               set p1 $b
               set p2 $a
           }
       } else {
           set lists [list $a $c $b]
           set p1 [lmap it [lindex $lists $idx] {if {$it ni $p1} continue; set it}]
           set p2 [lmap it [lindex $lists 2-$idx] {if {$it ni $p2} continue; set it}]
       }
   }
   if {[llength $p1]} {puts "Result $p1"} {puts "Result $p2"}
}
puts "Number of balls?"
weight [gets stdin]


No matter what you choose, the next question is always the same.