gamma.tk
author viric@llimona
Mon, 23 Oct 2006 00:35:20 +0200
changeset 3 2bdd3f8b7864
parent 2 9aa865195c24
child 4 f8ce867298a9
permissions -rwxr-xr-x
Diverses millores: New, gnuplots, ...
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@2
   143
	prepare_colors $type $nxmin $nxmax
viric@2
   144
}
viric@2
   145
viric@2
   146
proc prepare_colors { type nxmin nxmax } {
viric@2
   147
	global gradient
viric@2
   148
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@2
   166
viric@2
   167
	# Prepare the colors of the middle buttons
viric@2
   168
	for {set i 0} {$i < $gradient} {incr i} {
viric@2
   169
		set x [stepvalue $nxmin $nxmax $i]
viric@2
   170
		switch -- $type {
viric@2
   171
			r { set c [color $x 0 0] }
viric@2
   172
			g { set c [color 0 $x 0] }
viric@2
   173
			b { set c [color 0 0 $x] }
viric@2
   174
		}
viric@2
   175
		.centercol.b$i configure -background $c -foreground $c
viric@2
   176
	}
viric@2
   177
}
viric@2
   178
viric@2
   179
proc padd { point } {
viric@1
   180
}
viric@1
   181
viric@1
   182
proc selection { i } {
viric@2
   183
	global rpoints gpoints bpoints nxmin nxmax gradient type th_prec
viric@2
   184
viric@2
   185
	upvar 0 ${type}points points
viric@2
   186
viric@2
   187
	set nstep_min [expr {$i - 1}]
viric@2
   188
	set nstep_max [expr {$i + 1}]
viric@2
   189
	if {$nstep_min < 0} { set nstep_min 0 }
viric@2
   190
	if {$nstep_max >= $gradient} { set nstep_max [expr {$gradient - 1}] }
viric@2
   191
	set nvalue_min [stepvalue $nxmin $nxmax $nstep_min]
viric@2
   192
	set nvalue_max [stepvalue $nxmin $nxmax $nstep_max]
viric@2
   193
	puts "$type - nvalue_min: $nvalue_min, nvalue_max: $nvalue_max"
viric@2
   194
viric@2
   195
	set nxmin $nvalue_min
viric@2
   196
	set nxmax $nvalue_max
viric@2
   197
viric@2
   198
	if {[expr {$nxmax - $nxmin}] > $th_prec} {
viric@2
   199
		puts "$type - More precision needed"
viric@2
   200
		prepare_colors $type $nxmin $nxmax
viric@2
   201
	} else {
viric@2
   202
viric@2
   203
		puts "$type - New point!"
viric@2
   204
		# Add the point - middle range
viric@2
   205
		set middle [expr {$nxmin + ($nxmax - $nxmin)/2}]
viric@2
   206
		set i 0
viric@2
   207
		while { [lindex [lindex $points $i] 0] < $middle } {
viric@2
   208
			incr i 1
viric@2
   209
		}
viric@2
   210
		# Get the middle of the light intesity
viric@2
   211
		set vmin [lindex [lindex $points [expr {$i - 1}]] 1]
viric@2
   212
		set vmax [lindex [lindex $points $i] 1]
viric@2
   213
		set nval [expr {$vmin + ($vmax - $vmin)/2.0}]
viric@2
   214
		set points [linsert $points $i [list $middle $nval]] 
viric@2
   215
		puts "$type - $points"
viric@2
   216
viric@2
   217
		prepare_colors_newpoint
viric@2
   218
	}
viric@1
   219
}
viric@1
   220
viric@2
   221
proc save_file { } {
viric@2
   222
	global rpoints gpoints bpoints
viric@2
   223
viric@2
   224
	set file [tk_getSaveFile]
viric@2
   225
	if { $file == "" } {
viric@2
   226
		return
viric@2
   227
	}
viric@2
   228
	set fd [open $file w]
viric@3
   229
	puts $fd "# plot for gnuplot"
viric@3
   230
	puts $fd "# plot 'data' index 0 title 'vermell', 'data' index 1 title 'verd', 'data' index 2 title 'blau'"
viric@2
   231
viric@2
   232
	foreach t { rpoints gpoints bpoints } {
viric@3
   233
		puts $fd "# $t"
viric@2
   234
		foreach i [set $t] {
viric@2
   235
			puts -nonewline $fd [join $i " "]
viric@2
   236
			puts $fd ""
viric@2
   237
		}
viric@2
   238
		if { $t != "bpoints"} {
viric@2
   239
			puts $fd ""
viric@3
   240
			puts $fd ""
viric@2
   241
		}
viric@2
   242
	}
viric@2
   243
viric@2
   244
	close $fd
viric@2
   245
viric@2
   246
}
viric@2
   247
viric@2
   248
proc load_file { } {
viric@2
   249
	global rpoints gpoints bpoints
viric@2
   250
viric@2
   251
	set file [tk_getOpenFile]
viric@2
   252
	if { $file == "" } {
viric@2
   253
		return
viric@2
   254
	}
viric@2
   255
	set fd [open $file r]
viric@2
   256
viric@2
   257
	set rpoints {}
viric@2
   258
	set gpoints {}
viric@2
   259
	set bpoints {}
viric@2
   260
viric@2
   261
	set type r
viric@2
   262
	while { [eof $fd] != 1 } {
viric@2
   263
		set line [gets $fd]
viric@2
   264
		if { $line == "" } {
viric@2
   265
			set line [gets $fd]
viric@2
   266
			if { $line == "" } {
viric@2
   267
				switch -- $type {
viric@2
   268
					r { set type g }
viric@2
   269
					g { set type b }
viric@2
   270
				}
viric@2
   271
			}
viric@2
   272
		} else {
viric@3
   273
			if { [string index $line 0] != "#" } {
viric@2
   274
				lappend ${type}points [split $line " "]
viric@2
   275
			}
viric@2
   276
		}
viric@2
   277
	}
viric@2
   278
viric@2
   279
	close $fd 
viric@2
   280
	# Debug
viric@2
   281
	set nrp [llength $rpoints]
viric@2
   282
	set ngp [llength $gpoints]
viric@2
   283
	set nbp [llength $bpoints]
viric@2
   284
	puts "Read nrp: $nrp, ngp: $ngp, nbp: $nbp"
viric@2
   285
viric@2
   286
	prepare_colors_newpoint
viric@2
   287
}
viric@2
   288
viric@3
   289
proc new_points { } {
viric@3
   290
        global rpoints gpoints bpoints
viric@3
   291
viric@3
   292
        set rpoints {{0 0.} {65535 1.}}
viric@3
   293
        set gpoints {{0 0.} {65535 1.}}
viric@3
   294
        set bpoints {{0 0.} {65535 1.}}
viric@3
   295
viric@3
   296
        prepare_colors_newpoint
viric@3
   297
}
viric@3
   298
viric@3
   299
viric@2
   300
# Prepare the colors for the user, for the first time!
viric@2
   301
prepare_colors_newpoint