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