tcl/hypermap

   1 #!/usr/bin/wish8.0
   2
   3 package require Fgis
   4
   5 proc loadfile {file} {
   6     global basename namestack
   7     if [info exist basename] {
   8         set file [file join [file dirname $basename] $file]
   9         if [info exist namestack] {
  10             set namestack [concat [list $basename] $namestack]
  11         } else {
  12             set namestack [list $basename]
  13         }
  14     }
  15     if [file exist $file] {
  16        set f [open $file]
  17        set text [read $f]
  18        close $f
  19        set basename $file
  20        return $text
  21     } else {
  22        return "<HTML><HEAD><TITLE>File not found</TITLE></HEAD>\
  23        <BODY><H1>File not found</H1>File $file cannot be\
  24        read</BODY></HTML>"
  25     }
  26 }
  27 proc hyper_window {text} {
  28   if {[wm state .hyperleg] != "normal"} {
  29      wm deiconify .hyperleg
  30   } else {
  31      raise .hyperleg
  32   }
  33   HMreset_win .hyperleg.t
  34   HMparse_html $text "HMrender .hyperleg.t"
  35 }
  36
  37 proc show_hyper {planchet x y} {
  38   global main_layer basename namestack
  39   catch { unset basename}
  40   catch {unset namestack}
  41   set value [$main_layer value [$planchet mapx $x]  [$planchet mapy $y] -raw]
  42   if [string length $value] {
  43      hyper_window [loadfile $value]
  44   } else {
  45      hyper_window "<HTML>\n\
  46      <HEAD><TITLE>No info avalable</TITLE></HEAD>\n\
  47      <BODY>\n\
  48      <H1>No info avalable</H1>\n\
  49      There is no information on this point\n\
  50      </BODY>\n\
  51      </HTML>"
  52   }
  53 }
  54
  55
  56 set planchet .map
  57 option add *font -cronyx-times-bold-r-normal--10-*
  58 frame .menu -relief raised -bd 2
  59 menubutton .menu.file -text "File" -menu [set m .menu.file.m]
  60 menu $m
  61 #$m add command -label "Open..." -command add_layer
  62 #$m add command -label "Save..." -state disabled -command {save_layer [select_layer]}
  63 #$m add command -label "Close..." -state disabled -command {close_layer [select_layer]}
  64 #$m add separator
  65 $m add command -label "Print..." -command [list fgisPrintDialog $planchet]
  66 $m add separator
  67 $m add command -label "Quit" -command confirmExit
  68 menubutton .menu.layer -text "Layer" -menu [set m .menu.layer.m]
  69 menu $m
  70 $m add command -label "Show..." -command {show_layer [select_layer] } -state disabled
  71 $m add command -label "Look..." -command select_layers -state disabled
  72 #$m add command -label "Properties..." -command {edit_layer [select_layer]} -state disabled
  73 pack .menu.file .menu.layer -side left
  74 pack .menu -side top -expand y -fill x
  75 label .status -anchor w
  76 planchet $planchet -width 640 -height 480 -status .status
  77 toolbar .tool $planchet
  78 pack .tool -expand y -fill x
  79 pack $planchet
  80 pack .status -expand y -fill x
  81
  82
  83 button .tool.layer -text "?" -command add_layer
  84 pack .tool.layer -side left -before .tool.scale
  85 wm protocol . WM_DELETE_WINDOW confirmExit
  86
  87 toplevel .hyperleg
  88 text .hyperleg.t -wrap word -width 80 -height 40 -yscrollcommand\
  89        ".hyperleg.y set"
  90 scrollbar .hyperleg.y -orient vert -command ".hyperleg.t yview"
  91 grid .hyperleg.t .hyperleg.y -sticky news
  92 wm protocol .hyperleg WM_DELETE_WINDOW {wm withdraw .hyperleg}
  93 wm withdraw .hyperleg
  94 HMinit_win .hyperleg.t
  95 bind $planchet <Button-1> {show_hyper $planchet %x %y}
  96
  97 #
  98 # Define callbacks for html library. Should be done here
  99 # when html library alderady loaded
 100 proc HMlink_callback {win href} {
 101     HMreset_win $win
 102     HMparse_html [loadfile $href ] "HMrender $win"
 103 }
 104 proc HMset_image {win handle src} {
 105   global basename
 106   if [info exist basename] {
 107      set src [file join [file dirname $basename] $src]
 108   }
 109   if [file exists $src] {
 110     set img [image create photo -file $src]
 111     HMgot_image $handle $img
 112   }
 113 }
 114
 115 proc hyper_layer {file legend} {
 116    global main_layer
 117    if ![file exists $file] {
 118       if [file exists $file.epp] {
 119          append file .epp
 120       } else {
 121          tk_messageBox -message "File $filename doesn't exists" -type ok
 122          return
 123       }
 124    }
 125    if ![file exists $legend] {
 126         if [file exists $legend.leg] {
 127             append legend .leg
 128         } else {
 129             tk_messageBox -message "File $legend doesn't exists" -type ok
 130             return
 131         }
 132    }
 133    set main_layer [layer create raster -file $file -legfile $legend]
 134 }
 135
 136 source [lindex $argv 0]