Данный скрипт - мой первый опыт в написании tcl/tk программ. Так что не пинайте сильно за несообразности и ляпы. В конце концов я не профессиональный программист, я вообще радиоэлектронщик :) .
В программе используются 3 файла - иконка, файл с растром пунктира и подложка карты; так же в программе есть вызов для запроса данных о сети через прокси на sql, там на выходе данные вида:


lines:

{0 236 18 0.72 6 Описание 3 587 2904 785 1781 2 sw0336 cs0400}\
 {0 150 104 4.10 6 Описание 1 327 1153 3067 1454 2 cs0272 cs0402}\
 {0 167 87 3.44 6 Описание 1 2052 1535 3067 1454 2 cs6224 cs0402}\
 {0 204 50 1.97 6 Описание 0 834 2296 3067 1454 2 cs0770 сs0402}\
 {0 176 78 3.09 6 Описание 3 1985 781 3067 1454 2 sw0981 cs0402}\
....
 {0 192 62 2.45 6 Описание 1 3912 432 1452 389 2 sw2153 sw6192}

routers:

{cs0402 ivanova547 ул._Иванова,_547 3067 1454 0 13.27 -3 0.000 119.646 135.354 2 1 0 }\
 {sw0981 petrova25_5_8 ул.Петрова_29_5п_8э 1985 781 0 4.60 -3 0.000 208.080 46.920 2 1 0 }\
....
 {sw6192 sidorova22 ул_Сидорова_22 1452 389 0 4.22 -3 0.000 211.956 43.044 2 1 0 }

ну и сам скрипт:

#!/bin/sh
# \
exec wish -f "$0" ${1+"$@"}
package require Tk

set ver "0.8.4 alpha 2008.11.22"
# где картинки
set paath [file dirname $argv0]
# максимальные координаты в мсскл
set xmax 4237
set ymax 4228
# множитель для преобразования координат в метры
set xy2m 4.608025478
# шаг сетки на максимальном масштабе
set kletka 500
# делитель масштаба по умолчанию
set mult 3
# шрифт на карте
set plotFont {Helvetica 8}

# подложка
proc bgd_set {w} {
    if {$::bgd == 1} {
        set ::mult 1
        refresh $w 0
    } {
        refresh $w 0
    }
}

# запрос информации с роутера
proc info_router {w} {
    catch {
        set id [$w find withtag current]
        if {$id == ""} return
        if {[lindex $::obj($id) 0] == "Router:"} {
            set rid [lindex $::obj($id) 1]
            set ::currentObj "Please wait, get info from $rid"
            update idletasks
            set c $w.m
            toplevel $c
            wm title $c $::obj($id)
            frame $c.f -highlightthickness 1 -borderwidth 1 -relief sunken
            set t $c.f.text
            text $t -bg white -yscrollcommand "$c.scroll set" -setgrid true \
                -width 120 -height 60 -wrap no -tabs {3c 5c 7c 9c 11c} -highlightthickness 0 -borderwidth 0
            scrollbar $c.scroll -command "$t yview"
            pack $t -expand  yes -fill both
            pack $c.scroll -side right -fill y
            pack $c.f -side top
            bind $c <Key-Escape> "destroy $c"
            # открытие сокета с роутером
            set s [socket $rid.lan.xxx.xxx.ru 7xxx]
            fconfigure $s -translation lf -buffering none
            puts $s "password"
            set message [read $s]
            if {$message == ""} {set message "No answer from router $rid"}
            close $s
            $t insert end $message
        }
    }
}

# выполняем body через каждые s секунд
proc every {s body} {eval $body; after [expr {$s*1000}] [info level 0]}

# Сохраням позицию окна и масштаб в $HOME/.maprc
proc write_params {} {
    set fileId [open "$::env(HOME)/.maprc" w 0600]
    puts $fileId "set mult $::mult"
    puts $fileId "wm geometry . [wm geometry .]"
    close $fileId
}

# Запрос на биллинг через проксик
# routers - выводит tcl-список роутеров, lines - связей
proc mssql {c} {
    set s [socket xxx.xxxx.xxx.ru 7xxx]
    fconfigure $s -translation lf -buffering none -encoding utf-8
    puts $s $c
    set message [read $s]
    close $s
    return $message
}

# Координатная сетка
proc setka {w} {
    global xm ym
    set ym [expr {$::ymax/$::mult}]
    set xm [expr {$::xmax/$::mult}]
    # map scroll region
    $w configure -scrollregion "-30 -30 [expr {$xm+30}] [expr {$ym+30}]"
    # подложка в файле map-2.gif, в винде отъедает кучу памяти!!!
    if {$::mult == 1 && $::bgd == 1} {
        image create photo im_map -file [file join $::paath map-2.gif]
        $w create image 0 0 -image im_map -anchor nw
    }
    # setka
    for {set i 0} {$i <= [expr {$xm*$::xy2m/$::kletka}]} {incr i} {
        set x [expr {$i*$::kletka/$::xy2m}]
        $w create line $x 0 $x $ym -width 1 -fill grey
        $w create text $x [expr {$ym+2}] -text [expr {$::kletka*$::mult*$i}] -anchor n -font $::plotFont
    }
    for {set i 0} {$i <= [expr {$ym*$::xy2m/$::kletka}]} {incr i} {
        set y [expr {$ym - ($i*$::kletka/$::xy2m)}]
        $w create line 0 $y $xm $y -width 1 -fill grey
        $w create text -16 [expr {$y-7}] -text [expr {$i*$::kletka*$::mult}] -anchor n -font $::plotFont
    }
    # osi
    $w create line 0 $ym [expr {$xm+10}] $ym -width 2 -arrow last
    $w create line 0 -10 0 $ym -width 2 -arrow first
}

# Рисуем трассы
proc trassa {w line} {
    foreach lin [mssql $line] {
        # coordinates
        set xb [expr {[lindex $lin 7]/$::mult}]
        set yb [expr {$::ym - [lindex $lin 8]/$::mult}]
        set xe [expr {[lindex $lin 9]/$::mult}]
        set ye [expr {$::ym - [lindex $lin 10]/$::mult}]
        # size in m
        set m [expr {round($::xy2m*hypot([lindex $lin 7]-[lindex $lin 9],[lindex $lin 8]-[lindex $lin 10]))}]
        # color
        set r [format "%.0f" [lindex $lin 0]]
        set g [format "%.0f" [lindex $lin 1]]
        set b [format "%.0f" [lindex $lin 2]]
        set clr [format "%02X%02X%02X" $r $g $b]

        set punkt ""
        set strel none
        set dir " == "
        # optika в файле punkt.xbm картинка для создания пунктирной линии
        if {[lindex $lin 4] eq 5} {set punkt "@[file join $::paath punkt.xbm]"}
        # direction
        if {[lindex $lin 6] eq 0} {set strel first; set dir " <== "}
        if {[lindex $lin 6] eq 1} {set strel last; set dir " ==> "}
        # line
        set item [$w create line $xb $yb $xe $ye -tags lines -arrow $strel \
        -arrowshape {10 20 4} -stipple $punkt -width 1 -fill \#$clr ]
        set ::obj($item) "Link: [lindex $lin 12]$dir[lindex $lin 13]   Ping: [lindex $lin 3] lenght=$m m"
        $w addtag point withtag $item
    }
}

# Рисуем обьекты
proc router {w line} {
    # mo - размер АС,свитчей,АП; mor - размер БС
    set mo [expr {$::mult-5}]
    if {$mo == -1} {set mo -2}
    set mor [expr {$mo-2}]
    foreach point [mssql $line] {
        set name [lindex $point 0]
        set x [expr {[lindex $point 3]/$::mult}]
        set y [expr {$::ym - [lindex $point 4]/$::mult}]
        set r [format "%.0f" [lindex $point 8]]
        set g [format "%.0f" [lindex $point 9]]
        set b [format "%.0f" [lindex $point 10]]
        set c0lr [format "%02X%02X%02X" $r $g $b]
        # 0 - abonent station, -2,-3 - base station, 3 - switches, other - repiters
        switch -regexp -- "[lindex $point 7]" {
            "0" {set item [$w create oval [expr {$x-$mo}] [expr {$y-$mo}] [expr {$x+$mo}] [expr {$y+$mo}] \
                -tags objects -fill \#$c0lr ]
                set o "Router:"}
            (-3|-2) {set item [$w create poly $x [expr {$y+$mor}] [expr {$x-$mor}] [expr {$y-$mor}] \
            [expr {$x+$mor}] [expr {$y-$mor}] $x [expr {$y+$mor}] -tags objects -width 0 -fill \#$c0lr -outline black]
                if {$::mult ne 4} {$w create text [expr {$x+6}] [expr {$y+7}] -text [lindex $point 0] -anchor n -font $::plotFont}
                set o "Router:"}
            "3" {set item [$w create rect [expr {$x+$mo}] [expr {$y+$mo}] [expr {$x-$mo}] [expr {$y-$mo}] \
                -tags objects -fill \#$c0lr ]
                set o "Switch:"}
            "default" {set item [$w create oval [expr {$x-$mo}] [expr {$y-$mo}] [expr {$x+$mo}] \
                [expr {$y+$mo}] -tags objects -width 2 -fill white -outline \#$c0lr ]
                set o "AP:"}
        }

        set ::obj($item) "$o $name   [lindex $point 1]   [lindex $point 2]   Ping: [lindex $point 6] Last seen: [lindex $point 14]"
        $w addtag point withtag $item
    }
}

# Обновление карты
proc refresh {w i} {
    $w delete all
    setka $w
    catch {
        trassa $w lines
        router $w routers
    }
    set ::currentObj "MAP refreshed"
    update idletasks
}

# Обновление статус-строки
proc newobj w {
    set id [$w find withtag current]
    if {$id != ""} {
        set ::currentObj $::obj($id)
    }
    update idletasks
}

# Картинкос
image create photo ::img::delete -format GIF -data {
    R0lGODlhEAAQAIABAIQAAP///yH5BAEAAAEALAAAAAAQABAAAAIjjI+pmwAc3HGy
    PUSvqYpuvWQg40FfSVacBa5nN6JYDI3mzRQAOw==
}
image create photo ::img::refresh -format GIF -data {
    R0lGODlhEAAQAJEDAP///wAAACpnKv///yH5BAEAAAMALAAAAAAQABAAAAI63IKp
    xgcPH2ouwgBCw1HIxHCQ4F3hSJKmwZXqWrmWxj7lKJ2dndcon9EBUq+gz3brVXAR
    2tICU0gXBQA7
}

############ main ###########
if {[file exists "$env(HOME)/.maprc"]} {source "$env(HOME)/.maprc"}
wm title . "MAP Viewer v$ver (c) Sanych"
wm iconname . "map viever v$ver (c) Sanych"
# файл с иконкой
wm iconbitmap . @[file join $paath iconmap.xbm]
wm geometry . +0+0

# status line
label .entry -width 200 -font {-family times -size 12 -weight bold } -fg red -textvariable currentObj
set currentObj "MAP v$ver (C) Sanych"
pack .entry -side top

# buttons
frame .niz
checkbutton .niz.chk -text "Background" -compound left -variable bgd -width 30 -command {bgd_set .c}
button .niz.b1 -text "Quit(esc)" -image ::img::delete -compound left -width 100 -command {write_params; exit}
button .niz.b2 -text "Refresh(r)" -image ::img::refresh -compound left -width 100 -command {refresh .c 0}
scale .niz.mlt -relief flat -orient horizontal -from 1 -to 4 -variable mult -command {refresh .c}
pack .niz.b1 .niz.b2 .niz.mlt .niz.chk -side right
pack .niz -side bottom -padx 45

#trace variable currentObj w "objChanged .c"

# paint region
frame .grid
scrollbar .hscroll -orient horiz -command ".c xview"
scrollbar .vscroll -command ".c yview"
canvas .c  -relief flat -borderwidth 1 -scrollregion {-30 -30 4280 4230} -bg white -xscrollcommand ".hscroll set" -yscrollcommand ".vscroll set"
pack .grid -expand yes -fill both -padx 1 -pady 1
grid rowconfig    .grid 0 -weight 1 -minsize 0
grid columnconfig .grid 0 -weight 1 -minsize 0
grid .c -padx 1 -in .grid -pady 1 \
    -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news
grid .vscroll -in .grid -padx 1 -pady 1 \
    -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news
grid .hscroll -in .grid -padx 1 -pady 1 \
    -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news

# refresh every 60"
every 60 {refresh .c 0}

# keys
.c bind point <Any-Enter> "newobj .c"
.c bind point <Any-Leave> {set currentObj ""}
bind .c <3> ".c scan mark %x %y"
bind .c <1> "info_router .c"
bind .c <B3-Motion> ".c scan dragto %x %y"
bind . <Key-r> {refresh .c 0}
#bind . <Key-b> "set $bgd [expr !$bgd];bgd_set .c"
bind . <Key-Escape> {write_params; exit}
bind . <Key-Down> {if {$mult < 4} {set mult [expr {$mult+1}]; refresh .c 0}}
bind . <Key-Up> {if {$mult > 1} {set mult [expr {$mult-1}]; refresh .c 0}}
bind .c <5> {if {$mult < 4} {set mult [expr {$mult+1}]; refresh .c 0}}
bind .c <4> {if {$mult > 1} {set mult [expr {$mult-1}]; refresh .c 0}}