tcl/hypermap

   1 #!/usr/bin/wish
   2 ##
   3 ## $ID: $
   4 ##
   5 ## Copyright (C) 1997, Victor Wagner <vitus@ice.ru>
   6 ## Copyright (C) 2002, Andrey Kiselev <dron@remotesensing.org>
   7 ##
   8 ## This program is free software; you can redistribute it and/or modify
   9 ## it under the terms of the GNU General Public License as published by
  10 ## the Free Software Foundation; either version 2, or (at your option)
  11 ## any later version.
  12 ##
  13 ## This program is distributed in the hope that it will be useful,
  14 ## but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ## GNU General Public License for more details.
  17 ##
  18 ## You should have received a copy of the GNU General Public License
  19 ## along with this program; if not, write to the Free Software
  20 ## Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
  21 ## USA.
  22
  23 package require Fgis
  24
  25 proc loadfile {file} {
  26     global basename namestack
  27     if [info exist basename] {
  28         set file [file join [file dirname $basename] $file]
  29         if [info exist namestack] {
  30             set namestack [concat [list $basename] $namestack]
  31         } else {
  32             set namestack [list $basename]
  33         }
  34     }
  35     if [file exist $file] {
  36        set f [open $file]
  37        set text [read $f]
  38        close $f
  39        set basename $file
  40        return $text
  41     } else {
  42        return "<HTML><HEAD><TITLE>File not found</TITLE></HEAD>\
  43        <BODY><H1>File not found</H1>File $file cannot be\
  44        read</BODY></HTML>"
  45     }
  46 }
  47 proc hyper_window {text} {
  48   if {[wm state .hyperleg] != "normal"} {
  49      wm deiconify .hyperleg
  50   } else {
  51      raise .hyperleg
  52   }
  53   HMreset_win .hyperleg.t
  54   HMparse_html $text "HMrender .hyperleg.t"
  55 }
  56
  57 proc show_hyper {planchet x y} {
  58   global main_layer basename namestack
  59   catch { unset basename}
  60   catch {unset namestack}
  61   set value [$main_layer value [$planchet mapx $x]  [$planchet mapy $y] -raw]
  62   if [string length $value] {
  63      hyper_window [loadfile $value]
  64   } else {
  65      hyper_window "<HTML>\n\
  66      <HEAD><TITLE>No info avalable</TITLE></HEAD>\n\
  67      <BODY>\n\
  68      <H1>No info avalable</H1>\n\
  69      There is no information on this point\n\
  70      </BODY>\n\
  71      </HTML>"
  72   }
  73 }
  74
  75
  76 set planchet .map
  77 option add *font -cronyx-times-bold-r-normal--10-*
  78 frame .menu -relief raised -bd 2
  79 menubutton .menu.file -text "File" -menu [set m .menu.file.m]
  80 menu $m
  81 #$m add command -label "Open..." -command add_layer
  82 #$m add command -label "Save..." -state disabled -command {save_layer [select_layer]}
  83 #$m add command -label "Close..." -state disabled -command {close_layer [select_layer]}
  84 #$m add separator
  85 $m add command -label "Print..." -command [list fgisPrintDialog $planchet]
  86 $m add separator
  87 $m add command -label "Quit" -command confirmExit
  88 menubutton .menu.layer -text "Layer" -menu [set m .menu.layer.m]
  89 menu $m
  90 $m add command -label "Show..." -command {show_layer [select_layer] } -state disabled
  91 $m add command -label "Look..." -command select_layers -state disabled
  92 #$m add command -label "Properties..." -command {edit_layer [select_layer]} -state disabled
  93 pack .menu.file .menu.layer -side left
  94 pack .menu -side top -expand y -fill x
  95 label .status -anchor w
  96 planchet $planchet -width 640 -height 480 -status .status
  97 toolbar .tool $planchet
  98 pack .tool -expand y -fill x
  99 pack $planchet
 100 pack .status -expand y -fill x
 101
 102
 103 button .tool.layer -text "?" -command add_layer
 104 pack .tool.layer -side left -before .tool.scale
 105 wm protocol . WM_DELETE_WINDOW confirmExit
 106
 107 toplevel .hyperleg
 108 text .hyperleg.t -wrap word -width 80 -height 40 -yscrollcommand\
 109        ".hyperleg.y set"
 110 scrollbar .hyperleg.y -orient vert -command ".hyperleg.t yview"
 111 grid .hyperleg.t .hyperleg.y -sticky news
 112 wm protocol .hyperleg WM_DELETE_WINDOW {wm withdraw .hyperleg}
 113 wm withdraw .hyperleg
 114 HMinit_win .hyperleg.t
 115 bind $planchet <Button-1> {show_hyper $planchet %x %y}
 116
 117 #
 118 # Define callbacks for html library. Should be done here
 119 # when html library alderady loaded
 120 proc HMlink_callback {win href} {
 121     HMreset_win $win
 122     HMparse_html [loadfile $href ] "HMrender $win"
 123 }
 124 proc HMset_image {win handle src} {
 125   global basename
 126   if [info exist basename] {
 127      set src [file join [file dirname $basename] $src]
 128   }
 129   if [file exists $src] {
 130     set img [image create photo -file $src]
 131     HMgot_image $handle $img
 132   }
 133 }
 134
 135 proc hyper_layer {file legend} {
 136    global main_layer
 137    if ![file exists $file] {
 138       if [file exists $file.epp] {
 139          append file .epp
 140       } else {
 141          tk_messageBox -message "File $filename doesn't exists" -type ok
 142          return
 143       }
 144    }
 145    if ![file exists $legend] {
 146         if [file exists $legend.leg] {
 147             append legend .leg
 148         } else {
 149             tk_messageBox -message "File $legend doesn't exists" -type ok
 150             return
 151         }
 152    }
 153    set main_layer [layer create raster -file $file -legfile $legend]
 154 }
 155
 156 source [lindex $argv 0]