#!/bin/sh
#
# Copyright (c) 1998   Alessandro Rubini  (rubini@linux.it)
# Copyright (c) 1998   Daniel Scharstein  (schar@panther.middlebury.edu)
#
#   This program is free software; you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation; either version 2 of the License, or
#   (at your option) any later version.
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with this program; if not, write to the Free Software
#   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#

# This program uses gpac if available, wish otherwise \
if [ -f /usr/local/bin/gpac ]; then engine=gpac; else engine=wish; fi

# The following a comment for both tcl interpreters, not for the shell \
exec $engine -f $0 $*

###### From now on, the shell doesn't see the code (only wish or gpac)

### Set global variables

set g(configfile) "$env(HOME)/.pxc_xgrabrc"
set g(defaultbuffer) 16; # 4 megs (hires)

# Based on "islores"
set g(device:0) /dev/pxc0Hpgm
set g(device:1) /dev/pxc0pgm

### Color Models (fg, bg, hi-bg), used in local_color
set g(color:dark)   {black gray60 gray63}
set g(color:darker) {black gray50 gray58}
set g(color:light)  {black gray95 white}
set g(color:red)    {white darkred #c01010}
set g(color:green)  {white darkgreen #20a020}
set g(color:yellow) {black yellow #808030}


# set some defaults
set g(activerectcolor)   "#FF6000"
set g(inactiverectcolor) "#802000"
set g(disabledfg) gray50
set g(fillcolor) gray75

set g(saving) 0
set g(avoidfilters) 0

set g(gain) 1.0
set g(gain:flag) 0
set g(add) 0
set g(add:flag) 0
set g(bgwidth) 0
set g(bgwidth:flag) 0


### Use the environment for configuration
# ACQUIRE_PHOTO is used to force using the photo widget even if pacco exists
set g(pacco) 0; if [info exist pacco_defaults]       {set g(pacco) 1}
if [info exists env(ACQUIRE_PHOTO)]  {set g(pacco) 0}

### Commandline parsing
if {[llength $argv] == 0} {
    set g(islores) 1
    #puts "$argv0: using low resolution: $g(device:1)"
} elseif {([llength $argv] == 1) && ([lindex $argv 0] == "-hires")} {
    set g(islores) 0
    #puts "$argv0: using high resolution: $g(device:0)"
} else {
    puts stderr "$argv0: Usage: $argv0 \[-hires\]"
    exit 1
}

###### The procedures

proc LiveGrab {} {
    global g

    if !$g(live) return
    if $g(pacco) {
	# Use the pacco way. with gain and other controls
	img.tmp import $g(device)
	if !$g(avoidfilters) {
	    if $g(bgwidth:flag) {
		img.tmp sub img.bg
	    }
	    if $g(gain:flag) {
		img.tmp mult $g(gain)
	    }
	    if $g(add:flag) {
		img.tmp add $g(add)
	    }
	    if [winfo exists .xtra] {
		minmax.min reduce -min img.tmp
		minmax.max reduce -max img.tmp
		set err 0
		if [minmax.min pixel]<0 {
		    $g(win:errors).uf config -foreground red
		    incr err
		} else {
		    $g(win:errors).uf config -foreground gray70
		}
		if [minmax.max pixel]>0.999 {
		    $g(win:errors).of config -foreground red
		    incr err
		} else {
		    $g(win:errors).of config -foreground gray70
		}
		if $err {
		    $g(win:errors).no config -foreground gray70
		} else {
		    $g(win:errors).no config -foreground black
		}
	    }
	    img.tmp max 0.0
	    # No need to trim high values for lflt
	    #img.tmp min 0.994
	    img.it copy img.tmp
	} else {
	    # No image filtering
	    img.it import $g(device)
	    if [winfo exists $g(win:errors).no] {
		$g(win:errors).no config -foreground black
		$g(win:errors).of config -foreground gray70
		$g(win:errors).uf config -foreground gray70
	    }
	}
    } else {
	exec cp $g(device) $g(img)
	grabimg config -file $g(img)
    } 
    update
    after 10 LiveGrab
}

proc Live_Changed {} {
    global g
    # we read the variable *after* it changed
    if $g(live) {
	.b.run invoke
    } else {
	.b.stop invoke
    }
}

# The image is created at the beginning, but also when changing resolution
proc create_image {} {
    global g

    catch {$g(c) delete image}
    if $g(pacco) {
	catch {img destroy}
	obox  img "{Img_lflt it $g(X) $g(Y)} \
		{Img_lflt tmp $g(X) $g(Y)} \
		{Img_lflt bg  $g(X) $g(Y)}"
	$g(c) create pacmap 0 0 [expr $g(X)-1] [expr $g(Y)-1] \
		-link img.it -tag image
	img.it bind <Data> "$g(c) itemconfig image -update 1"
	img.bg clear 0; Extra_setbgwidth; # According to current settings
    } else {
	exec cp $g(device) $g(img)
	image create photo grabimg  -file $g(img)
	$g(c) create image $g(Xc) $g(Yc) -image grabimg -tag image
    }    

}

proc Run {} {
    global g

    set g(live) 1
    .f configure -background cyan
    .b.run configure -state disabled
    .b.stop configure -state normal
    .b.save configure -state disabled
    after 10 LiveGrab
}
    
proc Stop {} {
    global g

    set g(live) 0
    if $g(pacco) {
	# if we are using pacco, copy the device to an image
	exec cp $g(device) $g(img)
    }
    .f configure -background #aeb2c3
    .b.run configure -state normal
    .b.stop configure -state disabled
    .b.save configure -state normal
}

proc Save {} {
    global g

    if $g(live) return
    set g(saving) 1
    toplevel .w -class Dialog
    wm title .w "Save File"
    frame .w.f
    label .w.f.lab -text "File name:"
    entry .w.f.ent -width 30 -relief sunken -bd 2 -textvariable fname
    pack .w.f.lab .w.f.ent -in .w.f -side left
    button .w.sav -text "Save" -command  {DoSave $fname 0}
    button .w.can -text "Cancel" -command {DoSave "" 0}
    pack .w.f -side top
    pack .w.sav .w.can -side left -expand yes
    bind .w <Return> {DoSave $fname 1}
    set oldFocus [focus]
    grab set .w
    focus .w.f.ent
    tkwait window .w
    focus $oldFocus
    set g(saving) 0
}

proc DoSave {fname flash} {
    global g

    set msecs 50
    if $flash {
	set msecs 500
    }
    if {$fname == ""} {
	.w.can configure -state active
	set msecs 500
    } else {
	.w.sav configure -state active
	exec cp $g(img) $fname
    }
    after $msecs destroy .w
}

proc Extra {} {
    # Add extra controls to control acquisition
    .b.xtra config -state disabled
    Extra_main [toplevel .xtra]
}

proc Quit {} {
    global g
    exec rm -f $g(img) $g(bgimg)
    exit 0
}

######################################################## The "extra" stuff

# First of all, empty hooks, to avoid initial errors
proc change_size_hook args {}

proc Extra_main tl {
    global g

    # Prepare globals anyways, even with plain wish
    # Note that there is not support for gain offset etc, even if
    # pxc_gain (the acquisition engine) has such support).
    set g(prevgain) [set g(gain) 1.0]
    set g(halfsize) 0

    wm title $tl "Extra acquisition information"
    pack [frame $tl.topf]

    ### Video controls:  gain, offset, bg (only if pacco is there)
    if $g(pacco) {
	################### Left panel

	pack [set f [frame $tl.topf.ctrl -bd 3 -bg $g(fillcolor)]] -side left
	pack [scale $f.s1 -from 0.5 -to 5 -resolution 0.1 -variable g(gain) \
		-command Extra_setgain -orient h] -fill x
	pack [label $f.l1 -text "Image gain"] -fill x
	pack [frame $f.sep1 -height 3 -background $g(fillcolor)] -fill x

	pack [scale $f.s2 -from -0.5 -to 0.5 -resolution 0.1 -variable g(add) \
		-command Extra_setadd -orient h] -fill x
	pack [label $f.l2 -text "Image offset"] -fill x
	pack [frame $f.sep2 -height 3 -background $g(fillcolor)] -fill x

	pack [frame $f.bg] -expand true -fill x
	# Extra frame for background, it has an extra button
	pack [scale $f.bg.s3 -from -0 -to 50 -resolution 5 -orient h \
		-variable g(bgwidth)] -fill x
	pack [label $f.bg.l3 -text "Low-pass width"] \
		-fill x -expand 1 -side left
	pack [button $f.bg.b3 -text "Subtract" -command Extra_setbgwidth] \
		-fill x -padx 2m
	pack [frame $f.sep3 -height 3 -background $g(fillcolor)] -fill x
	pack [button $f.showbg -text "See background..." \
		-command Extra_see] -expand true -fill x -padx 2m -pady 3
	set g(win:bgbutton) $f.showbg

	### Status: overflow, underflow
	pack [set f [frame $f.labs -borderwidth 2 -relief ridge]] \
		-padx 2m -pady 1m
	pack [label $f.txt -text "Errors: "] -side left
	pack [label $f.no -text " none "] -side left
	pack [label $f.uf -text " underflow "] -side left
	pack [label $f.of -text " overflow "] -side left
	set g(win:errors) $f
    }

    ################### Middle panel
    pack [set f [frame $tl.topf.f -width 220]] \
	    -expand true -fill both -side left

    ###  Radio buttons: hi-res, low-res and optionally full/half
    pack [set f2 [frame $f.rb0]] -expand true -fill both
    pack [set f3 [frame $f2.low -bd 2 -relief ridge]] \
	    -expand true -fill both -padx 2m -pady 2m -side left
    pack [radiobutton $f3.1 -variable g(islores) -value 1 \
	    -command Extra_res -text "Low resolution"] -expand true -fill both
    pack [radiobutton $f3.0 -variable g(islores) -value 0 \
	    -command Extra_res -text "High resolution"] -expand 1 -fill both
    # Radio buttons: full/half size
    if $g(pacco) {
	pack [set f3 [frame $f2.half -bd 2 -relief ridge]] \
		-expand true -fill both -padx 2m -pady 2m -side left
	pack [radiobutton $f3.0 -variable g(halfsize) -value 0 \
		-command Extra_half -text "Full size"] -expand true -fill both
	pack [radiobutton $f3.1 -variable g(halfsize) -value 1 \
	    -command Extra_half -text "Half size"] -expand 1 -fill both
    }

    ### A checkbutton to enable/disable image controls
    if $g(pacco) {
	set g(avoidfilters) 1; # Display original in the first place
	pack [checkbutton $f.enable -text "Display original image" \
		-variable g(avoidfilters) \
		-bd 2 -relief ridge] \
		-expand true -fill both -padx 2m -pady 2m
    }

    ### Ability to load/save config
    if $g(pacco) {
	pack [frame $f.io] -expand true -fill both -padx 3m -pady 3m
	pack [button $f.io.save -text "Save parameters" -command Extra_save] \
		-side left -fill both -padx 1m
	pack [button $f.io.load -text "Load parameters" -command Extra_load] \
		-side left -fill both -padx 1m
    }

    ### Create a label describing the ROI (in a frame, for constant width)
    pack [label $f.label -width 28] -expand true -fill both
    # "trace variable" doesn't work, it seems...
    proc new_geo geo "$f.label config -text \"   Geometry: \$geo\" "

    ### Create a rectangle in the canvas, to mark the roi, and bind it
    $g(c) create rect 0 0 [expr $g(X)-1] [expr $g(Y)-1] \
	    -outline $g(activerectcolor) -tag recto
    Extra_rect init
    Extra_bindings 1

    ### Report disk space, and prepare for updating it
    pack [label $f.df] -expand true -fill both
    proc change_df_hook {} "$f.df config -text \
	    \[format \"Disk space: %iMB\" \[local_df]]; change_size_hook"
    change_df_hook

    ### Report size of next acquisition, and prepare for updating it
    pack [label $f.size] -expand true -fill both
    proc change_size_hook args "$f.size config -text \
	    \[format \"Next run: %sMB\" \[local_size]]"

    ################### Right panel
    pack [set f [frame $tl.topf.other]] -expand true -fill both

    ### Other controls: step and duration
    pack [frame $f.fill_top -height 4]  -expand true -fill both
    pack [scale $f.step -variable g(acqstep) -orient h -from 1 -to 150 \
	    -command "Extra_step $f.step_l"] -fill x
    pack [label $f.step_l] -fill x
    pack [frame $f.fill_step -height 4]  -expand true -fill both
    
    pack [scale $f.len -variable g(acqlen) -orient h -from 1 -to 150\
	    -command change_size_hook] -fill x
    pack [label $f.len_l -text "Grab duration (s)"] -fill x
    pack [frame $f.fill_len -height 4] -expand true -fill both

    pack [entry $f.name_e] -fill x -padx 1m
    set g(n_entry) $f.name_e; set g(name) ""; Extra_NewName
    pack [label $f.name_l -text "Directory name for sequence"] -fill x
    pack [frame $f.fill_name -height 4] -expand true -fill both

    pack [entry $f.calib_e] -fill x -padx 1m
    set g(c_entry) $f.calib_e;
    pack [label $f.calib_l -text "Calibration: pixel/um"] -fill x
    pack [frame $f.fill_callib -height 4] -expand true -fill both

    # Size is now known, update the label
    change_size_hook

    ################### Bottom row
    ### The "Ok" and the "no" buttons
    pack [button $tl.done -text "Close" -command "Extra_done $tl"] \
	    -expand true -fill x -side left
    pack [button $tl.go -text "Acquire" -command Extra_acq] \
	    -expand true -fill x -side left
    local_color green $tl.go 
    local_color red $tl.done

    # Initialize with previous values
    Extra_load;
}

# Bind the canvas...
proc Extra_bindings bool {
    global g

    if !$bool { # Disable all the bindings
	bind $g(c) <ButtonPress-1> ""
	bind $g(c) <ButtonRelease-1> ""
	bind $g(c) <B1-Motion> ""
	return
    }
	
    # press: disable live video
    bind $g(c) <ButtonPress-1> {
	set g(savelive) $g(live); set g(live) 0; Live_Changed
	set g(Xmove) ""; set g(Ymove) "";
    }
    # release: re-enable live video if needed
    bind $g(c) <ButtonRelease-1> {
	if $g(savelive) {.b.run invoke}
    }

    # motion: check if we move the ROI
    bind $g(c) <B1-Motion> {
	# check if it locks some vertical line
	if [expr abs(%x-$g(r:x))<3]&&![llength $g(Xmove)] {
	    set g(Xmove) x
	    set g(Xmove:o) %x
	}
	if [expr abs(%x-$g(r:X))<3]&&![llength $g(Xmove)] {
	    set g(Xmove) X
	    set g(Xmove:o) %x
	}
	if [llength $g(Xmove)] {
	    Extra_rect move $g(Xmove) [expr %x-$g(Xmove:o)]
	    set g(Xmove:o) %x
	}

	# same for horiz
	if [expr abs(%y-$g(r:y))<3]&&![llength $g(Ymove)] {
	    set g(Ymove) y
	    set g(Ymove:o) %y
	}
	if [expr abs(%y-$g(r:Y))<3]&&![llength $g(Ymove)] {
	    set g(Ymove) Y
	    set g(Ymove:o) %y
	}
	if [llength $g(Ymove)] {
	    Extra_rect move $g(Ymove) [expr %y-$g(Ymove:o)]
	    set g(Ymove:o) %y
	}
    }
}


# Rectangle management
proc Extra_rect {mode args} {
    global g

    if ![string compare $mode "init"] {
	if ![info exists g(r:geometry)] {
	    new_geo [set g(r:geometry) \
		    "[expr $g(X)-20]x[expr $g(Y)-20]+10+10"]
	}
	set mode "geometry"
	set args $g(r:geometry)
    }

    # geometry: parse string into values
    if ![string compare $mode "geometry"] {
	if [scan $args "%ix%i+%i+%i" X Y x y]!=4 {
	    local_error "Wrong geometry: \"$args\""
	    set x [set y 0]; set X $g(X); set Y $g(Y)
	}
	# convert size to posizion
	incr X $x; incr Y $y
	set g(r:x) $x;	set g(r:y) $y
	set g(r:X) $X;	set g(r:Y) $Y
	set mode "update"
    }

    # move: update one number
    if ![string compare $mode "move"] {
	set what [lindex $args 0]
	set where [lindex $args 1]
	switch $what {
	    x { incr g(r:x) $where; set g(r:x) [local_limit $g(r:x) $g(X)] }
	    y { incr g(r:y) $where; set g(r:y) [local_limit $g(r:y) $g(Y)] }
	    X { incr g(r:X) $where; set g(r:X) [local_limit $g(r:X) $g(X)] }
	    Y { incr g(r:Y) $where; set g(r:Y) [local_limit $g(r:Y) $g(Y)] }
	}
	set mode "update"
    }

    # update: update screen and global var
    if ![string compare $mode "update"] {
	if $g(r:x)>$g(r:X) { set t $g(r:x); set g(r:x) $g(r:X); set g(r:X) $t }
	if $g(r:y)>$g(r:Y) { set t $g(r:y); set g(r:y) $g(r:Y); set g(r:Y) $t }
	new_geo [set g(r:geometry) [format "%ix%i+%i+%i" \
		[expr 1+$g(r:X)-$g(r:x)] [expr 1+$g(r:Y)-$g(r:y)] \
		[expr $g(r:x)] [expr $g(r:y)]]]
	$g(c) coords recto $g(r:x) $g(r:y) $g(r:X) $g(r:Y)
	change_size_hook
	return
    }

    # Update half: coords are right, just redraw it half-size
    if ![string compare $mode "updatehalf"] {
	$g(c) coords recto [expr $g(r:x)/2] [expr $g(r:y)/2] \
		[expr $g(r:X)/2] [expr $g(r:Y)/2]
    }
}


proc Extra_res {} {
    global g

    . config -cursor watch; .xtra config -cursor watch; update
    # Stop video and Destroy images 
    set savelive $g(live); set g(live) 0; Live_Changed
    $g(c) delete image
    Extra_see_done; # Delete background
    if $g(halfsize) { # Back to full size
	set g(halfsize) 0
	Extra_half
    }

    set g(device) $g(device:$g(islores))

    # fix the calibration (we just changed resolution)
    set calib [$g(c_entry) get]; # No errors here
    set g(calib) [expr double($calib)]; # Error possible
    if $g(islores) {
	set g(calib) [expr $g(calib)/2]
    } else {
	set g(calib) [expr $g(calib)*2]
    }
    $g(c_entry) delete 0 end; $g(c_entry) insert 0 $g(calib)

    # close and reopen the "keepopen descriptor"
    close $g(keepopen)
    after 10
    set g(keepopen) [open $g(device)]

    local_getsize $g(device)

    # Re-canvas
    $g(c) config -width $g(X) -height $g(Y)

    # Re-create the image
    create_image

    # Resize the rectangle to fit the image
    Extra_rect move x 0; Extra_rect move X 0; 
    Extra_rect move y 0; Extra_rect move Y 0; 
    $g(c) raise recto

    # Acquire one image
    set g(live) $savelive; Live_Changed; # Restore "live"
    if !$g(live) { # Acquire one anyways
	set g(live) 1; LiveGrab; set g(live) 0
    }
    update; . config -cursor ""; .xtra config -cursor ""; update
}

proc Extra_half {} {
    global g
    # This is invoked when the image size is changed
    # It only works with pacco
    if !$g(pacco) return

    Extra_see_done; # destroy the background
    if $g(halfsize) {

	# From full to half-size
	set size [img.it info features]
	scan $size  "%i %i" x y
	set x [expr $x/2]; set y [expr $y/2]

	# "half" objects, automatically updated
	obox half "{Img_lflt it $x $y} {Img_lflt bg $x $y}"; # New box
	img.it bind <Data> + "half.it reduce -avg img.it"
	img.bg bind <Data> + "half.bg reduce -avg img.bg"

	# Destroy the image and remove bindings (unbind img.it)
	$g(c) delete image; img.it bind <Data> "half.it reduce -avg img.it"
	$g(c) config -width $x -height $y; # Recreate it, half size
	$g(c) create pacmap 0 0 [expr $x-1] [expr $y-1] \
		-link half.it -tag image
	half.it bind <Data> "$g(c) itemconfig image -update 1"
	
	# The rectange is now inactive
	$g(c) itemco recto -outline $g(inactiverectcolor)
	$g(c) raise recto
	Extra_rect updatehalf
	Extra_bindings 0

    } else {

	# From half to full-size
	set x $g(X); set y $g(Y)
	# Destroy "half" objects and their bindings
	img.it bind ""; img.bg bind ""; half destroy

	# Restore image in canvas
	$g(c) delete image
	$g(c) config -width $x -height $y; # Recreate it, full size
	$g(c) create pacmap 0 0 [expr $x-1] [expr $y-1] \
		-link img.it -tag image
	img.it bind <Data> "$g(c) itemconfig image -update 1"

	# Re-create rectangle bindings
	$g(c) itemco recto -outline $g(activerectcolor)
	$g(c) raise recto
	Extra_rect update
	Extra_bindings 1
    }
}

proc Extra_load {} {
    global g

    if [file exists $g(configfile)] {
	source $g(configfile)
    }
    if ![info exists g(calib)] { # Can't "||" reliably...
	set g(calib) 2.8; # Default
    }
    if ![llength $g(calib)] {
	set g(calib) 2.8
    }
    # calibration is always saved in lo-res
    if !$g(islores) {set g(calib) [expr 2* $g(calib)]}
    foreach n "gain add bgwidth" {
	Extra_set$n $g($n)
    }
    Extra_rect init
    $g(c_entry) delete 0 end; $g(c_entry) insert 0 $g(calib)
}

proc Extra_save {} {
    global g
    set g(calib) [$g(c_entry) get]
    set F [open $g(configfile) w]
    puts $F "global g"
    # Save calibration as lo-res
    set savecalib $g(calib)
    if !$g(islores) {set g(calib) [expr $g(calib)/2]}
    foreach n "gain add bgwidth acqlen acqstep calib r:geometry" {
	puts $F "set g($n) $g($n)"
    }
    set g(calib) $savecalib
    close $F
}

proc Extra_setgain value {
    global g

    set g(gain:flag) 1
    # if gain is one, avoid the multiplication
    if $g(gain)==1 {set g(gain:flag) 0}

    # Bah, passing on the scale invokes its command. Why?
    if $g(gain)!=$g(prevgain) {
	set g(avoidfilters) 0
	set g(prevgain) $g(gain)
    }
}

proc Extra_setadd value {
    global g

    set g(add:flag) 0
    # if add is not 0, mark it
    if $g(add) {set g(add:flag) 1}
    set g(avoidfilters) 0
}

proc Extra_setbgwidth {args} {
    global g
    # This function only works with pacco
    if !$g(pacco) return

    set value $g(bgwidth)
    if [llength $args] {set value $args}
    set g(bgwidth:flag) 0
    # if it is not 0, mark it
    if $g(bgwidth) {
	set g(bgwidth:flag) 1
	catch {mask destroy}
	### Instead of a rectangle, use two segments
	# obox mask "{Tpl_lflt m $g(bgwidth) $g(bgwidth)}"
	# mask.m clear [expr 1.0/$g(bgwidth)/$g(bgwidth)]
	obox mask "{Tpl_lflt h $g(bgwidth) 1} {Tpl_lflt v 1 $g(bgwidth)}"
	mask.h clear [expr 1.0/$g(bgwidth)]
	mask.v clear [expr 1.0/$g(bgwidth)]
	. config -cursor watch; .xtra config -cursor watch; update
	img.tmp import $g(device)
	#img.bg conv img.tmp mask.m
	img.bg conv img.tmp mask.h; img.bg conv img.bg mask.v
	. config -cursor ""; .xtra config -cursor ""
    } else {
	img.bg clear 0
    }
    set g(avoidfilters) 0
}


proc Extra_done tl {
    global g

    if $g(halfsize) { # Back to full size
	set g(halfsize) 0
	Extra_half
    }
    proc change_size_hook args {}; # Prevent errors
    set g(avoidfilters) 1; # Display original when we are back
    $g(c) delete recto
    destroy $tl
    Extra_see_done
    .b.xtra config -state normal
}

proc Extra_step {label value} {
    global g
    
    set sec  [expr 2.0*$value/$g(frequency)]
    set s [expr int($sec)]
    set ms [expr int(1000*($sec-$s))]
    $label config -text [format "One image every %i.%03i seconds" $s $ms]
    change_size_hook
}

proc calc_maxbuffer {} {
    set F [open "| grep MemTotal: /proc/meminfo"]
    gets $F string; close $F
    return [expr [lindex $string 1]/250/2]; # Use half memory at most
}

proc Extra_acq {} {
    global g
    if $g(pacco) {
	exec rm -f $g(bgimg)
	img.bg export -pgm $g(bgimg)
    }
    # stop acquisition
    set g(live) 0; Live_Changed

    #Calculate the number of images
    set n [expr $g(frequency)/2*$g(acqlen)]
    set n [expr int($n/$g(acqstep))]

    # calculate the buffersize -- 
    set bufsize $g(defaultbuffer)
    if $g(acqstep)<5 {
	set bufsize [calc_maxbuffer]
    }
    if $g(islores) {set bufsize [expr 4*$bufsize]}
    if $bufsize>$n {
	set bufsize $n
    }

    # retrieve the name and the calibration
    Extra_NewName
    set g(name) [string trim [$g(n_entry) get]]
    set calib [$g(c_entry) get]; # No errors here
    set g(calib) [expr double($calib)]; # Error possible
    set g(calib) [expr 1/$g(calib)]; # Error possible (need um/pixel)


    set cmdline "pxc_grab -M $bufsize -g $g(gain) -a $g(add) -s $g(acqstep) \
	     -n $n -o $g(name) -b $g(bgimg) -r $g(r:geometry) $g(device)"
    if !$g(pacco) {
	# No pacco, the cmdline is simpler
	set cmdline "pxc_grab -M $bufsize -s $g(acqstep) \
	     -n $n -o $g(name) -r $g(r:geometry) $g(device)"
    }
    puts $cmdline
    . config -cursor watch; .xtra config -cursor watch; update
    . config -cursor ""; .xtra config -cursor ""

    set result [catch {eval exec $cmdline} msg]
    exec mkdir $g(name)

    ### Post-acquire work: remove background, add extra info
    exec rm -f $g(bgimg)
    set F [open $g(name)/params w] 
    set step [expr 2.0/$g(frequency) * $g(acqstep)]
    puts $F "calib $g(calib) um/pixel"
    puts $F "step $step s"
    close $F
    Extra_NewName
    if $result {
	tk_dialog .error "Erro in acquisition" $msg "" 0 Ok
    }
}

proc Extra_see {} {
    global g
    toplevel .bg
    wm title .bg "Background"
    if $g(halfsize) {
	half.bg reduce -avg img.bg
	pacco/display .bg.bg half.bg
    } else {
	pacco/display .bg.bg img.bg
    }
    $g(win:bgbutton) config -state disabled
    pack [button .bg.done -text Done -command "Extra_see_done"] \
	    -expand yes -fill x
}

proc Extra_see_done {} {
    global g
    catch {$g(win:bgbutton) config -state normal}
    catch {destroy .bg}
}

proc Extra_NewName {} {
    global g

    set name $g(name)
    if ![llength $name] {
	set name [format "seq%i.00"  [exec date {+%y%m%d}]]
    }
    while {[file exists $name]} {
	# trim numbers, and increment it
	for {set i [string length $name]; incr i -1} {$i>=0} {incr i -1} {
	    set c [string index $name $i]
	    if ![string match {[0-9]} $c] break
	}
	incr i
	#puts "-$name-$i-"
	set ndigits [expr [string length $name] - $i]
	#puts "ndigits $ndigits"
	if !$ndigits {set name $name.01; continue}
	set n [string trimleft [string range $name $i end] 0]
	if ![llength $n] {set n 0}
	set n [expr "1 + $n"]
	set name [format %s%0${ndigits}i [string range $name 0 [incr i -1]] $n]
	#puts "name $name"
    }
    $g(n_entry) delete 0 end; $g(n_entry) insert 0 $name
    return $name
}

######################################################## Local (generic) stuff

proc local_limit {curr max} {
    if $curr<0 {return 0}
    if $curr>=$max {return [expr $max-1]}
    return $curr
}

proc local_getsize file {
    global g

    # Retrieve the image size from the head of the file
    set H [open $file]; gets $H string; close $H
    scan  $string "P5 %i %i" g(X) g(Y)
    set g(Xc) [expr $g(X)/2]; set g(Yc) [expr $g(Y)/2]; # center coords
}

proc local_tmpname base {
    set n 0
    while {[file exists  /tmp/$base.$n]} {incr n}
    return /tmp/$base.$n
}

proc local_place {win} {
    wm withdraw $win
    update
    set WID [winfo screenwidth $win]
    set HEI [winfo screenheight $win]
    set wid [winfo reqwidth $win]
    set hei [winfo reqheight $win]
    set x [expr ($WID-$wid)/2]; if $x<0 {set x 0}
    set y [expr ($HEI-$hei)/2]; if $y<0 {set y 0}
    wm geometry $win +$x+$y
    wm deiconify $win
}

proc local_error string {
    global g

    toplevel .le
    pack [label .le.l -text $string] -padx 3m -pady 3m
    local_place .le
    update
    after 1000
    destroy .le
}

proc local_df {} {
    set G [open "|df ." r]
    gets $G; gets $G string; close $G
    return [expr [lindex $string 3]/1024]
}

proc local_size {} {
    global g

    scan $g(r:geometry) "%dx%d" x y
    set acqlen [expr $g(frequency)/2*$g(acqlen)]
    set acqlen [expr int($acqlen/$g(acqstep))]
    set size [expr $x*$y*$acqlen/1024.0/1024.0]
    set i [expr int($size)]
    set j [expr int(1000*($size-$i))]
    return [format "%i.%03i" $i $j]
}

proc local_color {color args} {
    global g

    foreach n $args {
	$n configure -foreground          [lindex $g(color:$color) 0]
	$n configure -background          [lindex $g(color:$color) 1]
	# Labels have no active*ground, so catch any error
	catch {$n configure -activeforeground    [lindex $g(color:$color) 0]}
	catch {$n configure -activebackground    [lindex $g(color:$color) 2]}
    }
}


######################################################## Spin the wheel

# This is a procedure invoked with "after"; this way
# any errors are reported using the tk error mechanism
# (otherwise, errors would go to stderr and are not visible if you invoke
# the program through the window manager menus)

proc main {} {
    global g argv0

    set g(device) $g(device:$g(islores))

    ### Initial setup
    # I use to "source" this file to interactively test new versions,
    # so destroy first
    catch {eval destroy [winfo children .]}
    if $g(pacco) {foreach n [pacco info boxes] {$n destroy}}
    catch {close $g(keepopen)}

    # Keep the file open, to maximize perfomance
    if [catch {set g(keepopen) [open $g(device) r]} msg] {
	puts stderr "$argv0: $msg"
	exit 1
    }

    # Use an external image, as some versions of wish are not able to
    # load from a device node.
    set g(img) [local_tmpname cxg_xgrab.img]
    set g(bgimg) [local_tmpname cxg_xgrab.bg]

    exec cp $g(device) $g(img)
    if ![file size $g(img)] {
	puts "error in grabbing file"
	exit 1
    }

    local_getsize $g(device)

    # And remember whether we are PAL or NTSC
    set g(frequency) 50;
    if "$g(X)==640 || $g(X)==320" {set g(frequency) 60}

    ### Pack the image frame
    pack [frame .f  -relief ridge -borderwidth 3] -side top -expand yes
    pack [set g(c) [canvas .f.canv -width $g(X) -height $g(Y)]] -padx 2 -pady 2
    create_image; # After creating the canvas, as this plugs in it

    if $g(pacco) {
	obox minmax "{Img_lflt max 1 1} {Img_lflt min 1 1}"
    }

    ### Buttons
    pack [frame .b] -fill both
    button .b.run  -command "Run"   -text "Run" 
    button .b.stop -command "Stop"  -text "Stop"
    button .b.save -command "Save"  -text "Save"
    button .b.xtra -command "Extra" -text "Extra..."
    button .b.quit -command "Quit"  -text "Quit"
    foreach n "run stop save xtra quit" {
	.b.$n config -disabledforeground $g(disabledfg)
    }
    pack .b.run .b.stop .b.save .b.xtra .b.quit \
	    -side left -expand yes -fill both

    pack [label .botlab -text "Use \"s\" for Save, \"q\" for Quit,\n\
	    space to toggle live video"] -side right -expand y
    pack [checkbutton .check -text "Live Video" -variable g(live) \
	    -command  Live_Changed] -anchor e
    set g(checkbutton) .check

    bind all <space> {if !$g(saving) {.check invoke}}
    bind all <s> {if !$g(saving) Save}
    bind all <q> {if !$g(saving) Quit}
    bind all <Control-c> {Quit}
    update
    Run
}

after 0 main
