gamma.tk
changeset 2 9aa865195c24
parent 1 c36976fd28f3
child 3 2bdd3f8b7864
equal deleted inserted replaced
1:c36976fd28f3 2:9aa865195c24
     1 #!/bin/wish
     1 #!/bin/wish
     2 
     2 
     3 set wheight 400
     3 set wheight 400
     4 set wwidth 800
     4 set wwidth 800
     5 set wwidthsingle [expr $wwidth / 3 ]
     5 set wwidthsingle [expr $wwidth / 3 ]
     6 set gradient 5
     6 set gradient 10
       
     7 # Precision on color selection
       
     8 set th_prec 2000
     7 
     9 
     8 # Aquest -2 és perque els butons, per alguna raó, són 2 pixels més alts i
    10 # Aquest -2 és perque els butons, per alguna raó, són 2 pixels més alts i
     9 # amples.
    11 # amples.
    10 set wheightsingle [expr $wheight / $gradient - 2]
    12 set wheightsingle [expr $wheight / $gradient - 2]
    11 
    13 
    17 proc color { r g b } {
    19 proc color { r g b } {
    18 	return [format "#%04x%04x%04x" $r $g $b]
    20 	return [format "#%04x%04x%04x" $r $g $b]
    19 }
    21 }
    20 
    22 
    21 # Build the labels
    23 # Build the labels
       
    24 frame .c
       
    25 pack .c -side bottom
    22 
    26 
    23 # Left
    27 # Left
    24 frame .leftcol
    28 frame .leftcol
    25 label .leftcol.c -height $wheight -width $wwidthsingle -bg #12f \
    29 label .leftcol.c -height $wheight -width $wwidthsingle -bg #12f \
    26 	-bitmap @gray50.xbm -borderwidth 0
    30 	-bitmap @gray50.xbm -borderwidth 0
    46 
    50 
    47 pack .leftcol -side left
    51 pack .leftcol -side left
    48 pack .centercol -side left
    52 pack .centercol -side left
    49 pack .rightcol -side left
    53 pack .rightcol -side left
    50 
    54 
    51 
    55 # Menu
    52 # Global variables
    56 menu .mb
       
    57 . config -menu .mb
       
    58 set mFile [menu .mb.mFile]
       
    59 .mb add cascade -label File -menu .mb.mFile
       
    60 
       
    61 $mFile add command -label Load -command load_file
       
    62 $mFile add command -label Save -command save_file
       
    63 $mFile add separator
       
    64 $mFile add cascade -label Export -menu ${mFile}.mExport
       
    65 $mFile add command -label Quit -command exit
       
    66 set mExport [menu ${mFile}.mExport]
       
    67 $mExport add command -label "GNUPlot data" -command export_gnuplotdata
       
    68 $mExport add command -label ICC -command export_icc
       
    69 
       
    70 # Globals
       
    71 set rpoints {{0 0.} {65535 1.}}
       
    72 set gpoints {{0 0.} {65535 1.}}
       
    73 set bpoints {{0 0.} {65535 1.}}
    53 
    74 
    54 # Loop functions
    75 # Loop functions
    55 
    76 
    56 # Returns { min_r max_r min_g max_g min_b max_b }
    77 # Returns { type }
    57 set min_r 0
    78 proc get_next_ptype { } {
    58 set max_r 65535
    79 	global rpoints gpoints bpoints
    59 set min_g 0
    80 
    60 set max_g 0
    81 	set nrp [llength $rpoints]
    61 set min_b 0
    82 	set ngp [llength $gpoints]
    62 set max_b 0
    83 	set nbp [llength $bpoints]
    63 
    84 
    64 proc getnext { } {
    85 	puts "nrp: $nrp"
    65 }
    86 	puts "ngp: $ngp"
    66 
    87 	puts "nbp: $nbp"
    67 proc prepare_colors { } {
    88 
    68 	global min_r max_r min_g max_g min_b max_b
    89 	if { $nrp > $ngp } {
       
    90 		set type g
       
    91 	} else {
       
    92 		set type r
       
    93 	}
       
    94 
       
    95 	if { [set n${type}p] > $nbp } {
       
    96 		set type b
       
    97 	}
       
    98 
       
    99 	return $type
       
   100 }
       
   101 
       
   102 proc get_next_point { type } {
       
   103 	global ${type}points
       
   104 	upvar 0 ${type}points points
       
   105 	
       
   106 	set np [llength $points]
       
   107 
       
   108 	set last [lindex [lindex $points 0] 0 ]
       
   109 
       
   110 	set maxdist 0
       
   111 
       
   112 	set imin 0
       
   113 
       
   114 	for {set i 1} {$i < $np} {incr i 1} {
       
   115 		set actual [lindex [lindex $points $i] 0]
       
   116 		set dist [expr {abs($last - $actual)}]
       
   117 		puts "dist: $dist"
       
   118 		if { $dist > $maxdist } {
       
   119 			set imin [expr {$i - 1}]
       
   120 			puts "New imin"
       
   121 			set maxdist $dist
       
   122 		}
       
   123 		set last $actual
       
   124 	}
       
   125 	return $imin
       
   126 }
       
   127 
       
   128 proc prepare_colors_newpoint { } {
       
   129 	global icolors rpoints gpoints bpoints gradient type xmin xmax nxmin nxmax
       
   130 
       
   131 	set type [get_next_ptype]
       
   132 	set icolors [get_next_point $type]
       
   133 	upvar 0 ${type}points points
       
   134 
       
   135 	puts "type: $type"
       
   136 	puts "icolors: $icolors"
       
   137 
       
   138 	set xmin [lindex [lindex $points $icolors] 0]
       
   139 	set xmax [lindex [lindex $points [expr {$icolors + 1}]] 0]
       
   140 	set nxmin $xmin
       
   141 	set nxmax $xmax
       
   142 	prepare_colors $type $nxmin $nxmax
       
   143 }
       
   144 
       
   145 proc prepare_colors { type nxmin nxmax } {
       
   146 	global gradient
       
   147 
       
   148 	switch -- $type {
       
   149 		r {
       
   150 			set cmin [color $nxmin 0 0]
       
   151 			set cmax [color $nxmax 0 0]
       
   152 		} g {
       
   153 			set cmin [color 0 $nxmin 0]
       
   154 			set cmax [color 0 $nxmax 0]
       
   155 		}
       
   156 		b {
       
   157 			set cmin [color 0 0 $nxmin]
       
   158 			set cmax [color 0 0 $nxmax]
       
   159 		}
       
   160 	}
       
   161 
       
   162 	# Set the bg and fg color to xmin and xmax
       
   163 	.leftcol.c configure -background $cmin -foreground $cmax
       
   164 	.rightcol.c configure -background $cmin -foreground $cmax
       
   165 
       
   166 	# Prepare the colors of the middle buttons
       
   167 	for {set i 0} {$i < $gradient} {incr i} {
       
   168 		set x [stepvalue $nxmin $nxmax $i]
       
   169 		switch -- $type {
       
   170 			r { set c [color $x 0 0] }
       
   171 			g { set c [color 0 $x 0] }
       
   172 			b { set c [color 0 0 $x] }
       
   173 		}
       
   174 		.centercol.b$i configure -background $c -foreground $c
       
   175 	}
       
   176 }
       
   177 
       
   178 proc padd { point } {
    69 }
   179 }
    70 
   180 
    71 proc selection { i } {
   181 proc selection { i } {
    72 	puts $i
   182 	global rpoints gpoints bpoints nxmin nxmax gradient type th_prec
    73 }
   183 
    74 
   184 	upvar 0 ${type}points points
       
   185 
       
   186 	set nstep_min [expr {$i - 1}]
       
   187 	set nstep_max [expr {$i + 1}]
       
   188 	if {$nstep_min < 0} { set nstep_min 0 }
       
   189 	if {$nstep_max >= $gradient} { set nstep_max [expr {$gradient - 1}] }
       
   190 	set nvalue_min [stepvalue $nxmin $nxmax $nstep_min]
       
   191 	set nvalue_max [stepvalue $nxmin $nxmax $nstep_max]
       
   192 	puts "$type - nvalue_min: $nvalue_min, nvalue_max: $nvalue_max"
       
   193 
       
   194 	set nxmin $nvalue_min
       
   195 	set nxmax $nvalue_max
       
   196 
       
   197 	if {[expr {$nxmax - $nxmin}] > $th_prec} {
       
   198 		puts "$type - More precision needed"
       
   199 		prepare_colors $type $nxmin $nxmax
       
   200 	} else {
       
   201 
       
   202 		puts "$type - New point!"
       
   203 		# Add the point - middle range
       
   204 		set middle [expr {$nxmin + ($nxmax - $nxmin)/2}]
       
   205 		set i 0
       
   206 		while { [lindex [lindex $points $i] 0] < $middle } {
       
   207 			incr i 1
       
   208 		}
       
   209 		# Get the middle of the light intesity
       
   210 		set vmin [lindex [lindex $points [expr {$i - 1}]] 1]
       
   211 		set vmax [lindex [lindex $points $i] 1]
       
   212 		set nval [expr {$vmin + ($vmax - $vmin)/2.0}]
       
   213 		set points [linsert $points $i [list $middle $nval]] 
       
   214 		puts "$type - $points"
       
   215 
       
   216 		prepare_colors_newpoint
       
   217 	}
       
   218 }
       
   219 
       
   220 proc save_file { } {
       
   221 	global rpoints gpoints bpoints
       
   222 
       
   223 	set file [tk_getSaveFile]
       
   224 	if { $file == "" } {
       
   225 		return
       
   226 	}
       
   227 	set fd [open $file w]
       
   228 	puts "# plot for gnuplot"
       
   229 	puts "# plot 'data' index 0 title 'vermell', 'data' index 1 title 'verd', 'data' index 2 title 'blau'"
       
   230 
       
   231 	foreach t { rpoints gpoints bpoints } {
       
   232 		foreach i [set $t] {
       
   233 			puts -nonewline $fd [join $i " "]
       
   234 			puts $fd ""
       
   235 		}
       
   236 		if { $t != "bpoints"} {
       
   237 			puts $fd ""
       
   238 		}
       
   239 	}
       
   240 
       
   241 	close $fd
       
   242 
       
   243 }
       
   244 
       
   245 proc load_file { } {
       
   246 	global rpoints gpoints bpoints
       
   247 
       
   248 	set file [tk_getOpenFile]
       
   249 	if { $file == "" } {
       
   250 		return
       
   251 	}
       
   252 	set fd [open $file r]
       
   253 
       
   254 	set rpoints {}
       
   255 	set gpoints {}
       
   256 	set bpoints {}
       
   257 
       
   258 	set type r
       
   259 	while { [eof $fd] != 1 } {
       
   260 		set line [gets $fd]
       
   261 		if { $line == "" } {
       
   262 			set line [gets $fd]
       
   263 			if { $line == "" } {
       
   264 				switch -- $type {
       
   265 					r { set type g }
       
   266 					g { set type b }
       
   267 				}
       
   268 			}
       
   269 		} else {
       
   270 			if { [string index $line] != "#" } {
       
   271 				lappend ${type}points [split $line " "]
       
   272 			}
       
   273 		}
       
   274 	}
       
   275 
       
   276 	close $fd 
       
   277 	# Debug
       
   278 	set nrp [llength $rpoints]
       
   279 	set ngp [llength $gpoints]
       
   280 	set nbp [llength $bpoints]
       
   281 	puts "Read nrp: $nrp, ngp: $ngp, nbp: $nbp"
       
   282 
       
   283 	prepare_colors_newpoint
       
   284 }
       
   285 
       
   286 # Prepare the colors for the user, for the first time!
       
   287 prepare_colors_newpoint