Version 8 of Geographic World Maps

Updated 2007-06-22 18:37:16 by geoffm

The following reference [L1 ] provides simple data files that can be imported into a Tk canvas. Download the world.bln file in the section:

  Mapping -> Mapping - XY->BLN - Blanking/boundary

Each length of border line is labelled with its country. The common border between (say) Belgium and France is in the europe.bln file twice, once as part of the border of France, once as part of Belgium. The source of data is UNESCO; accuracy may not be ideal (it omits the Isle of Wight off the south coast of England, which is larger than Andorra and some of the other islands included).


RS always loves maps (see Tclworld :^) Here's my take at a little viewer to render one or more such bln files. In fact, the data are polygons, so one can just render them as such...

http://tclerswiki.googlepages.com/tclworld2.jpg

You can zoom in or out with + and -, see the name of a polygon by clicking on it (the number probably just says how many coordinates there are), and pan the canvas by dragging with left mouse button pressed:

 package require Tk
 proc main argv {
     foreach a $argv {bln_load $a data}
     pack [canvas .c -bg lightblue] -fill both -expand 1
     foreach item [array names data] {
         .c create polygon $data($item) -tag [list tx $item] -fill [randomcolor] \
            -outline black
     }
     bind . + {canvas'scale .c 1.25}
     bind . - {canvas'scale .c 0.8}
     canvas'scale .c 8
     bind .c <ButtonPress-1> {%W scan mark %x %y}
     bind .c <B1-Motion> {%W scan dragto %x %y 1}
     .c bind tx <1> {display %W %x %y}

 }
 proc bln_load {filename _arr} {
     upvar 1 $_arr arr
     set contour {}
     set recordname ""
     set f [open $filename]
     while {[gets $f line] >= 0} {
         set fields [split $line ,]
         switch [llength $fields] {
             4 {
                 if [llength $contour] {set arr($recordname) $contour}
                 set cnt([lindex $fields 2]) ""
                 set recordname [string trim [lindex $fields 2] \"],[lindex $fields 0]
                 set contour {}
             }
             2 {lappend contour [lindex $fields 0] [expr {-[lindex $fields 1]}]}
         }
     }
 }
 proc canvas'scale {w factor} {
     $w scale all 0 0 $factor $factor
     $w config -scrollregion [$w bbox all]
 }
 proc display {w x y} {
    $w delete txt
    set tags [lindex [$w gettags current] 1]
    $w create text [$w canvasx $x] [$w canvasy $y] -text $tags -tag txt

 }
 proc randomcolor {} {
    set cols {yellow beige orange green pink gray}
    lindex $cols [expr {int(rand()*[llength $cols])}]
 }
 main $argv

GWM In order to improve this I found some useful census data from the US census bureau. If you request and save a table from [L2 ] it can be loaded into the maps above to provide a less random colour scheme for the countries. I have also fixed a small bug in that some countries have more than one border - the above can overwrite older borders when a new border with the same number of vertices is found (e.g. Lesotho in South Africa is hidden). This version saves all the borders of a country as a list in a single element of the data array.

http://tclerswiki.googlepages.com/africamap.jpg

 # world census data in the form of tables can be obtained from
 # http://www.census.gov/cgi-bin/ipc/idbsprd.html, 
 # Use the option "Present all stub information on each data line" to produce the format used here.
 # copy entire page and paste into any text editor (notepad...)
 # In this format, a typical file looks like this:
 if 0 {
 "Table 008. Vital Rates"
 "-----------------------------------","-------","----------","----------","----------------","---------------","-----------"
 "                                   ","       ","    Births","    Deaths","   Net number of","Rate of natural","           "
 "                                   ","       "," per 1,000"," per 1,000","    migrants per","       increase","Growth rate"
 "Country or area                    ","Year   ","population","population","1,000 population","      (percent)","  (percent)"
 "-----------------------------------","-------","----------","----------","----------------","---------------","-----------"
 "" 

 "Afghanistan                        ",2007   ,     46.21,     19.96,            0.00,          2.625,      2.625
 "Albania                            ",2007   ,     15.16,      5.33,           -4.54,          0.983,      0.529
 "Algeria                            ",2007   ,     17.11,      4.62,           -0.33,          1.249,      1.216
 "American Samoa                     ",2007   ,     21.83,      3.24,          -21.21,          1.859,     -0.262
 "Andorra                            ",2007   ,      8.45,      6.45,            6.42,          0.200,      0.842
 }
 package require Tk
 global scale
 set scale 8
 proc main argv {
     foreach a $argv {bln_load $a data}
     set make 0
     if {![winfo exists .c]} {
       pack [canvas .c -bg lightblue] -fill both -expand 1
       set make 1
    }
     foreach item [array names data] {
             foreach curv $data($item) {
              set ip [.c create polygon $curv -tag [list tx $item] -fill [randomcolor] \
            -outline black]
              .c scale $ip 0 0 $::scale $::scale
            }
     }
     if {$make} {
       bind . + {canvas'scale .c 1.25}
       bind . - {canvas'scale .c 0.8}
       bind .c <ButtonPress-1> {%W scan mark %x %y}
       bind .c <B1-Motion> {%W scan dragto %x %y 1}
       .c bind tx <1> {display %W %x %y}
     }

 }
 proc bln_load {filename _arr} {
     upvar 1 $_arr arr
     set contour {}
     set recordname ""
     set f [open $filename]
     while {[gets $f line] >= 0} {
         set fields [split $line ,]
         switch [llength $fields] {
             4 {
                 if [llength $contour] { ;# multiple contours exist for some countries so make list of contours
                        lappend arr($recordname) $contour}
                 set cnt([lindex $fields 2]) ""
                 set recordname [string trim [lindex $fields 2] \"]
                 set contour {}
             }
             2 {lappend contour [lindex $fields 0] [expr {-[lindex $fields 1]}]}
         }
     }
     close $f
 }
 proc canvas'scale {w factor} {
     $w scale all 0 0 $factor $factor
     $w config -scrollregion [$w bbox all]
        set ::scale [expr {$::scale*$factor}] ;# used for new maps to be loaded.
 }
 proc display {w x y} {
    $w delete txt
    set tags [lindex [$w gettags current] 1]
    $w create text [$w canvasx $x] [$w canvasy $y] -text $tags -tag txt

 }
 proc randomcolor {} {
    set cols {yellow beige orange green pink gray}
    lindex $cols [expr {int(rand()*[llength $cols])}]
 }

 # GWM's interface items
 proc addmap {} {
        update ;# this needs to be called before openfile to ensure that binds work
                # particularly +/_ for zooming
        set mapfile [ tk_getOpenFile  -multiple true]
        main $mapfile
 }
  proc divideatstring {line split} {
        set fields {}
        set ok 1
        while {$ok} {
                set endoffield -1
                set sp -1
                while {$endoffield<0 && $sp<[llength $split]} {
                        incr sp
                        set endoffield [string first [lindex $split $sp] $line]
                }
                if {$endoffield>=0} {
                        lappend fields [string trim [string range $line 0 [expr {$endoffield-1}]] " -\""]
                        set start [expr {$endoffield+[string length [lindex $split $sp]]}]
                        set line [string range $line $start end]
                } else {
                        set ok 0;
                        lappend fields [string trim $line " -\""]
                }
        }
        return $fields
  }
 proc loadcensus {filename} {
    if {$filename != ""} {
    set f [open $filename]
    set section 1 ;# 1 title, headers
    # country, values
     gets $f line ;# jump title

    while {[gets $f line] >= 0} {
         set fields [divideatstring $line {"\",\"" "\"," ","}]
         switch [llength $fields] {
                1 { ;# demarks title/data
                        incr section
                }
                default { ;# table country name, one value per column
                        switch $section {
                                1 { ;# get title labels
                                        set ic 0
                                        foreach column $fields {
                                                append arr(Column_$ic) " " $column
                                                incr ic
                                        }
                                }
                                default {
                                                set arr([lindex $fields 0]) [lrange $fields 1 end]
                                }
                        }
                }
          }
        }
        close $f
        # create an interface to select the map colours:
        catch { destroy .color.menu }
        catch { destroy .color.menu.opts }
        set optmenu [menubutton .color.menu -menu .color.menu.opts -text "Choose display"]
        set opmen [menu $optmenu.opts]
        foreach col [array names arr Column_*] {
                $opmen add command -label $arr($col) -command \
                        "recolormap {[array get arr]} \"$arr($col)\""
        }
        pack $optmenu  -side left -expand f -fill y
     }
 }
  proc makecolour {frac} {
        if {$frac<0.5} { ;# range blue to green
                set col [format "#%02x%02x%02x" 0 [expr {int(127+255*$frac)}] [expr {int(127+255*(.5-$frac))}] ]
        } else { ;# green to red
                set col [format "#%02x%02x%02x" [expr {int(127+255*($frac-0.5))}] [expr {int(127+255*(1-$frac))}] 0 ]
        }
        return $col
 }
  proc recolormap {_arr coltitle} {
        array set  arr $_arr
        set icol 0
        set thec 0
        # find the column of data to use
        foreach col [array names arr Column_*] {
                if {$arr($col)==$coltitle} { set thec $icol }
                incr icol
        }
        incr thec -1
        if {$thec>=0} {
          set vmin 1.e30
          set vmax -1.e30
            foreach tag [.c find withtag tx] { ;# all countries in map
                set cname [lindex [.c gettags $tag] 1]
                if {[array names arr $cname]!=""} { 
                        set v [lindex [split $arr($cname)] $thec]
                        if {[string is double -strict $v]} {
                                set vmin [expr {$v<$vmin?$v:$vmin}]
                                set vmax [expr {$v>$vmax?$v:$vmax}]
                        }
                }
           }
        .color.menu configure -text "$coltitle: data range $vmin to $vmax" 
        if {($vmax-$vmin)>0} {
            foreach tag [.c find withtag tx] {
                set cname [lindex [.c gettags $tag] 1]
                if {[array names arr $cname]!=""} {
                        set v [lindex [split $arr($cname)] $thec]
                        if {[string is double -strict $v]} {
                                .c itemconfigure $tag -fill [makecolour [expr {double($v-$vmin)/double($vmax-$vmin)}]]
                        }
                } else {
                        .c itemconfigure $tag -fill #dddddd
                }
           }
                }
        }
  }
 proc addcensus {} {
        set censusfile [ tk_getOpenFile  ]
        loadcensus $censusfile 
 }

 pack [button .addmap -text "Load Map" -command "addmap"] -side top -expand f -fill y
 pack [frame .color] -side top -expand f -fill y
 pack [button .color.addcen -text "Load Census" -command "addcensus"] -side left -expand f -fill y

 # prompt for a bln map file.
 addmap

Arts and crafts of Tcl-Tk programming - Category Geography