3 ## $Id: hypermap,v 1.3 2003-01-08 15:25:35 dron Exp $
5 ## Copyright (C) 1997, Victor Wagner <vitus@ice.ru>
6 ## Copyright (C) 2002, Andrey Kiselev <dron@remotesensing.org>
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)
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.
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,
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]
32 set namestack [list $basename]
35 if [file exist $file] {
42 return "<HTML><HEAD><TITLE>File not found</TITLE></HEAD>\
43 <BODY><H1>File not found</H1>File $file cannot be\
47 proc hyper_window {text} {
48 if {[wm state .hyperleg] != "normal"} {
49 wm deiconify .hyperleg
53 HMreset_win .hyperleg.t
54 HMparse_html $text "HMrender .hyperleg.t"
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]
65 hyper_window "<HTML>\n\
66 <HEAD><TITLE>No info avalable</TITLE></HEAD>\n\
68 <H1>No info avalable</H1>\n\
69 There is no information on this point\n\
77 option add *font $gui_font
78 frame .menu -relief raised -bd 2
79 menubutton .menu.file -text "File" -menu [set m .menu.file.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]}
85 $m add command -label "Print..." -command [list fgisPrintDialog $planchet]
87 $m add command -label "Quit" -command confirmExit
88 menubutton .menu.layer -text "Layer" -menu [set m .menu.layer.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
100 pack .status -expand y -fill x
103 button .tool.layer -text "?" -command add_layer
104 pack .tool.layer -side left -before .tool.scale
105 wm protocol . WM_DELETE_WINDOW confirmExit
108 text .hyperleg.t -wrap word -width 80 -height 40 -yscrollcommand\
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}
118 # Define callbacks for html library. Should be done here
119 # when html library alderady loaded
120 proc HMlink_callback {win href} {
122 HMparse_html [loadfile $href ] "HMrender $win"
124 proc HMset_image {win handle src} {
126 if [info exist basename] {
127 set src [file join [file dirname $basename] $src]
129 if [file exists $src] {
130 set img [image create photo -file $src]
131 HMgot_image $handle $img
135 proc hyper_layer {file legend} {
137 if ![file exists $file] {
138 if [file exists $file.epp] {
141 tk_messageBox -message "File $filename doesn't exists" -type ok
145 if ![file exists $legend] {
146 if [file exists $legend.leg] {
149 tk_messageBox -message "File $legend doesn't exists" -type ok
153 set main_layer [layer create raster -file $file -legfile $legend]
156 source [lindex $argv 0]