Geografic-Information-System/scripts/d.rast.edit/d.rast.edit.tcl

if {[array get env GISBASE] == ""} {
    puts stderr "You must be in GRASS GIS to run this program."
    exit 1
}

if {$tcl_platform(platform) == "windows"} {
	set stderr NUL:
} else {
	set stderr @stderr
}

set outmap $env(GIS_OPT_OUTPUT)
set inmap $env(GIS_OPT_INPUT)
set aspect $env(GIS_OPT_ASPECT)
set width $env(GIS_OPT_WIDTH)
set height $env(GIS_OPT_HEIGHT)
set size $env(GIS_OPT_SIZE)
set rows $env(GIS_OPT_ROWS)
set cols $env(GIS_OPT_COLS)

set status(row) ""
set status(col) ""
set status(x) ""
set status(y) ""
set status(value) ""
set status(aspect) ""

set brush "*"

set origin(x) 0
set origin(y) 0

set finalized false

proc initialize {} {
	global tempbase tempfile tempreg tempmap env stderr
	global inmap outmap

	set tempbase [exec g.tempfile pid=[pid]]
	file delete $tempbase

	set tempfile $tempbase.ppm
	set tempreg tmp.d.rast.edit
	set tempmap tmp.d.rast.edit

	exec g.region --q --o save=$tempreg 2>$stderr

	set env(WIND_OVERRIDE) $tempreg

	exec g.copy --q --o rast=$inmap,$outmap 2>$stderr
	exec r.colors --q map=$outmap rast=$inmap 2>$stderr
}

proc finalize {} {
	global tempfile tempreg tempmap stderr finalized

	if {$finalized} return

	save_map

	file delete $tempfile
	exec g.remove --q rast=$tempmap region=$tempreg 2>$stderr

	set finalized true

	exit 0
}

proc force_window {} {
	global origin rows cols total

	if {$origin(x) < 0} {set origin(x) 0}
	if {$origin(x) > $total(cols) - $cols} {set origin(x) [expr $total(cols) - $cols]}
	if {$origin(y) < 0} {set origin(y) 0}
	if {$origin(y) > $total(rows) - $rows} {set origin(y) [expr $total(rows) - $rows]}
}

proc set_window {x y} {
	global origin rows cols

	set origin(x) [expr [.overview.canvas canvasx $x] - $cols / 2]
	set origin(y) [expr [.overview.canvas canvasy $y] - $rows / 2]

	force_window

	set x0 $origin(x)
	set y0 $origin(y)
	set x1 [expr $x0 + $cols]
	set y1 [expr $y0 + $rows]

	.overview.canvas delete window
	.overview.canvas create rectangle $x0 $y0 $x1 $y1 -dash {4 4} -tags window
}

proc update_window {} {
	global wind total origin rows cols

	set x0 $origin(x)
	set y0 $origin(y)
	set x1 [expr $x0 + $cols]
	set y1 [expr $y0 + $rows]

	set wind(n) [expr $total(n) - $y0 * $total(nsres)]
	set wind(s) [expr $total(n) - $y1 * $total(nsres)]
	set wind(w) [expr $total(w) + $x0 * $total(ewres)]
	set wind(e) [expr $total(w) + $x1 * $total(ewres)]
	set wind(rows) $rows
	set wind(cols) $cols
}

proc change_window {} {
	save_map
	update_window
	load_map
	load_aspect
	refresh_canvas
}

proc create_overview {} {
	global inmap outmap stderr env total rows cols tempfile

	exec g.region --q rast=$inmap 2>$stderr
	exec r.out.ppm --q $inmap out=$tempfile 2>$stderr

	set reg [exec g.region --q -g 2>$stderr]
	set reg [regsub -all {[\r\n]+} $reg { }]
	set reg [regsub -all {=} $reg { }]
	array set total $reg

	image create photo overview -file $tempfile
	file delete $tempfile

	toplevel .overview
	wm title .overview "d.rast.edit overview ($inmap)"

	set w $total(cols)
	set h $total(rows)

	canvas .overview.canvas -width $w -height $h -scrollregion [list 0 0 $w $h] \
	    -xscrollcommand {.overview.xscroll set} -yscrollcommand {.overview.yscroll set}

	scrollbar .overview.xscroll -orient horizontal -command {.overview.canvas xview}
	scrollbar .overview.yscroll -orient vertical   -command {.overview.canvas yview}

	if {$cols > $total(cols)} {set cols $total(cols)}
	if {$rows > $total(rows)} {set rows $total(rows)}

	force_window

	.overview.canvas create image 0 0 -anchor nw -image overview -tags image
	.overview.canvas create rectangle 0 0 $cols $rows -dash {4 4} -tags window

	grid .overview.canvas .overview.yscroll -sticky nsew
	grid .overview.xscroll -sticky nsew

	grid rowconfigure    .overview 0 -weight 1
	grid columnconfigure .overview 0 -weight 1

	bind .overview.canvas <ButtonPress-1>   { set_window %x %y }
	bind .overview.canvas <B1-Motion>       { set_window %x %y }
	bind .overview.canvas <ButtonRelease-1> { set_window %x %y ; change_window }

	bind .overview <Destroy> { finalize }
}

proc read_header {infile window} {
	upvar \#0 $window wind

	regexp {^north: *([0-9]+)$} [gets $infile] dummy wind(n)
	regexp {^south: *([0-9]+)$} [gets $infile] dummy wind(s)
	regexp {^east: *([0-9]+)$}  [gets $infile] dummy wind(e)
	regexp {^west: *([0-9]+)$}  [gets $infile] dummy wind(w)
	regexp {^rows: *([0-9]+)$}  [gets $infile] dummy wind(rows)
	regexp {^cols: *([0-9]+)$}  [gets $infile] dummy wind(cols)
}

proc read_data {infile array} {
	global wind
	upvar \#0 $array values

	for {set row 0} {$row < $wind(rows)} {incr row} {
		gets $infile line
		set col 0
		foreach elem $line {
			set values($row,$col) $elem
			incr col
		}
	}
}

proc clear_changes {} {
	global wind changed

	for {set row 0} {$row < $wind(rows)} {incr row} {
		for {set col 0} {$col < $wind(cols)} {incr col} {
			set changed($row,$col) 0
		}
	}
}

proc load_map {} {
	global tempfile wind values changed colors inmap stderr

	exec g.region --q n=$wind(n) s=$wind(s) e=$wind(e) w=$wind(w) \
	    rows=$wind(rows) cols=$wind(cols) 2>$stderr

	set infile [open "|r.out.ascii --q input=$inmap 2>$stderr" r]
	read_header $infile wind
	read_data $infile values
	close $infile

	clear_changes

	exec r.out.ppm --q input=$inmap output=$tempfile 2>$stderr

	image create photo colorimg -file $tempfile
	file delete $tempfile

	for {set row 0} {$row < $wind(rows)} {incr row} {
		for {set col 0} {$col < $wind(cols)} {incr col} {
			set val $values($row,$col)
			if {[array get colors $val] != ""} continue
			set pix [colorimg get $col $row]
			set r [lindex $pix 0]
			set g [lindex $pix 1]
			set b [lindex $pix 2]
			set color [format "#%02x%02x%02x" $r $g $b]
			set colors($val) $color
		}
	}

	image delete colorimg
}

proc load_aspect {} {
	global wind angles aspect stderr

	if {$aspect == ""} return

	set infile [open "|r.out.ascii --q input=$aspect 2>$stderr" r]
	read_header $infile dummy
	read_data $infile angles
	close $infile
}

proc save_map {} {
	global inmap outmap tempmap stderr
	global wind values changed

	set outfile [open "|r.in.ascii --q --o input=- output=$tempmap 2>$stderr" w]

	puts $outfile "north: $wind(n)"
	puts $outfile "south: $wind(s)"
	puts $outfile "east: $wind(e)"
	puts $outfile "west: $wind(w)"
	puts $outfile "rows: $wind(rows)"
	puts $outfile "cols: $wind(cols)"

	for {set row 0} {$row < $wind(rows)} {incr row} {
		for {set col 0} {$col < $wind(cols)} {incr col} {
			if {$col > 0} {
				puts -nonewline $outfile " "
			}
			if {$changed($row,$col)} {
				puts -nonewline $outfile "$values($row,$col)"
			} else {
				puts -nonewline $outfile "*"
			}
		}
		puts $outfile ""
	}

	close $outfile

	exec g.region --q rast=$inmap 2>$stderr
	exec r.patch --q --o input=$tempmap,$outmap output=$outmap 2>$stderr
	exec r.colors --q map=$outmap rast=$inmap 2>$stderr
	exec g.remove --q rast=$tempmap 2>$stderr
}

proc force_color {val} {
	global tempfile tempreg tempmap colors inmap stderr env

	exec g.region --q rows=1 cols=1 2>$stderr
	exec r.mapcalc "$tempmap = $val" 2>$stderr
	exec r.colors --q map=$tempmap rast=$inmap 2>$stderr
	exec r.out.ppm --q $tempmap out=$tempfile 2>$stderr
	exec g.remove --q rast=$tempmap 2>$stderr

	image create photo tempimg -file $tempfile
	file delete $tempfile

	set pix [tempimg get 0 0]
	set r [lindex $pix 0]
	set g [lindex $pix 1]
	set b [lindex $pix 2]
	set color [format "#%02x%02x%02x" $r $g $b]
	set colors($val) $color
	image delete tempimg
}

proc get_color {val} {
	global colors

	if {[array get colors $val] == ""} {
		if {[catch {force_color $val}]} {
			set colors($val) "#ffffff"
		}
	}

	return $colors($val)
}

proc brush_update {} {
	global brush colors

	if {$brush == "*"} {
		.tools.color configure -bitmap gray12 -foreground black
	} else {
		.tools.color configure -bitmap gray75 -foreground [get_color $brush]
	}
}

proc current_cell {} {
	global canvas

	set row ""
	set col ""

	set tags [.canvas itemcget current -tags]

	foreach tag $tags {
		if {[regexp {row-([0-9]+)} $tag dummy r]} {set row $r}
		if {[regexp {col-([0-9]+)} $tag dummy c]} {set col $c}
	}

	return [list $row $col]
}

proc cell_enter {} {
	global status
	global wind values angles

	set pos [current_cell]
	set row [lindex $pos 0]
	set col [lindex $pos 1]

	if {$row == "" || $col == ""} return

	set status(row) $row
	set status(col) $col
	set status(x) [expr {$wind(e) + ($col + 0.5) * ($wind(e) - $wind(w)) / $wind(cols)}]
	set status(y) [expr {$wind(n) - ($row + 0.5) * ($wind(n) - $wind(s)) / $wind(rows)}]
	set status(value) $values($row,$col)
	if {[array exists angles]} {
		set status(aspect) $angles($row,$col)
	}
}

proc cell_leave {} {
	global status

	set status(row) ""
	set status(col) ""
	set status(x) ""
	set status(y) ""
	set status(value) ""
	set status(aspect) ""
}

proc cell_get {} {
	global brush values colors

	set pos [current_cell]
	set row [lindex $pos 0]
	set col [lindex $pos 1]

	set brush $values($row,$col)

	brush_update
}

proc cell_set {} {
	global canvas brush values changed colors

	set pos [current_cell]
	set row [lindex $pos 0]
	set col [lindex $pos 1]
	set val $brush

	set values($row,$col) $val
	set changed($row,$col) 1

	set cell [.canvas find withtag "(cell&&row-$row&&col-$col)"]

	if {$val == "*"} {
		set fill black
		set stipple gray12 
	} else {
		set fill [get_color $val]
		set stipple ""
	}

	.canvas itemconfigure $cell -outline white -fill $fill -stipple $stipple
}

proc refresh_canvas {} {
	global wind size values colors angles

	.canvas delete all

	set aspect [array exists angles]
	set pi [expr 2 * acos(0)]

	for {set row 0} {$row < $wind(rows)} {incr row} {
		for {set col 0} {$col < $wind(cols)} {incr col} {
			set x0 [expr $col * $size + 1]
			set x1 [expr $x0 + $size - 1]
			set y0 [expr $row * $size + 1]
			set y1 [expr $y0 + $size - 1]

			if {$values($row,$col) == "*"} {
				set color black
				set stipple gray12
			} else {
				set color $colors($values($row,$col))
				set stipple ""
			}

			.canvas create polygon $x0 $y0 $x1 $y0 $x1 $y1 $x0 $y1 \
			    -fill $color -stipple $stipple \
			    -outline black -activeoutline red \
			    -tags [list cell row-$row col-$col]

			if {! $aspect} continue

			if {$angles($row,$col) == "*"} continue

			set cx [expr ($x0 + $x1) / 2]
			set cy [expr ($y0 + $y1) / 2]

			set a [expr $angles($row,$col) * $pi / 180]

			set dx [expr   cos($a) * $size / 2]
			set dy [expr - sin($a) * $size / 2]

			set x0 [expr $cx - $dx]
			set y0 [expr $cy - $dy]
			set x1 [expr $cx + $dx]
			set y1 [expr $cy + $dy]

			.canvas create line $x0 $y0 $x1 $y1 \
			    -arrow last \
			    -disabledfill white -state disabled \
			    -tags [list arrow row-$row col-$col]
		}
	}
}

proc make_canvas {} {
	global canvas values colors angles rows cols
	global size width height

	set cx [expr $width  / $cols]
	set cy [expr $height / $rows]

	set sz [expr ($cx > $cy) ? $cx : $cy]
	if {$size < $sz} {set size $sz}

	set w [expr $cols * $size]
	set h [expr $rows * $size]

	canvas .canvas -width $width -height $height -scrollregion [list 0 0 $w $h] \
	    -xscrollcommand {.xscroll set} -yscrollcommand {.yscroll set}

	scrollbar .xscroll -orient horizontal -command {.canvas xview}
	scrollbar .yscroll -orient vertical   -command {.canvas yview}

	.canvas bind cell <Any-Enter> { cell_enter }
	.canvas bind cell <Any-Leave> { cell_leave }

	.canvas bind cell <Button-1> { cell_set }
	.canvas bind cell <Button-3> { cell_get }

	bind .canvas <Any-Leave> { cell_leave }
}

proc make_ui {} {
	global canvas inmap

	wm title . "d.rast.edit ($inmap)"
	bind . <Destroy> { finalize }

	menu .menu -tearoff 0
	menu .menu.file -tearoff 0
	.menu add cascade -label "File" -menu .menu.file -underline 0
	.menu.file add command -label "Save" -underline 0 -command {save_map}
	.menu.file add command -label "Exit" -underline 1 -command {destroy .}

	. configure -menu .menu

	frame .status
	label .status.row_l -text "Row:"
	entry .status.row -textvariable status(row) -width 6
	label .status.col_l -text "Col:"
	entry .status.col -textvariable status(col) -width 6
	label .status.x_l -text "X:"
	entry .status.x -textvariable status(x) -width 10
	label .status.y_l -text "Y:"
	entry .status.y -textvariable status(y) -width 10
	label .status.value_l -text "Value:"
	entry .status.value -textvariable status(value) -width 10
	label .status.aspect_l -text "Aspect:"
	entry .status.aspect -textvariable status(aspect) -width 10

	pack \
	    .status.row_l .status.row \
	    .status.col_l .status.col \
	    .status.x_l .status.x \
	    .status.y_l .status.y \
	    .status.value_l .status.value \
	    .status.aspect_l .status.aspect \
	    -side left

	frame .tools
	label .tools.value_l -text "New value:"
	entry .tools.value -textvariable brush
	label .tools.color_l -text "Color:"
	label .tools.color -bitmap gray12 -foreground black

	pack \
	    .tools.value_l .tools.value \
	    .tools.color_l .tools.color \
	    -side left

	bind .tools.value <KeyPress-Return> brush_update

	grid .canvas .yscroll -sticky nsew
	grid .xscroll -sticky nsew
	grid .status  -sticky nsew
	grid .tools  -sticky nsew

	grid rowconfigure    . 0 -weight 1
	grid columnconfigure . 0 -weight 1
}

initialize
create_overview
make_canvas
make_ui
update_window
load_map
load_aspect
refresh_canvas