#!/usr/local/bin/perl
#
# ( insert GRL text)
#
# squeek.pl - prototype GUI for Anitrack mouse editor
# pw6 from  11/09/05, based on my notebook code


# required general libraries:
use strict;
use Tk;
use Tk::Dialog;
use Tk::Frame;
use Tk::HList;
use Tk::MainWindow;
use Tk::NoteBook;
use Tk::ProgressBar;
use Tk::LabEntry;
use Tk::Pane;
# 10/11/05:
use Tk::BrowseEntry;

# required SI site-specific libraries:
use SITk::Status;  	# to update status bar
use User; 		# user validation, needed for logon
use Checkbarcode2;	# to handle barcode entries


# data access:
use GTx; # commment this out for development outside office
# use ATR::GTx;

# constants:
use constant ROLETYPE => 'ANITRACK';
use constant ENTRY_COLOUR => 'pale green';
use constant NON_ENTRY_COLOUR => 'grey85';
use constant LOGIN => 'anitrack_b'; # use the test AniTrack database, see DBlogs

# font constants from AtrMain:
use constant TITLE_FONT => "-*-times-bold-r-normal-*-*-240-*-*-p-*-*";
use constant DATA_FONT => "-*-helvetica-medium-r-normal-*-*-140-*-*-*-*-iso8859-1";
use constant LABEL_FONT => "-adobe-helvetica-normal-r-normal-*-*-180-100-100-*-*-iso8859-1";
use constant BUTTON_FONT => "-adobe-helvetica-bold-r-normal-*-*-140-100-100-*-*-iso8859-1";
use constant ENTRY_FONT => "-adobe-courier-medium-r-normal-*-*-240-*-*-*-*-iso8859-*";
use constant ENTRY_BG => "white";


# development tool 8)
my $debug = 0;

# controller/business rules, and data interface broker:
use lib '.';
use anitrack_controller; # comment this out for non-Sanger work
use anitrack_broker; # ditto
use anitrack_data_access2; # ditto
use squeek_analysis; # gives events for history 
use squeek_data_access; # events viewer and mouse editor data access code
# 11/11/05, make the events viewer a sub not a system call:
use events;



# get a mouse if entered:
my $mouse = $ARGV[0];
print "Mouse is $mouse\n";
if (! $mouse) {
	# 17/11/05, hacked to run from an icon:
	print "Using a default mouse ...\n";
	$mouse = 'DD6.3a';
	# die "\n\nUsage: squeek.pl <mousename>\n";
}
# 10/11/05:
my @shown_items = ();
my $mouse_id;

# 11/11/05:
my $auto_arrange = 1; # set this to 1 for pretty layout, 0 for positioning by db time with overlays

my $title = "Mouse Viewer - Prototype GUI";
my $mw = MainWindow->new();
# LATER: need to implement fullscreen ...
my $width = 850;
my $height = 600;
$mw->wm('minsize', $width, $height);
# $mw->FullScreen;
# $mw->packPropagate(0);
$mw->title($title);

my $status_bar = $mw->Status(-selfpack=>1);
# try putting buttons frame at bottom of all pages:
my $but_f = $mw->Frame( Name 	=> 'buttons_f')->pack(-side	=> 'bottom');
				# ->form(	-left	=> '%0',
					# -right	=> '%100',
					# -bottom => '%98');
my $pedigree_button = $but_f->Button(	-text	=> 'Pedigree',
					-font	=> BUTTON_FONT,
					# ******* WARNING: HARDCODED PATH!!!!!!!!!
					# ******* ANOTHER WARNING - 'system' waits till showped is finished
	# changed for windows				-command=> sub { system("/usr/local/bin/perl GT/Project/Anitrack/showPed.pl $mouse"); })
					-command=> sub { system("perl GT/Project/Anitrack/showPed.pl $mouse"); })
					->pack(	-side	=> 'left',
						-anchor	=> 's');
my $find_button = $but_f->Button(	-text	=> 'Find ...',
					-font	=> BUTTON_FONT,
					-command=> \&find)
					->pack(	-side	=> 'left',
						-anchor	=> 's');
my $jump_button = $but_f->Button(	-text	=> 'Jump to ...',
					-font	=> BUTTON_FONT,
					-command=> \&jump)
					->pack(	-side	=> 'left',
						-anchor	=> 's');
my $transfer_button = $but_f->Button(	-text	=> 'Transfer ...',
					-font	=> BUTTON_FONT,
					-command=> [ \&transfer_mouse ])
					->pack(	-side	=> 'left',
						-anchor	=> 's');
my $mate_button = $but_f->Button(	-text	=> 'Mate ...', 
					-font 	=> BUTTON_FONT,
					-command=> [ \&mate_mouse ])
					->pack( -side	=> 'left',
						-anchor	=> 's');
# my quit button:
$but_f->Button( -fg 	=> 'purple', 
		-text 	=> 'Quit',
		-font	=> BUTTON_FONT, 
		-command=> sub { if ( &confirm( 'Quit' )) { $mw->destroy();} } )
		->pack(	-side	=> 'right',
			-anchor	=> 's');


my ($nb, $p1, $procedures_page, $comments_page, $history_page, $report_page, $report_field);
my $report_card_name = "Reports";

# make a notebook:
$nb = $mw->NoteBook()->pack(	-expand	=> 1,
				-fill	=> 'both');


# 02/08/05, check whether user has entered anything:
# use entry's -validatecommand option to set %changed_data{$cardname} to 1 if key pressed in entry
my %changed_data = (); 	

# 11/08/05, knowing what today is will be helpful:
my ($day, $month, $year) = (localtime) [3, 4, 5];
$month++;
if ( $month < 10 ) {
	$month = '0' . $month;
}
my $date_today = $day . '-' . $month .'-' . substr(($year + 1900), -2) ; 
			
my @comments = (); # loaded in displayOverview when mouse info loaded - may change for multiple comments
my @events = (); # to load the history page
$mouse_id = get_id_from_name($mouse); # note: need to handle this failing more gracefully
my $results_ref = single_mouse_details($mouse_id); # in anitrack_data_access
my %results = %$results_ref;

setup();
displayOverview();
loadProcedures();
showComments();
showHistory();

# 10/11/05:
push @shown_items, $mouse;

MainLoop;		
	
sub setup {
	@comments = ();
	@events = ();
	# will need to check for changed data before this:
	%changed_data = ();
	# do the mouse life analysis:
	my ($analysis_ref, $events_ref) = analyse_life($mouse);
	@events = @$events_ref;
	# add first page:
	$p1 = $nb->add('page1', 	-label		=> "Mouse $mouse",
					-raisecmd	=> sub{ $status_bar->show("Enter a mouse ID to see its details") });
	# add other pages for other data:
	$procedures_page = $nb->add('proc_page', 	-label	=> 'Procedures');
	$comments_page = $nb->add('comments_page', 	-label 	=> 'Comments');
	$history_page = $nb->add('history_page',	-label	=> 'History');
	
}

sub displayOverview {
	my $changed_data = 0;
	my $hf = $p1->Frame( 	Name 	=> 'head_f', 
				-border => 2,
				-relief => 'groove')
				->form(	-top 	=> '%0', 
					-left 	=> '%0',
					-right	=> '%100');
	$hf->Label(	-class 	=> 'title', 
			-text 	=> "$mouse",
			-font	=> TITLE_FONT)
			->form(	-left 	=> '%35', # bodge ...
				-top	=> '%0');
	
	
	# barcode/jumpquery/navigation frame:
	my $nav_f = $p1->Frame(	Name	=> 'nav_f',
				-border	=> 2,
				-relief	=> 'sunken')
				->form( -left	=> '%0',
					-right	=> '%100',
					-top	=> $hf);
	# barcode setup and behaviour:
	my $bar = '';
	my $bar_l; 
	# 10/11/05, what about a list of previously viewed mice?
	if ($#shown_items > -1) {
		for my $i (0 .. $#shown_items) {
			print "Seen: $i: $shown_items[$i]\n";
		}
	}
	my $bar_e;
	# make this a browseEntry:
	$bar_e = $nav_f->BrowseEntry(	-label => "Show new mouse: ",
					-labelFont	=> TITLE_FONT,
					-background => 'white',
					# -labelBackground => 'grey',
					-variable => \$bar)
					->form(	-left	=> ['%0', 16],
						-top	=> ['%0', 16],
						-right	=> ['%100', -16]);
	if ($#shown_items > -1) {
		for my $i (0 .. $#shown_items) {
			$bar_e->insert("end", $shown_items[$i]);
		}
	}
	# else {
		# $bar_l = $nav_f->Label( 	-text	=> "Show new mouse:",
					# -font	=> LABEL_FONT )
					# ->form(	-left	=> ['%0', 16],
						# -top	=> ['%0', 16]);
		# $bar_e = $nav_f->Entry(	-textvariable => \$bar)
					# ->form(	-left	=> $bar_l,
						# -top 	=> ['&', $bar_l],
						# -right	=> ['%100', -16]);
	# }
	$bar_e->bind('<Return>' 	=> sub { &barcode($bar); $bar = ''; });
	# use Jennifer's constants here?
	#$bar_e->bind('<FocusIn>'	=> sub { $bar_e->configure(-background => 'lightgreen') });
	#$bar_e->bind('<FocusOut>'	=> sub { $bar_e->configure(-background => 'white') });
	$bar_e->focus;
	
	# get the overview information about this mouse:
	# now moved earlier:
#	my $results_ref = single_mouse_details($mouse_id); # in anitrack_data_access
#	my %results = %$results_ref;
	my ($sex, $dob, $genotype, $ear_mark, $coat_colour, $dna_number);
	foreach my $i (sort keys %results) {
	#	print "$i: $results{$i}\n";
		if ($i =~ m/Coat/) {
			$coat_colour = $results{$i};
		}
		if ($i =~ m/_SEX/) {
			$sex = $results{$i};
		}
		if ($i =~ m/genotype/) {
			$genotype = $results{$i};
		}
		if ($i =~ m/date of birth/) {
			$dob = $results{$i};
		}
		if ($i =~ m/Comment/) {
			push @comments, $results{$i};
		}
			 
	}
	
	
	# make a frame to hold the overview information:
	my $overview_f = $p1->Frame(	Name		=> 'overview_f',
					-borderwidth	=> 1,
					-relief		=> 'sunken')
					->form(	-left 	=> '%30',
						-right	=> '%70',
						-top	=> $nav_f);
	$overview_f->LabEntry(		Name	=> 'Sex',
					-textvariable	=> \$sex,
					-label		=> 'Sex: ',
					-labelFont	=> LABEL_FONT,
					-font		=> LABEL_FONT,
					-background	=> ENTRY_BG,
					-width 		=> 10,
					-validate	=> 'key',
					-validatecommand	=> sub { $changed_data = 1; },
					-labelPack	=> [ -side	=> 'left'])
					->pack(	-side	=> 'top',
						-fill	=> 'both', 
						-expand	=> 0);
	$overview_f->LabEntry(		Name		=> 'DOB',
					-textvariable	=> \$dob,
					-label		=> 'DOB: ',
					-labelFont	=> LABEL_FONT,
					-font		=> LABEL_FONT,
					-background	=> ENTRY_BG,
					-width 		=> 10,
					-validate	=> 'key',
					-validatecommand	=> sub { $changed_data = 1; },
					-labelPack	=> [ -side	=> 'left'])
					->pack(	-side	=> 'top',
						-fill	=> 'both', 
						-expand	=> 0);
	$overview_f->LabEntry(		Name		=> 'Genotype',
					-textvariable	=> \$genotype,
					-label		=> 'Genotype: ',
					-labelFont	=> LABEL_FONT,
					-font		=> LABEL_FONT,
					-background	=> ENTRY_BG,
					-width 		=> 10,
					-validate	=> 'key',
					-validatecommand	=> sub { $changed_data = 1; },
					-labelPack	=> [ -side	=> 'left'])
					->pack(	-side	=> 'top',
						-fill	=> 'both', 
						-expand	=> 0);
	$overview_f->LabEntry(		Name		=> 'Ear_mark',
					-textvariable	=> \$ear_mark,
					-label		=> 'Ear mark: ',
					-labelFont	=> LABEL_FONT,
					-font		=> LABEL_FONT,
					-background	=> ENTRY_BG,
					-width 		=> 10,
					-validate	=> 'key',
					-validatecommand	=> sub { $changed_data = 1; },
					-labelPack	=> [ -side	=> 'left'])
					->pack(	-side	=> 'top',
						-fill	=> 'both', 
						-expand	=> 0);
	$overview_f->LabEntry(		Name		=> 'Coat_colour',
					-textvariable	=> \$coat_colour,
					-label		=> 'Coat colour: ',
					-labelFont	=> LABEL_FONT,
					-font		=> LABEL_FONT,
					-background	=> ENTRY_BG,
					-width 		=> 10,
					-validate	=> 'key',
					-validatecommand	=> sub { $changed_data = 1; },
					-labelPack	=> [ -side	=> 'left'])
					->pack(	-side	=> 'top',
						-fill	=> 'both', 
						-expand	=> 0);
				
	
}
	
sub loadProcedures {
	my $changed_data = 0;
	my $label_width = 12;
	my $procedure_count = 12; # 1 more than will appear; will need to modify this if more exist
	my $header_count = 5; # 1 less than will appear
	my %header_positions = (); # used to fill slots with correct data
	$header_positions{'date'} = 0;
	$header_positions{'name'} = 1;
	$header_positions{'performed by'} = 2;
	$header_positions{'authority'} = 3;
	$header_positions{'PPL'} = 4;
	$header_positions{'PIL'} = 5;
	my @data_grid = ();
		
#	my $procedures_f = $procedures_page->Frame(	Name	=> 'overview_f',
	my $results_ref = get_mouse_procedures($mouse_id);
	my %results = %$results_ref;
	# print "results ref  is $results_ref, resulst is ", scalar %results, "\n";
	if (scalar %results == 0) {
		print "No procedures found for $mouse.\n";
	} 
	else {
		foreach my $i (sort keys %results) {
			print "$i: $results{$i}\n";
			# load into a grid for putting into textvariables:
			$i =~ m/Procedure (\w+\s?\w*)\s(\d+)/;
			print "This is number $2 of $1\n";
			if (defined $header_positions{$1}) {
				$data_grid[$header_positions{$1}][$2] = $results{$i};
				print "Loaded $results{$i} into data_grid at $header_positions{$1}, $2\n";
			}
			else {
				print "No slot for $1 ...\n";
			}
		}
	}
	my $procedures_f = $procedures_page->Scrolled(	'Frame',
							-scrollbars	=> 'oe',
							Name		=> 'overview_f',
							-borderwidth	=> 1,
							-relief		=> 'sunken')
							->form(	-left 	=> '%0',
								-right	=> '%100');
	$procedures_f->Label(		-text	=> 'Date',
					-font	=> LABEL_FONT,
					-relief	=> 'ridge',
					-width 	=> $label_width)
					->grid( -row	=> 0,
						-column => 0,
						-sticky	=> 'nsew');
	$procedures_f->Label(		-text	=> 'Procedure',
					-font	=> LABEL_FONT,
					-relief	=> 'ridge',
					-width 	=> $label_width)
					->grid( -row	=> 0,
						-column => 1,
						-sticky	=> 'nsew');
	$procedures_f->Label(		-text	=> 'Performed by',
					-font	=> LABEL_FONT,
					-relief	=> 'ridge',
					-width 	=> $label_width)
					->grid( -row	=> 0,
						-column => 2,
						-sticky	=> 'nsew');
	$procedures_f->Label(		-text	=> "Under\ndelegated\nauthority",
					-font	=> LABEL_FONT,
					-relief	=> 'ridge',
					-width 	=> $label_width)
					->grid( -row	=> 0,
						-column => 3,
						-sticky	=> 'nsew');
	$procedures_f->Label(		-text	=> "PPL",
					-font	=> LABEL_FONT,
					-relief	=> 'ridge',
					-width 	=> $label_width)
					->grid( -row	=> 0,
						-column => 4,
						-sticky	=> 'nsew');
	$procedures_f->Label(		-text	=> "PIL",
					-font	=> LABEL_FONT,
					-relief	=> 'ridge',
					-width 	=> $label_width)
					->grid( -row	=> 0,
						-column => 5,
						-sticky	=> 'nsew');
	# put in the slots for procedure details:
	for my $i (0 .. $header_count) {
		for my $j (1 .. $procedure_count) {
			my $proc_id = ($j - 1);
			# print "Text variable is $data_grid[$i][$proc_id]\n";
			$procedures_f->Entry( #	Name	=> "proc_$i" . '_' ."$j",
								-textvariable	=> \$data_grid[$i][$proc_id],
								-width 	=> $label_width,
								-font	=> LABEL_FONT,
								-background	=> ENTRY_BG)
								->grid( -row	=> $j,
									-column => $i,
									-sticky	=> 'nsew');
		}
	}
	# configure the frame to a decent size:   
	$procedures_f->configure(	-height	=> 450);
	
	
	# put in a frame for a 'new procedure' button: 
	my $add_but_f = $procedures_page->Frame( Name 	=> 'buttons_f')->pack(-side	=> 'bottom');
				
	my $find_button = $add_but_f->Button(	-text	=> 'Add ...',
						-font	=> BUTTON_FONT,
						-command=> sub { $procedure_count++; 
							print "Procedure count is now $procedure_count\n";
							for my $i (0 .. $header_count) {
							$procedures_f->Entry( 
									 -width 		=> $label_width,
									 -font			=> LABEL_FONT,
									 -background		=> ENTRY_BG)
									 ->grid( -row		=> $procedure_count,
										 -column 	=> $i,
										 -sticky	=> 'nsew');
							}
							
						})->pack( -side	=> 'left',
						-anchor	=> 's');
	
	
}

sub showComments {
	my $changed_data = 0;
	my $comments_count = 12; # 1 more than will appear; will need to modify this if more exist
	my $header_count = 2; # 1 less than will appear
	my $comments_f = $comments_page->Scrolled(	'Frame',
							-scrollbars	=> 'oe',
							Name		=> 'comments_f',
							-borderwidth	=> 1,
							-relief		=> 'sunken')
							->form(	-left 	=> '%0',
								-right	=> '%100');
	$comments_f->Label(		-text	=> 'Date',
					-font	=> LABEL_FONT,
					-relief	=> 'ridge',
					-width 	=> 10)
					->grid( -row	=> 0,
						-column => 0,
						-sticky	=> 'nsew');
	$comments_f->Label(		-text	=> 'Comment',
					-font	=> LABEL_FONT,
					-relief	=> 'ridge',
					-width 	=> 60)
					->grid( -row	=> 0,
						-column => 1,
						-sticky	=> 'nsew');
	$comments_f->Label(		-text	=> 'Display',
					-font	=> LABEL_FONT,
					-relief	=> 'ridge',
					-width 	=> 7)
					->grid( -row	=> 0,
						-column => 2,
						-sticky	=> 'nsew');
	# put in the slots for comments:
	for my $j (1 .. $comments_count) {
		$comments_f->Entry( 	#-textvariable	=> \$data_grid[$i][$proc_id],
					-width 	=> 10,
					-font	=> LABEL_FONT,
					-background	=> ENTRY_BG)
					->grid( -row	=> $j,
						-column => 0,
						-sticky	=> 'nsew');
		$comments_f->Entry( 	-textvariable	=> \$comments[($j-1)],
					-width 	=> 60,
					-font	=> LABEL_FONT,
					-background	=> ENTRY_BG)
					->grid( -row	=> $j,
						-column => 1,
						-sticky	=> 'nsew');
		$comments_f->Entry( 	#-textvariable	=> \$data_grid[$i][$proc_id],
					-width 	=> 7,
					-font	=> LABEL_FONT,
					-background	=> ENTRY_BG)
					->grid( -row	=> $j,
						-column => 2,
						-sticky	=> 'nsew');
		
	}
	# configure the frame to a decent size:   
	$comments_f->configure(	-height	=> 450);
	
}

sub showHistory {
	my $changed_data = 0;
	my $events_count = 12; # 1 more than will appear; will need to modify this if more exist
	my $header_count = 3; # 1 less than will appear
	
	# should get the data in the overview stage, as may (later) need to generate a warnings page
	# will show page even if no events as may want to use this to add them
	
	
	# build the page:
	my $events_f = $history_page->Scrolled(	'Frame',
							-scrollbars	=> 'oe',
							Name		=> 'events_f',
							-borderwidth	=> 1,
							-relief		=> 'sunken')
							->form(	-left 	=> '%0',
								-right	=> '%100');
	$events_f->Label(		-text	=> 'Start',
					-font	=> LABEL_FONT,
					-relief	=> 'ridge',
					-width 	=> 10)
					->grid( -row	=> 0,
						-column => 0,
						-sticky	=> 'nsew');
	$events_f->Label(		-text	=> 'End',
					-font	=> LABEL_FONT,
					-relief	=> 'ridge',
					-width 	=> 10)
					->grid( -row	=> 0,
						-column => 1,
						-sticky	=> 'nsew');
	$events_f->Label(		-text	=> 'Event',
					-font	=> LABEL_FONT,
					-relief	=> 'ridge',
					-width 	=> 50)
					->grid( -row	=> 0,
						-column => 2,
						-sticky	=> 'nsew');
	$events_f->Label(		-text	=> 'Current?',
					-font	=> LABEL_FONT,
					-relief	=> 'ridge',
					-width 	=> 7)
					->grid( -row	=> 0,
						-column => 3,
						-sticky	=> 'nsew');
	# put in the slots for event details:
	for my $j (1 .. $events_count) {
		my $event_index = $j -1;
		my ($event, $mouse_start, $mouse_end, $db_start, $db_end, $is_current);
		if (defined $events[$event_index]) {
			($event, $mouse_start, $mouse_end, $db_start, $db_end, $is_current) = split /\t/, $events[$event_index];
		}
		$events_f->Entry( 	-textvariable	=> \$mouse_start,
					-width 	=> 10,
					-font	=> LABEL_FONT,
					-background	=> ENTRY_BG)
					->grid( -row	=> $j,
						-column => 0,
						-sticky	=> 'nsew');
		$events_f->Entry( 	-textvariable	=> \$mouse_end,
					-width 	=> 10,
					-font	=> LABEL_FONT,
					-background	=> ENTRY_BG)
					->grid( -row	=> $j,
						-column => 1,
						-sticky	=> 'nsew');
		$events_f->Entry( 	-textvariable	=> \$event,
					-width 	=> 50,
					-font	=> LABEL_FONT,
					-background	=> ENTRY_BG)
					->grid( -row	=> $j,
						-column => 2,
						-sticky	=> 'nsew');
		$events_f->Entry( 	-textvariable	=> \$is_current,
					-width 	=> 7,
					-font	=> LABEL_FONT,
					-background	=> ENTRY_BG)
					->grid( -row	=> $j,
						-column => 3,
						-sticky	=> 'nsew');
		
	}
	# configure the frame to a decent size:   
	$events_f->configure(	-height	=> 450);
	# put in a frame for a 'show history graphically' button: 
	my $history_but_f = $history_page->Frame( Name 	=> 'buttons_f')->pack(-side	=> 'bottom');
	my $events_ref = \@events;		
	my $history_button = $history_but_f->Button(	-text	=> 'Graphical view (prototype version) ...',
							-font	=> BUTTON_FONT,
							# ******* WARNING: HARDCODED PATH!!!!!!!!!
							# ******* ANOTHER WARNING - 'system' waits till events6 is finished
# moved for windows							-command=> sub { system("/usr/local/bin/perl events5.pl $mouse"); }
							# -command => sub { system("perl events5b.pl $mouse $events_ref &"); }

							# now a sub:
							-command	=> [ \&display_events, $mouse, $events_ref, $auto_arrange ]
							
						)->pack( -side	=> 'left',
						-anchor	=> 's');
	
}

sub confirm {
	my $context = $_[0];
	my $reply = $mw->Dialog(-title 		=> $context,
				-text 		=> 'Are you sure?',
				-default_button => 'No',
				-buttons	=> ['Yes', 'No'],
				-bitmap		=> 'question')->Show();
	# if ( $reply ne 'Yes' ) { return 0; } 
	# $mw->destroy();
	return ( $reply ne "Yes" ? 0 : 1 );
}

# stuff to go to business rules:
sub barcode {
	my $entered = $_[0];
	# $status_bar->show("Barcode handling is a work in progress: $entered ...",
				# -relief	=> 'sunken');
	# from mca:
	if ($entered =~ m/^\d{8,}$/ || $entered =~ m/^[A-Z]{2}\d+[A-Z]/) {
		# it's possibly a barcode:
		my $hash_return_ref = Checkbarcode2::Verifynumber($entered, "AM");
		my %hash_return = %$hash_return_ref;
		# TO DO: for some reason, verifynumber doesn't like me doing this ...
		if ($hash_return{Process} eq 'Good') {
			$status_bar->show("Good barcode $hash_return{Type} $hash_return{Number} ...",
				-relief	=> 'sunken');
		} else { 
			$status_bar->show("Bad barcode! Naughty barcode! $hash_return{Process} ...",
				-relief	=> 'sunken');
		}
	} else {
		$status_bar->show("$entered looks like the name of something ...",
				-relief	=> 'sunken');
		# check to see if it's a mouse name:
		if ($entered =~ m/[a-z]$/) {
			print "Hello - $entered looks like a mouse name ...\n";
			my $old_mouse_id = $mouse_id;
			$mouse_id = get_id_from_name($entered);
			if (!defined $mouse_id) {
				no_data_found($entered, 'mouse');
				$mouse_id = $old_mouse_id;
			} 
			else {
				# delete the existing pages:
				$nb->delete("page1");
				$nb->delete("proc_page");
				$nb->delete("comments_page");
				$nb->delete("history_page");
				# check for report page:
				if ($nb->pagecget($report_card_name, -state) eq 'normal') {
					$nb->delete($report_card_name);
				}

				$mouse = $entered;
				# now earlier, so results available elsewhere:
				%results = ();
				$results_ref = single_mouse_details($mouse_id); # in anitrack_data_access
				%results = %$results_ref;

				setup();
				displayOverview();
				loadProcedures();
				showComments();
				showHistory();
				push @shown_items, $entered;
				$nb->raise("page1");
			}
		}
		else {
			push @shown_items, $entered;
			&check_card($entered, 'new');
		}
	}
}

sub go_result {
	$status_bar->show("Result handling to follow",
				-relief	=> 'sunken');
}

# sub go_xml {
	# $status_bar->show("Pretending to report ...",
				# -relief	=> 'sunken');
	# # but let's have a progress bar anyway ...
	# my $carryon = 1;
	# my $prog_f = $p1->Frame(Name	=> 'progress',
				# -border	=> 2,
				# -relief	=> 'groove')
				# ->form(	-bottom	=> '%90', # bad hardcoding!
					# -left	=> '%0',
					# -right	=> '%100');
	# my $progbar = $prog_f->ProgressBar( 	-length		=> 192,
						# -width		=> 24,
						# -borderwidth	=> 2,
						# -colors		=> [0, 'green'],
						# -blocks		=> 100,
						# -gap		=> 0)
						# ->pack( -side	=> 'top' );
	# 
	# my $cancel_b = $prog_f->Button( -text		=> 'Cancel',
					# -font		=> BUTTON_FONT,
					# -command	=> sub { $carryon = !&confirm( 'Cancel' ) } )
					# ->pack( -side => 'bottom');
					# 
	# for my $i ( 0 .. 1000 ) {
		# unless( $carryon) {
			# $status_bar->show("Cancelling report ...");
			# $progbar->destroy;
			# $cancel_b->destroy;
			# $prog_f->destroy;
			# $status_bar->show("Report cancelled.");
			# last;
		# }
		# $progbar->value( $i/10 );
		# $progbar->update();
	# }
	# if ($carryon) {
		# $status_bar->show("Report 'printed'.");
		# $progbar->destroy;
		# $cancel_b->destroy;
		# $prog_f->destroy;		
	# }
			# 
	# 
# } 


# sub old_new_card {
	# # card options hardcoded for now - could get from GTx
	# my @card_options = ('Mating Card', 'Weaning Card') ;
	# my @button_list = @card_options;
	# push @card_options, 'Cancel';
	# my $choice = $mw->Dialog(	-title 		=> "Select card type",
					# -text 		=> 'Please choose a card type',
					# -default_button => 'Cancel',
					# -buttons	=> \@card_options,
					# -bitmap		=> 'question')->Show();
	# if ($choice ne 'Cancel') {
		# $status_bar->show("About to create new $choice ...");
		# # off to the business rules:
		# &create_card($choice);
	# } 
	# 
# }

sub new_card {
	my $cardname;
	my $db = $mw->DialogBox(	-title	 	=> 'Enter name of a card to show:',
					-buttons 	=> [ 'OK', 'Cancel' ],
					-default_button	=> 'OK');
	my $ce = $db->add('LabEntry', 	-textvariable	=> \$cardname, 
					-width		=> 20,
					-label		=> 'Card name: ',
					-labelPack	=> [ -side	=> 'left'])->pack;
	$ce->focus;
	$ce->icursor(1);		
	my $choice = $db->Show();
	if ($choice ne 'Cancel') {
		$status_bar->show("About to show card $cardname ...");
		# is card already displayed?
		&check_card($cardname, 'new');
	} 
}

sub new_show_card {
	# created 28/07/05 to handle real data
	# can have 3 or 4 params
	my ($card_name, $card_type, $results_ref, $mouse_refs_ref);
	$card_name = $_[0];
	$card_type = $_[1];
	$results_ref = $_[2];
	if (defined $_[3]) {
		$mouse_refs_ref = $_[3];
	}
	#print "In new show card\n";
	
	# 15/11/05:
	my @moved_mices = ();
	
	# load the data that we've been passed into variables we can use as Tk -textvariables
	my %results;
	# will not have any data if new card:
	my $new_card = 0;
	if (defined $results_ref) {
		print "\nIn new show card,have results_ref\n";
		%results = %$results_ref;
		foreach my $i (sort keys %results) {
			print "Results $i: $results{$i}\n";
		}
	} else {
		print "IN new_show_card, have no results_ref\n";
		$new_card = 1;
	}
	my @mouse_refs;
	my (%mouse_details, %mice_details);
	my ($i, $j);
		
	if (defined $mouse_refs_ref) {
		# load all individual mouse details into one hash for later lookups:
		@mouse_refs = @$mouse_refs_ref;
		for $i (0 .. $#mouse_refs) {
			%mouse_details = %{$mouse_refs[$i]};
			foreach $j (keys %mouse_details) {
				$mice_details{$j} = $mouse_details{$j};
			}
		}
		# check it:
#		foreach $i (keys %mice_details) {
# 			print "testing: $i, $mice_details{$i}\n";
# 		}
	}
	
	# get the litter details, store in a grid:
	# note that at present these may not be in litter order,
	# but it may be better to move this processing to the business rules ... to do
	# also, this only needs to be done for mating cards: to do
	my @litters = ();
	foreach $i (sort keys %results) { # need to get litters in name order - to do
		if ($i =~ /Litter (\d+) _Date/) {
			$litters[$1][1] = $results{$i};
		}
		if ($i =~ /Litter (\d+) mouse \d+ name /) {
			if (defined $litters[$1][2]) {
				$litters[$1][2]++;
			} else {
				$litters[$1][2] = 1;
			}
			$litters[$1][0] = $results{$i};
			$litters[$1][0] =~ s/[a-z]+$//;
		}
	} 
	
	
	@litters = sort { $a->[0] cmp $b->[0] } @litters;
	
	
	# penned mice can have non-consecutive ids:
	my @penned_mice_details = ();	
	my %penned_mice = ();
	my @mouse_details;
	my $key;
	my $micecount = 0;
	my $moved_mice = ' ';
	
	if ($card_type eq 'Weaning Card') {
		foreach $i (sort keys %results) {
			# sanity check:
			# print "Results: $i: $results{$i}\n";
			if ($i =~ m/Penned mouse (\d+) id/) {
				$key = $1 . '_id';
				$penned_mice{$key} = $results{$i};
			}
			if ($i =~ m/Penned mouse (\d+) name/) {
				$key = $1 . '_Name';
				$penned_mice{$key} = $results{$i};
			}
			if ($i =~ m/Penned mouse (\d+) penned from/) {
				$key = $1 . '_from';
				$penned_mice{$key} = $results{$i};
			}
			if ($i =~ m/Penned mouse (\d+) penned to/) {
				$key = $1 . '_to';
				$penned_mice{$key} = $results{$i};
				$moved_mice .= "$1 ";
			}
			if ($i =~ m/Penned mouse (\d+) penned since/) {
				$key = $1 . '_since';
				$penned_mice{$key} = $results{$i};
			}
		}
		
		foreach $i (sort keys %penned_mice) {
			# sanity check:
			print "Penned mice: $i: $penned_mice{$i}\n";
			if ($i =~ /(\d+)_id/) {
				my $id = $1;
				# need to check whether mice have been removed or are dead
				# this almost certainly needs to go in the business rules ...
				if ($moved_mice =~ / $1 /) {
					print "Mouse $i has been moved out ...\n";
					# 15/11/05, show the mice anyway, grey them out if needed later
					# next;
					$moved_mices[$id] = 1;
				}
				else {
					$moved_mices[$id] = 0;
				}
				$micecount++;
				@mouse_details = ();
				# get details from %mice_details
				# load the hash elements in to the display array:
				$key = $id . '_Name';
				$mouse_details[0] = $penned_mice{$key};
				print "Name is $mouse_details[0]\n";
				#print "About to look for details for mouse id $penned_mice{$i} ...\n";
				$key = $1 . '_Sex';
				$penned_mice{$key} = $mice_details{"Mouse $penned_mice{$i} attribute _SEX"};
				$mouse_details[1] = $mice_details{"Mouse $penned_mice{$i} attribute _SEX"};
				#print "Sex is $penned_mice{$key}\n";
				$key = $1 . '_[SV]';
				$penned_mice{$key} = $mice_details{"Mouse $penned_mice{$i} genotype"};
				$mouse_details[3] = $mice_details{"Mouse $penned_mice{$i} genotype"};
				#print "Genotype is $penned_mice{$key}\n";
				$key = $1 . '_DOB';
				$penned_mice{$key} = $mice_details{"Mouse $penned_mice{$i} date of birth"};
				$mouse_details[2] = $mice_details{"Mouse $penned_mice{$i} date of birth"};
				#print "Date of birth is $penned_mice{$key}\n";
				# load this row into the grid:
				@{$penned_mice_details[$micecount]} = @mouse_details;
				
			}
			
		}
		print "$penned_mice_details[0][0]\n";
		# woo, scary: this barfs unless you print the above:	
		@penned_mice_details = sort { $a->[0] cmp $b->[0] } @penned_mice_details;
	}
					
					
		
		
		
	
	$status_bar->show("About to create card $card_name ...");
	my $status_message = "Please complete details on this $card_type";
	# get colony from card_name? Later ...
	my $colony = 'SV';
	
	# no data has yet been changed on this card
	# (note: check this when new cards created?)
	$changed_data{$card_name} = 0;
	my $changed_data = 0;
		
	my $new_card = $nb->add("$card_name",	-label		=> "$card_name",
				-raisecmd	=> sub{ $status_bar->show() });
	# make the contents of the card here:
	# edited from AtrCard:
	
	# make the card frame in its own pane:			
	my $pane = $new_card->Frame->pack(	-side	=> 'top',
						-fill	=> 'both',
						-expand	=> 1);
	my $card_f = $pane->Frame(	Name		=> 'card_f',
					-borderwidth 	=> 3,
					# -background => 'light blue',
					-relief		=> 'solid')
					->pack(	-anchor	=> 'center');
	
	# Then make a header frame:
	my $head_f = $card_f->Frame( 	Name 		=> 'head_f',
					-borderwidth 	=> 2,
					# -background => 'purple',
					-relief		=> 'groove')
					->pack(	-side	=> 'top',
						-fill	=> 'x');
	# add in the card title:
	my $card_label = $card_type eq 'Mating Card' ? 'Mating card' : 'Weaning card';
	
	my $card_title = $head_f->LabEntry(	-label	=> "$card_label: ",
						-textvariable	=> \$card_name,
						-labelFont	=> LABEL_FONT,
						-font		=> LABEL_FONT,
						-width		=> 7,
						-labelPack	=> [ -side	=> 'left'])
						->pack( -side	=> 'left',
							-fill 	=> 'y');
	
	# Then make the button frame:
	my $buttons_f = $new_card->Frame(	Name		=> 'buttons_f',
						-borderwidth 	=> 2,
						-relief		=> 'sunken')
						->pack(	-side	=> 'bottom',
							-fill	=> 'x');
	
	# update button needs to go through business rules to broker
	$buttons_f->Button(	-text	=> 'Update',
				-font	=> BUTTON_FONT,
				-command=> sub { if ( &update($card_type, $card_name) ) { $changed_data = 0; } } )
				->pack(-side	=> 'right');
	$buttons_f->Button(	-text	=> 'Close /discard',
				-font	=> BUTTON_FONT,
				-command=> sub { if ( &confirm("Confirm Close/Discard")) { $nb->delete("$card_name"); }} )
				->pack(-side	=> 'right');
	# print needs to go through business rules in order to eg check for 
	# unsaved data to ensure match between stored and displayed information,
	# then needs to be passed to print engine
	$buttons_f->Button(	-text	=> 'Print',
				-font	=> BUTTON_FONT,
				-command=> sub { if ($changed_data) { &warn_save } else { &print_card( $card_type, $card_name, $changed_data )}} )
				->pack(-side	=> 'right');
	
	# create card_type-dependent buttons:
	SWITCH: {
		if ($card_type eq 'Mating Card') {
			$buttons_f->Button(	-text		=> 'Add litter',
						-font		=> BUTTON_FONT,
						-command	=> \&add_litter)
						->pack(	-side	=> 'left');
						# 02/08/05, use the litter buttons to wean:
# 			$buttons_f->Button(	-text		=> 'Transfer',
# 						-font		=> BUTTON_FONT,
# 						-command	=> \&transfer)
# 						->pack(	-side	=> 'left');
			last SWITCH;
		}
		if ($card_type eq 'Weaning Card') {
			$buttons_f->Button(	-text		=> 'Transfer',
						-font		=> BUTTON_FONT,
						-command	=> \&transfer)
						->pack(	-side	=> 'left');
			$buttons_f->Button(	-text		=> 'Split by sex',
						-font		=> BUTTON_FONT,
						-command	=> [ \&transfer, 'by_sex'])
						->pack(	-side	=> 'left');
			$buttons_f->Button(	-text		=> 'Jump to mating',
						-font		=> BUTTON_FONT,
						-command	=> sub { if ($changed_data) { &warn_save } else { &jump_mating( $card_name ) } })
						->pack(	-side	=> 'left');
			
			last SWITCH;
		}
		# default:
		die "Unexpected card type $card_type when creating card-specific bottom buttons!\n";
	}
	
				
	
	# put the licence area and progenitors in a subframe of the card frame:
	my $top_f = $card_f->Frame(	Name	=> 'top_f')
					->pack(	-side	=> 'top',
						-fill	=> 'none'); 
					
 	my $lf;
	SWITCH: {
		if ($card_type eq 'Mating Card') {
			$lf = $top_f->Frame(	Name		=> 'lic_f',
						-borderwidth	=> 0)
						->pack(	-side	=> 'right',
							-anchor	=> 'ne');
			last SWITCH;
		}
		if ($card_type eq 'Weaning Card') {
			$lf = $top_f->Frame(	Name		=> 'lic_f',
						-borderwidth	=> 1,
						-relief		=> 'groove')
						->pack(	-side	=> 'right',
							-fill	=> 'none',
							-anchor	=> 'se');
			last SWITCH;	
		}
		# default:
		die "Unexpected card type $card_type when creating licence frame!\n";
	}
				
 	# put the barcode in the card frame:
	my $barcode;
	my $height = 368;
#	my $height = 168;
	my $width = 56;
	my $borderwidth = 8;
	my $entrywidth = 6;
	SWITCH: {
		if ($card_type eq 'Mating Card') {			
			$lf->LabEntry(	Name	=> 'PPL',
					-textvariable	=> \$results{'_LicPPL'},
					-label		=> 'PPL: ',
					-labelFont	=> LABEL_FONT,
					-font		=> LABEL_FONT,
					-background	=> ENTRY_BG,
					-width 		=> $entrywidth,
					-validate	=> 'key',
					-validatecommand	=> sub { $changed_data = 1; },
					-labelPack	=> [ -side	=> 'left'])
					->pack(	-side	=> 'top',
						-fill	=> 'x', 
						-expand	=> 0);
			$lf->LabEntry(	Name	=> 'PIL',
					-textvariable	=> \$results{'_LicPIL'},
					-label		=> 'PIL: ',
					-labelFont	=> LABEL_FONT,
					-font		=> LABEL_FONT,
					-background	=> ENTRY_BG,
					-width 		=> $entrywidth,
					-validate	=> 'key',
					-validatecommand	=> sub { $changed_data = 1; },
					-labelPack	=> [ -side	=> 'left'])
					->pack(	-side	=> 'top',
						-fill	=> 'both', 
						-expand	=> 0);
			$lf->LabEntry(	Name	=> 'User',
					-textvariable	=> \$results{'_LicUser'},
					-label		=> 'User: ',
					-labelFont	=> LABEL_FONT,
					-font		=> LABEL_FONT,
					-background	=> ENTRY_BG,
					-width 		=> $entrywidth,
					-validate	=> 'key',
					-validatecommand	=> sub { $changed_data = 1; },
					-labelPack	=> [ -side	=> 'left'])
					->pack(	-side	=> 'top',
						-fill	=> 'both', 
						-expand	=> 0);
			$lf->LabEntry(	Name	=> '19b',
					-textvariable	=> \$results{'_Lic19b'},
					-label		=> '19b: ',
					-labelFont	=> LABEL_FONT,
					-font		=> LABEL_FONT,
					-background	=> ENTRY_BG,
					-width 		=> $entrywidth,
					-validate	=> 'key',
					-validatecommand	=> sub { $changed_data = 1; },
					-labelPack	=> [ -side	=> 'left'])
					->pack(	-side	=> 'top',
						-fill	=> 'both', 
						-expand	=> 0);
			$barcode = $card_f->Canvas(	-height		=> $height,
							-width		=> $width,
							-borderwidth	=> $borderwidth)
							->pack(	-side	=> 'right',
								-anchor	=> 'ne',
								-fill	=> 'none');
			last SWITCH;
		}
		if ($card_type eq 'Weaning Card') {
			$barcode = $lf->Canvas(	-height		=> $height,
						-width		=> $width,
						-borderwidth	=> $borderwidth)
						->pack(	-side	=> 'top',
							-anchor	=> 'ne',
							-fill	=> 'none');
			$lf->LabEntry(	Name	=> 'PPL',
					-textvariable	=> \$results{'_LicPPL'},
					-label		=> 'PPL: ',
					-labelFont	=> LABEL_FONT,
					-font		=> LABEL_FONT,
					-background	=> ENTRY_BG,
					-width 		=> $entrywidth,
					-validate	=> 'key',
					-validatecommand	=> sub { $changed_data = 1; },
					-labelPack	=> [ -side	=> 'left'])
					->pack(	-side	=> 'top',
						-fill	=> 'x', 
						-expand	=> 0);
			$lf->LabEntry(	Name	=> 'PIL',
					-textvariable	=> \$results{'_LicPIL'},
					-label		=> 'PIL: ',
					-labelFont	=> LABEL_FONT,
					-font		=> LABEL_FONT,
					-background	=> ENTRY_BG,
					-width 		=> $entrywidth,
					-labelPack	=> [ -side	=> 'left'])
					->pack(	-side	=> 'top',
						-fill	=> 'both', 
						-expand	=> 0);
			$lf->LabEntry(	Name	=> 'User',
					-textvariable	=> \$results{'_LicUser'},
					-label		=> 'User: ',
					-labelFont	=> LABEL_FONT,
					-font		=> LABEL_FONT,
					-background	=> ENTRY_BG,
					-width 		=> $entrywidth,
					-validate	=> 'key',
					-validatecommand	=> sub { $changed_data = 1; },
					-labelPack	=> [ -side	=> 'left'])
					->pack(	-side	=> 'top',
						-fill	=> 'both', 
						-expand	=> 0);
			$lf->LabEntry(	Name	=> '19b',
					-textvariable	=> \$results{'_Lic19b'},
					-label		=> '19b: ',
					-labelFont	=> LABEL_FONT,
					-font		=> LABEL_FONT,
					-background	=> ENTRY_BG,
					-width 		=> $entrywidth,
					-validate	=> 'key',
					-validatecommand	=> sub { $changed_data = 1; },
					-labelPack	=> [ -side	=> 'left'])
					->pack(	-side	=> 'top',
						-fill	=> 'both', 
						-expand	=> 0);
			last SWITCH;
		}
		# default:
		die "Unexpected card type $card_type when creating barcode canvas!\n";
	}	
	$barcode->createRectangle( 0, 0, $width, $height,
					-fill 	=> 'black');
	# had to double borderwidth to get correct layout ...
	$barcode->createRectangle( 	$borderwidth*2, $borderwidth*2, 
					$width-$borderwidth, 
					$height-$borderwidth,
					-fill 	=> 'white');
	
	# will need to get data in and render barcode (see BarcodeImage)
	# but need to get rest of GUI finished first ...
	
	# add the progenitors frame and litters frame for mating, litter mice
	# frame for weaning:
	my ( $mice_f, $progs_f, $lit_f);
	my @LITS_HEAD = ('#', 'DOB', 'Pups', 'Weaned', 'Comments');
	SWITCH: {
		if ($card_type eq 'Mating Card') {
			# make the parent's details frame:
			 $progs_f = $top_f->Frame(	Name		=> 'progs_f',
							-borderwidth	=> 1,
							# -background => 'blue',
							-relief		=> 'sunken')
							->pack(	-side	=> 'left',
								-anchor	=> 'nw');
			# display the parent's details:
			# first get relevant genotype column names (hardcoded for now):
			my $col = 'SV';
			my @col_headers = &get_col_headers( $col, $card_type ); # off to business rules
			
			my $parent1 = $results{'Parent mouse 0 name'};
			my $parent2 = $results{'Parent mouse 1 name'};
			my (%p1, %p2);
			my $parent1_id = $results{'Parent mouse 0 id'};
			my $parent2_id = $results{'Parent mouse 1 id'};
			$p1{'Sex'} = $mice_details{"Mouse $parent1_id attribute _SEX"};
			$p2{'Sex'} = $mice_details{"Mouse $parent2_id attribute _SEX"};
			$p1{'DOB'} = $mice_details{"Mouse $parent1_id date of birth"};
			$p2{'DOB'} = $mice_details{"Mouse $parent2_id date of birth"};
			$p1{'[SV]'} = $mice_details{"Mouse $parent1_id genotype"};
			$p2{'[SV]'} = $mice_details{"Mouse $parent2_id genotype"};
			
			# NOTE: now have buttons, but can't associate label with button, 
			# so need to generate a separate line of labels on grid
			
			for (my $i = 0; $i < @col_headers; $i++) {
				if ($col_headers[$i] eq "Name") {
					# make button:
					$progs_f->Button( 	Name	=> "$col_headers[$i]_m",
								-text 	=> "$parent1",
								-font	=> BUTTON_FONT,
								# -command=> \&not_yet)
								-command=> [ \&barcode, $parent1 ])
								->grid( -row	=> 0,
									-column => $i,
									-sticky	=> 'nsew');
					$progs_f->Label( 	-text	=> $col_headers[$i],
								-font	=> LABEL_FONT)
								->grid( -row	=> 1,
									-column => $i,
									-sticky	=> 'nsew');
 					$progs_f->Button( 	Name	=> "$col_headers[$i]_f",
								-text 	=> "$parent2",
								-font	=> BUTTON_FONT,
								# -command=> \&not_yet)
								-command=> [ \&barcode, $parent2 ])
								->grid( -row	=> 2,
									-column => $i,
									-sticky	=> 'sew');
				} else {
					$progs_f->Entry( 	Name		=> "$col_headers[$i]_m",
								-textvariable	=> \$p1{$col_headers[$i]},
								-width 	=> length( "$col_headers[$i]"),
								-font	=> LABEL_FONT,
								-background	=> ENTRY_BG)
								->grid( -row	=> 0,
									-column => $i,
									-sticky	=> 'nsew');
 					$progs_f->Label( 	-text	=> $col_headers[$i],
								-font	=> LABEL_FONT)
								->grid( -row	=> 1,
									-column => $i,
									-sticky	=> 'nsew');
					$progs_f->Entry( 	Name		=> "$col_headers[$i]_f",
								-textvariable	=> \$p2{$col_headers[$i]},
								-width 	=> length( "$col_headers[$i]"),
								-font	=> LABEL_FONT,
								-background	=> ENTRY_BG)
								->grid( -row	=> 2,
									-column => $i,
									-sticky	=> 'nsew');
				}
			}
							
			
			# Note: should check here for any existing litters: needs to go 
			# off to business rules, or maybe direct to broker ...
			
			if ( $#litters == -1 ) {
				print "No litters\n";
			} else {
			
				# make the litter frame:
				$lit_f = $card_f->Frame(Name		=> 'lit_f')
								->pack(	-side	=> 'top',
									-anchor	=> 'nw');
				# make the headers:
				for (my $i = 0 ; $i < @LITS_HEAD; $i++) {
					my $hdr = $lit_f->Label(	Name	=> "col$i",
									-text	=> $LITS_HEAD[$i],
									-font	=> LABEL_FONT);
					$hdr->grid(	-row	=> 0,
							-column	=> $i,
							-sticky	=>'nsew');
				}
				# make the litter details:
				my $rowcount;
				my ($entry, $entryname);
				my @widths = ('1', '8', '2', '12', '20');
				 for (my $i = 0; $i <= $#litters; $i++) {
					$rowcount = $i + 1;
					# make first item a button:
 					$lit_f->Button(	-text	=> "$litters[$i][0]",
							-font	=> BUTTON_FONT,
							# -command=> \&not_yet)
							-command=> [ \&barcode, $litters[$i][0] ])
							->grid(	-row	=> $rowcount,
								-column	=> 0,
								-sticky	=>'nsew');
					for (my $j = 1; $j <= $#LITS_HEAD; $j++) {
						#$entryname = $LITS_HEAD[$j] . $i . '_' . $j;
						$entry = $lit_f->Entry(	-width 		=> $widths[$j],
									-font		=> LABEL_FONT,
									-background	=> ENTRY_BG,
									#-textvariable 	=> $entryname)
									-textvariable 	=> \$litters[$i][$j])
									->grid(	-row	=> $rowcount,
										-column	=> $j,
										-sticky	=>'nsew');
						#$entry->insert('end', "$litters[$i][$j]");
					}
				}	
				
			}
			
			last SWITCH;
		}
		if ($card_type eq 'Weaning Card') {
			# make the mouse frame;
			$mice_f = $top_f->Frame(	Name		=> 'mice_f',
							-borderwidth	=> 1)
							->pack( -side	=> 'left',
								-fill	=> 'none',
								-anchor	=> 'nw');
			# display the pup's details:
			# first get relevant genotype column names (hardcoded for now):
			my $col = 'SV';
			my @col_headers = &get_col_headers( $col, $card_type ); # off to business rules
			# show the headers:
			for (my $i = 0 ; $i < @col_headers; $i++) {
				my $hdr = $mice_f->Label(	Name	=> "col$i",
								-text	=> $col_headers[$i],
								-font	=> LABEL_FONT);
				$hdr->grid(	-row	=> 0,
						-column	=> $i,
						-sticky	=>'nsew');
			}
			# then display weaning details.  First get the details:
			
			
			
			
			
			# then create and populate the slots:
			my ($entry, $entryname);
			my $rowcount;
			# NOTE: should really generate this on the fly from header item lengths
			
				
			print "Length moved_mice ($moved_mice) is ", length($moved_mice), "\n";
			if (length($moved_mice) > 1) {
				# print "Why isn't the status bar changing?\n";
				$status_message = "Some mice have been removed from this weaning pen.";
			}
			print "Micecount is $micecount\n";
			unless ($micecount) {
				$status_message = "All mice have been removed from this weaning pen.";
			}
			my @widths = ('7', '2', '8', '4', '5', '3','4','4','5');
			for (my $i = 1 ; $i <= $micecount ; $i++) {
				$rowcount = $i + 1;
				for (my $j = 0; $j <= $#col_headers; $j++ ) {
					#$entryname = $i . '_' . $col_headers[$j];
				#	print "$i $j: Entryname is $entryname\n";
					$key = ($i - 1) . '_' . $col_headers[$j];
					# print "Key is $key\n";
					# 15/11/05, check for moved mice:
					my $display_font;
					if ($moved_mices[$i]) {
						$display_font = "helvetica 18 overstrike";
					}
					else {
						$display_font = "LABEL_FONT";
					}
					$entry = $mice_f->Entry(-width 	=> $widths[$j],
								#-font	=> LABEL_FONT,
								-font	=> $display_font,
								-background	=> ENTRY_BG,
								# -textvariable => \$penned_mice{$key})
								-textvariable => \$penned_mice_details[$i][$j])
								->grid(	-row	=> $rowcount,
									-column	=> $j,
									-sticky	=>'nsew');
					# TO DO: need to replace this with penned_mice:
				#	$entry->insert('end', "$litters[$i][$j]");
# 					if (defined $penned_mice{$entryname}) {
# 						$entryname = $penned_mice{$entryname};
# 					}		
				}
				
				
			}
					
			
								
			last SWITCH;
			
		}
		# default:
		die "Unexpected card type $card_type when creating prog/lit/mice frames!\n";
	}	
	
	
	
	# more card-specific options:
	SWITCH: {
		if ($card_type eq 'Mating Card') {
			# will need to get this from database later ...
			my $mating_setup_date = '01/03/05';
			$head_f->LabEntry(	-label	=> 'Date mating setup:',
						-labelFont	=> LABEL_FONT,
						-font		=> LABEL_FONT,
						-width		=> 8,
						-textvariable 	=> \$mating_setup_date,
						-labelPack	=> [ -side	=> 'left'])
						->pack(	-side	=> 'right',
							-fill	=>'y');
			last SWITCH;
		}
		if ($card_type eq 'Weaning Card') {
			my $sex = $results{'_SEX_intended'};
			$head_f->LabEntry(	-label	=> 'Sex:',
						-labelFont	=> LABEL_FONT,
						-font		=> LABEL_FONT,
						-width		=> 6,
						-textvariable 	=> \$sex,
						-background 	=> ENTRY_BG,
						-labelPack	=> [ -side	=> 'left'])
						->pack(	-side	=> 'left',
							-fill	=>'y');
			last SWITCH;
		}
		# default:
		die "Unexpected card type $card_type when creating card-specific top buttons!\n";
	}		
	
	
	# then move this card to the front:
	$nb->raise("$card_name");
	$status_bar->show($status_message);
	
}
	
	


sub select_card {
	my $cardname;
	my $db = $mw->DialogBox(	-title	 	=> 'Choose a card to show:',
					-buttons 	=> [ 'OK', 'Cancel' ],
					-default_button	=> 'OK');
	my $ce = $db->add('LabEntry', 	-textvariable	=> \$cardname, 
					-width		=> 20,
					-label		=> 'Card name: ',
					-labelPack	=> [ -side	=> 'left'])->pack;
	$ce->focus;
	$ce->icursor(1);		
	my $choice = $db->Show();
	if ($choice ne 'Cancel') {
		$status_bar->show("About to show card $cardname ...");
		# is card already displayed?
		&check_card($cardname, 'old');
	} 
}

sub check_card {
	my ($card_name, $type) = @_;
	my $state = $nb->pagecget("$card_name", -state);
	my $front_page;
	my $card_type;
	print "State of card $card_name is $state\n";
 	if ( $state eq "normal" ) {
 		print "Card $card_name exists ...\n";
		# is it front card?
		$front_page = $nb->raised();
		if ( $front_page ne $card_name ) {
			# need to raise it:
			$nb->raise( $card_name );
		}
		
 	} else {
 		print "Card $card_name doesn't exist ...\n";
		unless ($card_name =~ m/\.\d+$/) {
			$card_type = "Mating Card";
			# off to the controller:
			# &new_create_card($card_name, $card_type);
		} else { 
# 			$status_bar->show("Can't create anything but mating cards this way at present - sorry");
			$card_type = "Weaning Card";
		}
		# off to the controller:
		print "Type is $type ..\n";
		if ($type = 'old') {
			&new_create_card($card_name, $card_type);
		} else {
			&new_show_card($card_name, $card_type, undef);
		}
 	}	
} 


sub add_litter {
	# add this when basic card gui implemented
	print "Pretending to add a litter to a card ...\n";
}

sub transfer {
	# add this when basic card gui implemented
	# see AtrCard for details
	my $param = shift;
	print "Pretending to transfer ";
	if ($param) {
		print "by sex";
	}		
	print "...\n";
	
	# 11/08/05, let's make a dialog box:
	my $db = $mw->DialogBox(	-title	 	=> 'Transfer mice:',
					-buttons 	=> [ 'Transfer', 'Cancel' ],
					-default_button	=> 'Transfer');
	my $grid_f = $db->Frame(Name		=> 'grid_f',
				-background	=> 'white')
				->pack(	-side	=> 'top',
					-fill	=> 'both',
					-expand	=> 1,
					-anchor	=> 'nw');
	# set date of transferring to today initially:
	my $transfer_date = $date_today;
	my $hist_date = $db->LabEntry(	-label	 	=> 'Transfer date: ',
					-textvariable	=> \$transfer_date)
					->pack(-side	=> 'right');				
	my $choice = $db->Show();
	if ($choice ne 'Cancel') {
		$status_bar->show("About to transfer mice ...");
	} 
}

# don't think this is used any more:
sub jump_mating {
	# confess "jump_mating called - what from?";
	# print "Pretending to jump to mating ...\n";
	my $card_name = shift;
	# need to check whether anything should be saved on the page first:
	my $mating;
	# WARNING: HARDCODED NAME FORMAT!!!!
	$card_name =~ m/([A-Z]{2}\d+)/;
	$mating = $1;
	print "Looking for mating $mating\n";
	# check if card is on another tab or needs to be created:
	&check_card($mating, 'old');
	
}

sub logon {
	# ask user for username and password, pass to business rules
	my ($uname, $pw, $ue);
	my $db = $mw->DialogBox(	-title	 	=> 'Please login:',
					-buttons 	=> [ 'OK', 'Cancel' ],
					-default_button	=> 'OK');
	$ue = $db->add('LabEntry', 	-textvariable	=> \$uname, 
					-width		=> 20,
					-label		=> 'Username: ',
					-labelPack	=> [ -side	=> 'left'])->pack;
	$db->add('LabEntry', 	-textvariable	=> \$pw, 
				-width		=> 20,
				-label		=> 'Password: ',
				-show		=> '*',
				-labelPack	=> [ -side	=> 'left'])->pack;
	$ue->focus;
	$ue->icursor(1);		
	my $answer = $db->Show();
	
	if ($answer eq 'OK') {
		return( &authenticate( $uname, $pw ) );
	} else {
		if ( &confirm( 'Quit' )) { 
			$mw->destroy();
		}
	}

}	

sub not_yet {
	# generic work-in-progress warning:
	my $mb = $mw->messageBox(	-title	=> "Sorry",
					-message=> "This functionality is not yet implemented - sorry.",
					-type	=> 'OK');
}


sub warn_save {
	my $mb = $mw->messageBox(	-title	=> "Unsaved data",
					-message=> "You need to save your data first!",
					-type	=> 'OK');
}

sub no_data_found {
	my ($card_name, $card_type) = @_;
	my $mb = $mw->messageBox(	-title	=> "No data found",
					-message=> "No data was found for $card_type $card_name.",
					-type	=> 'OK');
}

# 15/11/05, user request to go to *actual cards*:
sub jump {
	my @pup_cards = ();
	# find what mating it came from:
	$mouse =~ m/(\w+\d+)\.\d+/;
	my $born_in = $1;
	# find the weaning card from the name:
	$mouse =~ m/(\w+\d+\.\d+)/;
	my $weaned_in = $1;
	my $mating_names_ref = get_mating_names($mouse_id);
	my @mating_names = @$mating_names_ref;
	print "This mouse $mouse was born in cage $born_in and weaned in cage $weaned_in.\n";
	for my $i (0 .. $#mating_names) {
		print "It was on mating $mating_names[$i]\n";
	}
	my $db = $mw->DialogBox(	-title	 	=> 'Jump to:',
					-buttons 	=> [ 'Cancel', 'Jump' ],
					-default_button	=> 'Jump');
	my $grid_f = $db->Frame(Name		=> 'grid_f',
				-background	=> 'white')
				->pack(	-side	=> 'top',
					-fill	=> 'both',
					-expand	=> 1,
					-anchor	=> 'nw');
	# from the emu book, modified:
	my @options = ();
	push @options, "Littermates ($weaned_in)";
	push @options, "Parents ($born_in)";
	for my $i (0 .. $#mating_names) {
			push @options, "Offspring ($mating_names[$i])";
		}
	
	my $what_to_find = $options[0]; # make the first the default
#	foreach (qw/Littermates Parents Offspring/) {
	for my $i (0 .. $#options) {
		$grid_f->Radiobutton(	-text 		=> $options[$i],
					-variable 	=> \$what_to_find,
					-value 		=> $options[$i],
					-justify	=> 'left',
					-anchor		=> 'w')
					->pack(	-side	=> 'top',
						-fill	=> 'both',
						-expand	=> 'y');
					
		
	}
	my $choice = $db->Show();
	if ($choice ne 'Cancel') {
		$status_bar->show("About to jump to $what_to_find for $mouse ...");
		if ($what_to_find =~ m/Parents/) {
			push @shown_items, $born_in;
			check_card($born_in, 'new');
		}
		if ($what_to_find =~ m/Littermates/) {
			push @shown_items, $weaned_in;
			check_card($weaned_in, 'new');
		}
		if ($what_to_find =~ m/Offspring \((\w+\d+)\)/) {
			push @shown_items, $1;
			check_card($1, 'new');
		}
	} 
}


sub find {
	# not_yet();
	my @parent_names = ();
	my @litter_mates = ();	
	my @offspring = ();
	my @output_lines = ();
	my $results_count = 0;
	my $db = $mw->DialogBox(	-title	 	=> 'Find mice:',
					-buttons 	=> [ 'Cancel', 'Find' ],
					-default_button	=> 'Find');
	my $grid_f = $db->Frame(Name		=> 'grid_f',
				-background	=> 'white')
				->pack(	-side	=> 'top',
					-fill	=> 'both',
					-expand	=> 1,
					-anchor	=> 'nw');
	# from the emu book:
	my $what_to_find = 'Littermates'; # make the first the default
	foreach (qw/Littermates Parents Offspring/) {
		$grid_f->Radiobutton(	-text 		=> $_,
					-variable 	=> \$what_to_find,
					-value 		=> $_,
					-justify	=> 'left',
					-anchor		=> 'w')
					->pack(	-side	=> 'top',
						-fill	=> 'both',
						-expand	=> 'y');
					
		
	}
	my $choice = $db->Show();
	if ($choice ne 'Cancel') {
		$status_bar->show("About to find $what_to_find for $mouse ...");
	#} 
		push @output_lines, "Report on $what_to_find for mouse $mouse, id $mouse_id\n\n";
		SWITCH: {
			if ($what_to_find eq 'Parents') {
				my $parent_names_ref = get_parent_names( $mouse_id );
				@parent_names = @$parent_names_ref;
				for my $i (0 .. $#parent_names) {
					print "Parent $i: $parent_names[ $i ]\n";
					push @output_lines, "Parent $i: $parent_names[$i]\n";
					$results_count++;
				}
				last SWITCH;
			}
			if ($what_to_find eq 'Littermates') {
				my $littermates_ref = get_littermates( $mouse_id, $mouse );
				@litter_mates = @$littermates_ref;
				for my $i (0 .. $#litter_mates) {
					print "Litter mate $i: $litter_mates[ $i ]\n";
					push @output_lines, "Litter mate $i, $litter_mates[$i]\n";
					$results_count++;
				}
				last SWITCH;
			}
			if ($what_to_find eq 'Offspring') {
				my $offspring_ref = get_offspring( $mouse_id );
				@offspring = @$offspring_ref;
				for my $i (0 .. $#offspring) {
					print "Offspring $i: $offspring[ $i ]\n";
					push @output_lines, "Offspring $i: $offspring[ $i ]\n";
					$results_count++;
				}
				last SWITCH;
			}
			# default:
			print "Unexpected 'thing to find' request: $what_to_find\n";
		} # end switch
		if ($results_count > 0) {
			print "Got $results_count results ...\n";
			# show the results:
			my $state = $nb->pagecget($report_card_name, -state);
			my $front_page;
			if ($state eq 'normal') {
				# reports card has been generated, is it front?
				$front_page = $nb->raised();
				if ($front_page ne $report_card_name) {
					$nb->raise($report_card_name);
				}
			}
			else {
				# need to create the reports card
				$report_page = $nb->add($report_card_name,	-label	=> $report_card_name);
				$report_field = $report_page->Scrolled("Text",
									-font => LABEL_FONT,
									-width 	=> 120,
									-scrollbars => 'e')->pack;
				$nb->raise($report_card_name);

				
			}
			# insert in the text we've just found:
			for my $i (0 .. $#output_lines) { 
				$report_field->insert('end', "$output_lines[$i]");
			}
			$report_field->insert('end', "\n\n");
		}
		else {
			$status_bar->show("Couldn't find any $what_to_find for $mouse!");
		}
		
	} # end if choice ne cancel		
}

sub transfer_mouse {
	# my $mouse_to_move = shift;
	my $mb = $mw->messageBox(	-title	=> "Transfer mouse",
					-message=> "About to transfer $mouse ...",
					-type	=> 'OK');
}

sub mate_mouse {
	# my $mouse_to_mate = shift;
	my $mb = $mw->messageBox(	-title	=> "Mate mouse",
					-message=> "About to mate $mouse ...",
					-type	=> 'OK');
}