viric@0: #!/bin/wish
viric@0: 
viric@1: set wheight 400
viric@1: set wwidth 800
viric@1: set wwidthsingle [expr $wwidth / 3 ]
viric@2: set gradient 10
viric@2: # Precision on color selection
viric@2: set th_prec 2000
viric@1: 
viric@1: # Aquest -2 és perque els butons, per alguna raó, són 2 pixels més alts i
viric@1: # amples.
viric@1: set wheightsingle [expr $wheight / $gradient - 2]
viric@1: 
viric@1: proc stepvalue { min max step } {
viric@1: 	global gradient
viric@1: 	return [expr $min + ( ( $max - $min ) * $step / ($gradient - 1) )]
viric@1: }
viric@1: 
viric@1: proc color { r g b } {
viric@1: 	return [format "#%04x%04x%04x" $r $g $b]
viric@1: }
viric@1: 
viric@1: # Build the labels
viric@2: frame .c
viric@2: pack .c -side bottom
viric@1: 
viric@1: # Left
viric@0: frame .leftcol
viric@1: label .leftcol.c -height $wheight -width $wwidthsingle -bg #12f \
viric@1: 	-bitmap @gray50.xbm -borderwidth 0
viric@0: pack .leftcol.c
viric@1: 
viric@1: # Center
viric@0: frame .centercol
viric@1: for {set i 0} {$i < $gradient} {incr i} {
viric@1: 	set r [stepvalue 0 65535 $i]
viric@1: 	set g $r 
viric@1: 	set b $r 
viric@1: 	button .centercol.b$i -height $wheightsingle -width $wwidthsingle \
viric@1: 		-bg [color $r $g $b]  -bitmap gray50 -borderwidth 0 \
viric@1: 		-highlightthickness 0 -command "selection $i"
viric@1: 	pack .centercol.b$i -side top
viric@1: }
viric@1: 
viric@1: # Right
viric@0: frame .rightcol
viric@1: label .rightcol.c -height $wheight -width $wwidthsingle -bg #f12 \
viric@1: 	-bitmap @gray50.xbm -borderwidth 0
viric@0: pack .rightcol.c
viric@0: 
viric@0: pack .leftcol -side left
viric@0: pack .centercol -side left
viric@0: pack .rightcol -side left
viric@0: 
viric@2: # Menu
viric@2: menu .mb
viric@2: . config -menu .mb
viric@2: set mFile [menu .mb.mFile]
viric@2: .mb add cascade -label File -menu .mb.mFile
viric@1: 
viric@2: $mFile add command -label Load -command load_file
viric@2: $mFile add command -label Save -command save_file
viric@2: $mFile add separator
viric@2: $mFile add cascade -label Export -menu ${mFile}.mExport
viric@2: $mFile add command -label Quit -command exit
viric@2: set mExport [menu ${mFile}.mExport]
viric@2: $mExport add command -label "GNUPlot data" -command export_gnuplotdata
viric@2: $mExport add command -label ICC -command export_icc
viric@2: 
viric@2: # Globals
viric@2: set rpoints {{0 0.} {65535 1.}}
viric@2: set gpoints {{0 0.} {65535 1.}}
viric@2: set bpoints {{0 0.} {65535 1.}}
viric@1: 
viric@1: # Loop functions
viric@1: 
viric@2: # Returns { type }
viric@2: proc get_next_ptype { } {
viric@2: 	global rpoints gpoints bpoints
viric@2: 
viric@2: 	set nrp [llength $rpoints]
viric@2: 	set ngp [llength $gpoints]
viric@2: 	set nbp [llength $bpoints]
viric@2: 
viric@2: 	puts "nrp: $nrp"
viric@2: 	puts "ngp: $ngp"
viric@2: 	puts "nbp: $nbp"
viric@2: 
viric@2: 	if { $nrp > $ngp } {
viric@2: 		set type g
viric@2: 	} else {
viric@2: 		set type r
viric@2: 	}
viric@2: 
viric@2: 	if { [set n${type}p] > $nbp } {
viric@2: 		set type b
viric@2: 	}
viric@2: 
viric@2: 	return $type
viric@2: }
viric@1: 
viric@2: proc get_next_point { type } {
viric@2: 	global ${type}points
viric@2: 	upvar 0 ${type}points points
viric@2: 	
viric@2: 	set np [llength $points]
viric@2: 
viric@2: 	set last [lindex [lindex $points 0] 0 ]
viric@2: 
viric@2: 	set maxdist 0
viric@2: 
viric@2: 	set imin 0
viric@2: 
viric@2: 	for {set i 1} {$i < $np} {incr i 1} {
viric@2: 		set actual [lindex [lindex $points $i] 0]
viric@2: 		set dist [expr {abs($last - $actual)}]
viric@2: 		puts "dist: $dist"
viric@2: 		if { $dist > $maxdist } {
viric@2: 			set imin [expr {$i - 1}]
viric@2: 			puts "New imin"
viric@2: 			set maxdist $dist
viric@2: 		}
viric@2: 		set last $actual
viric@2: 	}
viric@2: 	return $imin
viric@1: }
viric@1: 
viric@2: proc prepare_colors_newpoint { } {
viric@2: 	global icolors rpoints gpoints bpoints gradient type xmin xmax nxmin nxmax
viric@2: 
viric@2: 	set type [get_next_ptype]
viric@2: 	set icolors [get_next_point $type]
viric@2: 	upvar 0 ${type}points points
viric@2: 
viric@2: 	puts "type: $type"
viric@2: 	puts "icolors: $icolors"
viric@2: 
viric@2: 	set xmin [lindex [lindex $points $icolors] 0]
viric@2: 	set xmax [lindex [lindex $points [expr {$icolors + 1}]] 0]
viric@2: 	set nxmin $xmin
viric@2: 	set nxmax $xmax
viric@2: 	prepare_colors $type $nxmin $nxmax
viric@2: }
viric@2: 
viric@2: proc prepare_colors { type nxmin nxmax } {
viric@2: 	global gradient
viric@2: 
viric@2: 	switch -- $type {
viric@2: 		r {
viric@2: 			set cmin [color $nxmin 0 0]
viric@2: 			set cmax [color $nxmax 0 0]
viric@2: 		} g {
viric@2: 			set cmin [color 0 $nxmin 0]
viric@2: 			set cmax [color 0 $nxmax 0]
viric@2: 		}
viric@2: 		b {
viric@2: 			set cmin [color 0 0 $nxmin]
viric@2: 			set cmax [color 0 0 $nxmax]
viric@2: 		}
viric@2: 	}
viric@2: 
viric@2: 	# Set the bg and fg color to xmin and xmax
viric@2: 	.leftcol.c configure -background $cmin -foreground $cmax
viric@2: 	.rightcol.c configure -background $cmin -foreground $cmax
viric@2: 
viric@2: 	# Prepare the colors of the middle buttons
viric@2: 	for {set i 0} {$i < $gradient} {incr i} {
viric@2: 		set x [stepvalue $nxmin $nxmax $i]
viric@2: 		switch -- $type {
viric@2: 			r { set c [color $x 0 0] }
viric@2: 			g { set c [color 0 $x 0] }
viric@2: 			b { set c [color 0 0 $x] }
viric@2: 		}
viric@2: 		.centercol.b$i configure -background $c -foreground $c
viric@2: 	}
viric@2: }
viric@2: 
viric@2: proc padd { point } {
viric@1: }
viric@1: 
viric@1: proc selection { i } {
viric@2: 	global rpoints gpoints bpoints nxmin nxmax gradient type th_prec
viric@2: 
viric@2: 	upvar 0 ${type}points points
viric@2: 
viric@2: 	set nstep_min [expr {$i - 1}]
viric@2: 	set nstep_max [expr {$i + 1}]
viric@2: 	if {$nstep_min < 0} { set nstep_min 0 }
viric@2: 	if {$nstep_max >= $gradient} { set nstep_max [expr {$gradient - 1}] }
viric@2: 	set nvalue_min [stepvalue $nxmin $nxmax $nstep_min]
viric@2: 	set nvalue_max [stepvalue $nxmin $nxmax $nstep_max]
viric@2: 	puts "$type - nvalue_min: $nvalue_min, nvalue_max: $nvalue_max"
viric@2: 
viric@2: 	set nxmin $nvalue_min
viric@2: 	set nxmax $nvalue_max
viric@2: 
viric@2: 	if {[expr {$nxmax - $nxmin}] > $th_prec} {
viric@2: 		puts "$type - More precision needed"
viric@2: 		prepare_colors $type $nxmin $nxmax
viric@2: 	} else {
viric@2: 
viric@2: 		puts "$type - New point!"
viric@2: 		# Add the point - middle range
viric@2: 		set middle [expr {$nxmin + ($nxmax - $nxmin)/2}]
viric@2: 		set i 0
viric@2: 		while { [lindex [lindex $points $i] 0] < $middle } {
viric@2: 			incr i 1
viric@2: 		}
viric@2: 		# Get the middle of the light intesity
viric@2: 		set vmin [lindex [lindex $points [expr {$i - 1}]] 1]
viric@2: 		set vmax [lindex [lindex $points $i] 1]
viric@2: 		set nval [expr {$vmin + ($vmax - $vmin)/2.0}]
viric@2: 		set points [linsert $points $i [list $middle $nval]] 
viric@2: 		puts "$type - $points"
viric@2: 
viric@2: 		prepare_colors_newpoint
viric@2: 	}
viric@1: }
viric@1: 
viric@2: proc save_file { } {
viric@2: 	global rpoints gpoints bpoints
viric@2: 
viric@2: 	set file [tk_getSaveFile]
viric@2: 	if { $file == "" } {
viric@2: 		return
viric@2: 	}
viric@2: 	set fd [open $file w]
viric@2: 	puts "# plot for gnuplot"
viric@2: 	puts "# plot 'data' index 0 title 'vermell', 'data' index 1 title 'verd', 'data' index 2 title 'blau'"
viric@2: 
viric@2: 	foreach t { rpoints gpoints bpoints } {
viric@2: 		foreach i [set $t] {
viric@2: 			puts -nonewline $fd [join $i " "]
viric@2: 			puts $fd ""
viric@2: 		}
viric@2: 		if { $t != "bpoints"} {
viric@2: 			puts $fd ""
viric@2: 		}
viric@2: 	}
viric@2: 
viric@2: 	close $fd
viric@2: 
viric@2: }
viric@2: 
viric@2: proc load_file { } {
viric@2: 	global rpoints gpoints bpoints
viric@2: 
viric@2: 	set file [tk_getOpenFile]
viric@2: 	if { $file == "" } {
viric@2: 		return
viric@2: 	}
viric@2: 	set fd [open $file r]
viric@2: 
viric@2: 	set rpoints {}
viric@2: 	set gpoints {}
viric@2: 	set bpoints {}
viric@2: 
viric@2: 	set type r
viric@2: 	while { [eof $fd] != 1 } {
viric@2: 		set line [gets $fd]
viric@2: 		if { $line == "" } {
viric@2: 			set line [gets $fd]
viric@2: 			if { $line == "" } {
viric@2: 				switch -- $type {
viric@2: 					r { set type g }
viric@2: 					g { set type b }
viric@2: 				}
viric@2: 			}
viric@2: 		} else {
viric@2: 			if { [string index $line] != "#" } {
viric@2: 				lappend ${type}points [split $line " "]
viric@2: 			}
viric@2: 		}
viric@2: 	}
viric@2: 
viric@2: 	close $fd 
viric@2: 	# Debug
viric@2: 	set nrp [llength $rpoints]
viric@2: 	set ngp [llength $gpoints]
viric@2: 	set nbp [llength $bpoints]
viric@2: 	puts "Read nrp: $nrp, ngp: $ngp, nbp: $nbp"
viric@2: 
viric@2: 	prepare_colors_newpoint
viric@2: }
viric@2: 
viric@2: # Prepare the colors for the user, for the first time!
viric@2: prepare_colors_newpoint