chiark / gitweb /
Solver for the Travelling Salesman Problem.
[rocl] / elite-salesman
1 #! /usr/bin/tclsh
2 #
3 # $Id: elite-salesman,v 1.1 2003/03/07 00:45:51 mdw Exp $
4
5 package require "elite" "1.0.1"
6 package require "vector" "1.0.0"
7 package require "graph" "1.0.0"
8
9 set opts {}
10 set weight weight-hops
11 set d 70
12 set cycle 1
13 for {set i 0} {$i < [llength $argv]} {incr i} {
14   set a [lindex $argv $i]
15   switch -glob -- $a {
16     "-inner" - "-dead" - "-temp" - "-cool" {
17       lappend opts $a
18       incr i
19       lappend opts [lindex $argv $i]
20     }
21     "-cycle" {
22       set cycle 1
23       lappend opts $a
24     }
25     "-nocycle" {
26       set cycle 0
27       lappend opts $a
28     }
29     "-w" {
30       incr i
31       set a [lindex $argv $i]
32       set weight "weight-$a"
33       if {[lsearch -exact [info commands "weight-*"] $weight] == -1} {
34         puts stderr "$argv0: unknown weight function `$a'"
35         puts stderr "$argv0: I know [info commands weight-*]"
36         exit 1
37       }
38     }
39     "-d" {
40       incr i
41       set d [expr {int([lindex $argv $i] * 10)}]
42     }
43     "--" {
44       incr i
45       break
46     }
47     "-*" {
48       puts stderr "unknown switch `$a'"
49       exit 1
50     }
51     default {
52       break
53     }
54   }
55 }
56
57 set argv [lrange $argv $i end]
58 if {[llength $argv] < 1 || [llength $argv] > 2} {
59   puts stderr "usage: $argv0 \[-OPTIONS\] \[-w WEIGHT\] \[-d DIST\] GAL \[WORLD\]"
60   exit 1
61 }
62
63 set g [parse-galaxy-spec [lindex $argv 0]]
64 if {[string equal $g ""]} {
65   puts stderr "$argv0: bad galaxy spec `$g'"
66   exit 1
67 }
68 destructure {ng g} $g
69 set ww [elite-galaxylist $g]
70 if {[llength $argv] < 2} {
71   if {!$cycle} {
72     puts stderr "$argv0: must specify starting point if not cycling"
73     exit 1
74   }
75   set p [lindex $ww 0]
76 } else {
77   set p [parse-planet-spec $g [lindex $argv 1]]
78   if {[string equal $g ""]} {
79     puts stderr "$argv0: bad planet spec `$p'"
80     exit 1
81   }
82   if {![in-galaxy-p $g $p]} {
83     puts stderr "$argv0: planet `[worldname $p]' is not in galaxy $ng"
84     exit 1
85   }
86 }
87
88 array set index {}
89 set seed {}
90 set i 0
91 foreach {s x y} $ww {
92   set index($s) $i
93   lappend seed $s
94   incr i
95 }
96
97 elite-adjacency adj $ww $d
98 set av [vector {256 256} -1]
99 foreach {s x y} $ww {
100   set i $index($s)
101   foreach {ss xx yy} $adj($s) {
102     set j $index($ss)
103     $av set $i $j [eval $weight [list $s $ss]]
104   }
105 }
106 destructure {lv pv} [graph-shortest-path $av]
107 set i $index($p)
108 set pp [list $i]
109 for {set j 0} {$j < 256} {incr j} {
110   if {$i != $j && [$lv get $i $j] >= 0} { lappend pp $j }
111 }
112 puts -nonewline stderr "\[thinking..."
113 destructure {dist tsp} \
114     [eval graph-travelling-salesman $opts -- [list $lv $pp]]
115 puts stderr " done\]"
116 puts "# Total metric = $dist"
117 set home [lindex $tsp 0]
118 set k $home
119 puts [world-summary [lindex $seed $k] 0 2]
120 foreach i [lrange $tsp 1 end] {
121   while {1} {
122     set k [$pv get $k $i]
123     if {$k < 0 || $k == $i} { break }
124     puts [world-summary [lindex $seed $k] 2 0]
125   }
126   puts [world-summary [lindex $seed $k] 0 2]
127   set k $i
128 }
129 if {$cycle} {
130   while {1} {
131     set k [$pv get $k $home]
132     if {$k < 0 || $k == $home} { break }
133     puts [world-summary [lindex $seed $k] 2 0]
134   }
135 }