← Back to branch summary

~ubuntu-branches/ubuntu/trusty/horae/trusty

« back to all changes in this revision

Viewing changes to athena_parts/file.pl

  • Committer: Bazaar Package Importer
  • Author(s): Carlo Segre
  • Date: 2008-02-23 23:13:02 UTC
  • mfrom: (2.1.2 hardy)
  • Revision ID: james.westby@ubuntu.com-20080223231302-mnyyxs3icvrus4ke
Tags: 066-3
Apply patch to athena_parts/misc.pl for compatibility with 
perl-tk 804.28.

Show diffs side-by-side

added added

removed removed

Lines of Context:
athena_parts/file.pl
18
18
  my @data;
19
19
  if ($read_arg) {
20
20
    push @data, $read_arg;
21
 
  } elsif ($get_many) {
 
21
  } elsif (($Tk::VERSION < 804) and ($get_many)) {
22
22
    @data = &get_file_list;
23
 
  } else {
 
23
  } elsif ($Tk::VERSION < 804) {
24
24
    $data[0] = &get_single_file;
 
25
  } else {
 
26
    @data = &get_single_file;
25
27
  };
26
28
  return unless ((@data) and ($data[0]) and ($data[0] !~ /^\s*$/));
27
29
  $top -> Busy(-recurse=>1,);
29
31
  #$prior_args = [];
30
32
  my ($first, $count) = ("", 1);
31
33
  my $errmsg;
32
 
 DATA: foreach (@data) {
33
 
    next unless (($_) and ($_ !~ /^\s*$/));
34
 
    unless (-r $_) {
35
 
      if (-e $_) {
36
 
        $errmsg = "Could not read \"$_\" (check permissions)";
 
34
  my $project_no_prompt = 0;
 
35
 DATA: foreach my $thisfile (@data) {
 
36
    next unless (($thisfile) and ($thisfile !~ /^\s*$/));
 
37
    unless (-r $thisfile) {
 
38
      if (-e $thisfile) {
 
39
        $errmsg = "Could not read \"$thisfile\" (check permissions)";
37
40
        $top -> Dialog(-bitmap  => 'error',
38
41
                       -text    => $errmsg,
39
42
                       -title   => 'Athena: Error reading file',
42
45
          -> Show();
43
46
        Error($errmsg);
44
47
      } else {
45
 
        $errmsg = "Could not read \"$_\" (file does not exist)";
 
48
        $errmsg = "Could not read \"$thisfile\" (file does not exist)";
46
49
        $top -> Dialog(-bitmap  => 'error',
47
50
                       -text    => $errmsg,
48
51
                       -title   => 'Athena: Error reading file',
57
60
 
58
61
    Archive::Zip::setErrorHandler( \&is_zip_error_handler );
59
62
    my $zip = Archive::Zip->new();
60
 
    ##print $zip->read($_), $/;
61
 
    my $is_zipstyle = ($zip->read($_) == AZ_OK) ? 1 : 0;
 
63
    ##print $zip->read($thisfile), $/;
 
64
    my $is_zipstyle = ($zip->read($thisfile) == AZ_OK) ? 1 : 0;
62
65
    my $is_artemis = ($is_zipstyle) ? $zip->membersMatching(/HORAE/) : 0;
63
 
    ##print "$_|$is_zipstyle|$is_artemis\n";
 
66
    ##print "$thisfile|$is_zipstyle|$is_artemis\n";
64
67
    undef $zip;
65
68
    Archive::Zip::setErrorHandler( undef );
66
69
    if ($is_artemis) {
67
 
      $errmsg = "Oops!  $_ seems to be an Artemis project file.";
 
70
      $errmsg = "Oops!  $thisfile seems to be an Artemis project file.";
68
71
      $top -> Dialog(-bitmap  => 'error',
69
72
                     -text    => $errmsg,
70
73
                     -title   => 'Athena: Error reading file',
76
79
      next DATA;
77
80
    };
78
81
    if ($is_zipstyle) {
79
 
      $errmsg = "$_ is not a valid data file.";
 
82
      $errmsg = "$thisfile is not a valid data file.";
80
83
      $top -> Dialog(-bitmap  => 'error',
81
84
                     -text    => $errmsg,
82
85
                     -title   => 'Athena: Error reading file',
90
93
 
91
94
 
92
95
    # does this one have mac line-endings?
93
 
#    my $was_mac = $groups{"Default Parameters"} ->
94
 
#      fix_mac($_, $stash_dir, lc($config{general}{mac_eol}), $top);
95
 
#    Echo("\"$_\" had Macintosh EOL characters and was skipped."), next DATA if ($was_mac == -1);
96
 
#    Echo("\"$_\" had Macintosh EOL characters and was fixed.") if ($was_mac == 1);
97
 
    my $is_record = (Ifeffit::Files->is_record($_));
 
96
#     my $was_mac = $groups{"Default Parameters"} ->
 
97
#       fix_mac($thisfile, $stash_dir, lc($config{general}{mac_eol}), $top);
 
98
#     Echo("\"$thisfile\" had Macintosh EOL characters and was skipped."), next DATA if ($was_mac eq '-1');
 
99
#     Echo("\"$thisfile\" had Macintosh EOL characters and was fixed.") if ($was_mac eq '1');
 
100
    my $is_record = (Ifeffit::Files->is_record($thisfile));
 
101
    my ($is_mac, $tempfile) = (0, q{});
 
102
    if (not $is_record) {
 
103
      local( $/, *FH ) ;
 
104
      open( FH, $thisfile ) or die "sudden flaming death\n";
 
105
      my $snarf = <FH>;
 
106
      close(FH);
 
107
      if ($snarf =~ m{\r(?!\n)}) { # this matches Mac EOL but not Windows
 
108
        Echo("Correcting Mac line termination for $thisfile");
 
109
        $tempfile =  File::Spec->catfile($stash_dir, "unmacify_".basename($thisfile));
 
110
        $snarf =~ s{\r(?!\n)}{\n}g;
 
111
        open TF, ">",$tempfile;
 
112
        print TF $snarf;
 
113
        close TF;
 
114
        $is_mac = 1;
 
115
      };
 
116
    };
 
117
    my $thisfile_notmac = ($is_mac) ? $tempfile : $thisfile;
 
118
 
98
119
    my @foo = %marked;
99
120
    my $empty = $#foo;
100
121
    my $safe_message_issued = 0;
101
122
    my %stash;
102
123
    my %map;
103
124
    if ($is_record) {
104
 
      my $fname = $_;
 
125
      my $fname = $thisfile_notmac;
 
126
      my %group_map = ();
 
127
      my ($imported, $total) = (0,0);
 
128
      my $frame = examine_project($fname, \%group_map, \$cancel, \$project_no_prompt);
 
129
      ($frame == 0) or $frame -> waitWindow();
 
130
      last DATA if ($cancel);
105
131
      my $nrecords = 0;
106
132
      $reading_project = 1;
107
 
      &push_mru($fname, 1, 1);
108
 
      ##open R, $fname or die "Could not open $_ as a record or project\n";
 
133
      ##open R, $fname or die "Could not open $thisfile_notmac as a record or project\n";
109
134
      my $gz = gzopen($fname, "rb") or die "could not open $fname as an Athena project\n";
110
135
      my $line;
111
136
      use vars qw($old_group @args @x @y @journal @stddev @i0 %foo);
123
148
            ($line =~ /^\@journal/) and do {
124
149
              eval $line;
125
150
              foreach (@journal) {
126
 
                $notes{journal} -> insert('end', $line."\n");
 
151
                $notes{journal} -> insert('end', $line."\n", "text");
127
152
              };
128
153
              last WINDOWS;
129
154
            };
201
226
              @ {$cpt->varglob('journal')} = $cpt->reval($line);
202
227
              @journal = @ {$cpt->varglob('journal')};
203
228
              foreach (@journal) {
204
 
                $notes{journal} -> insert('end', $_."\n");
 
229
                $notes{journal} -> insert('end', $_."\n", "text");
205
230
              };
206
231
              last NOT_WINDOWS;
207
232
            };
208
233
            ($line =~ /^\%plot_features/) and do {
209
 
              s/\%/\@/;
 
234
              $line =~ s{^\%}{\@};
210
235
              @ {$cpt->varglob('plot_features')} = $cpt->reval($line);
211
236
              my @list = @ {$cpt->varglob('plot_features')};
212
237
              while (@list) {   # only set the things in the plot
213
238
                my ($k, $v) = (shift @list, shift @list); # options area
214
 
                next unless ($k =~ /[ekqr]((_\w+)|(m(ax|in)))/);
 
239
                next unless ($k =~ /[ekqr]((_\w+)|(m(ax|in))|w)/);
215
240
                $plot_features{$k} = $v;
216
241
              };
217
242
              ($plot_features{e_marked} = 'n') if ($plot_features{e_marked} eq 'd');
 
243
              delete $plot_features{project};
218
244
              last NOT_WINDOWS;
219
245
            };
220
246
            ($line =~ /^\@indicator/) and do {
267
293
              last NOT_WINDOWS;
268
294
            };
269
295
            (($line =~ /^\[record\]/) or ($line =~ /^\&read_record/)) and do {
 
296
              ++$total;
 
297
              last NOT_WINDOWS if not $group_map{$old_group}; # from examine_project
 
298
              ++$imported;
270
299
              my $memory_ok = $groups{"Default Parameters"}
271
300
                -> memory_check($top, \&Echo, \%groups, $max_heap, 0, 1);
272
301
              Echo ("Out of memory in Ifeffit"), last DATA if ($memory_ok == -1);
289
318
        Echo("The project file \"$fname\" contained no records.");
290
319
        return;
291
320
      };
 
321
      my $complete = ($total == $imported);
 
322
      &push_mru($thisfile, 1, 1, $complete);
292
323
      project_state(1) if ($empty == -1);
293
324
 
294
325
 
343
374
        };
344
375
        ## reference channels
345
376
        if ($groups{$k}->{reference}) {
 
377
          my $found = 0;
346
378
        INNER: foreach my $o (keys %groups) {
347
379
            next if ($o eq "Default Parameters");
348
380
            next if ($o eq $k);
351
383
                (exists $groups{$o}->{old_group}) and
352
384
                ($groups{$k}->{reference} eq $groups{$o}->{old_group})) {
353
385
              $groups{$k}->MAKE(reference=>$o);
 
386
              $found = 1;
354
387
              last INNER;
355
388
            };
356
389
          };
 
390
          $groups{$k}->MAKE(reference=>0) if
 
391
            ((not $found) and ## in case of partial project import
 
392
             (not exists($groups{$groups{$k}->{reference}}))); # already in project
357
393
        };
358
394
        ## linear combination fitting standards
359
395
        if ($groups{$k}->{lcf_fit}) {
408
444
#       };
409
445
      };
410
446
    } else {
411
 
      my $foo = $_;
412
 
      ($raw, $prior_string) = read_raw($_, $prior_string, $prior_args, \$cancel, $count);
 
447
      #my $foo = $thisfile_notmac;
 
448
      ($raw, $prior_string) = read_raw($thisfile_notmac, $thisfile, $prior_string, $prior_args, \$cancel, $count);
413
449
      ($raw == 0) or $raw -> waitWindow();
414
450
      last DATA if ($cancel);
415
451
      ++$count;
417
453
    };
418
454
  };
419
455
  ## unset extra import features
420
 
  $rebin{do_rebin}      = 0;
 
456
  #$rebin{do_rebin}     = 0;
 
457
  $preprocess{standard} ||= 'None';
 
458
  #$preprocess{mark_do} = 0;
 
459
  #$preprocess{trun_do} = 0;
 
460
  #$preprocess{deg_do}  = 0;
 
461
 
 
462
  $preprocess{raised} ||= "reference";
421
463
  $rebin{titles}        = [];
422
 
  $preprocess{standard} = 'None';
423
 
  $preprocess{mark_do}  = 0;
424
 
  $preprocess{trun_do}  = 0;
425
 
  $preprocess{deg_do}   = 0;
426
464
  $preprocess{titles}   = [];
427
465
 
428
466
  section_indicators();
468
506
               ['chi(k) files',         '.chi'],
469
507
               ['Athena project files', '.prj'],
470
508
              ];
471
 
  my $file = $top -> getOpenFile(-filetypes=>$types,
472
 
                                 #(not $is_windows) ?
473
 
                                 #  (-sortcmd=>sub{$Tk::FBox::a cmp $Tk::FBox::b}) : () ,
474
 
                                 -initialdir=>$path,
475
 
                                 -title => "Athena: Open a SINGLE data file");
476
 
  return $file;
 
509
  if ($Tk::VERSION > 804) {
 
510
    my $file = $top -> getOpenFile(-filetypes=>$types,
 
511
                                   #(not $is_windows) ?
 
512
                                   #  (-sortcmd=>sub{$Tk::FBox::a cmp $Tk::FBox::b}) : () ,
 
513
                                   -initialdir=>$path,
 
514
                                   -multiple => 1,
 
515
                                   -title => "Athena: Open one or more data files");
 
516
    $file ||= [];
 
517
    return @$file;
 
518
  } else {
 
519
    my $file = $top -> getOpenFile(-filetypes=>$types,
 
520
                                   #(not $is_windows) ?
 
521
                                   #  (-sortcmd=>sub{$Tk::FBox::a cmp $Tk::FBox::b}) : () ,
 
522
                                   -initialdir=>$path,
 
523
                                   -title => "Athena: Open a SINGLE data file");
 
524
    $file ||= q{};
 
525
    return $file;
 
526
  };
477
527
};
478
528
 
479
529
 
485
535
  my $types = [['Athena project files', '.prj'],
486
536
               ['All Files',            '*'],
487
537
              ];
488
 
  my $file = $top -> getOpenFile(-filetypes=>$types,
489
 
                                 #(not $is_windows) ?
490
 
                                 #  (-sortcmd=>sub{$Tk::FBox::a cmp $Tk::FBox::b}) : () ,
491
 
                                 -initialdir=>$path,
492
 
                                 -title => "Athena: Open a demo project");
 
538
  my $file = scalar $top -> getOpenFile(-filetypes=>$types,
 
539
                                        #(not $is_windows) ?
 
540
                                        #  (-sortcmd=>sub{$Tk::FBox::a cmp $Tk::FBox::b}) : () ,
 
541
                                        -initialdir=>$path,
 
542
                                        -multiple => 0,
 
543
                                        -title => "Athena: Open a demo project");
493
544
  if ($file) {
494
545
    read_file(0,$file);
495
546
    raise_palette('journal');
501
552
 
502
553
  my $red = $config{colors}{single};
503
554
 
504
 
  my ($data, $prior_string, $prior_args, $r_cancel, $count) = @_;
 
555
  my ($data, $orig, $prior_string, $prior_args, $r_cancel, $count) = @_;
505
556
                                ## look at first file in list to see
506
557
                                ## if this is a record or raw dat
507
558
  my $memory_ok = $groups{"Default Parameters"}
583
634
    set_status(0);
584
635
    return (0, $prior_string);
585
636
  };
586
 
  my $suff = (split(" ", Ifeffit::get_string('$column_label')))[0];
 
637
  my $str = &column_string;
 
638
  my $suff = (split(" ", $str))[0];
587
639
  $groups{"Default Parameters"} -> dispose("set ___n = npts($group.$suff)", $dmode);
588
640
  my $nn = Ifeffit::get_scalar("___n");
589
641
  unless ($nn > $config{general}{minpts}) {
600
652
    return (0, $prior_string);
601
653
  };
602
654
 
603
 
  &push_mru($data, 1);
 
655
  &push_mru($orig, 1);
604
656
 
605
657
  ## the heuristic for deciding if the interpretation of the columns
606
658
  ## has changed is the value of ifeffit's column_label variable.  I
609
661
  ## heuristic for data with labeled columns, but can be trouble for
610
662
  ## unlabeled columns.  In that case, the arrays are called $group.1,
611
663
  ## $group.2, etc.
612
 
  my $col_string = Ifeffit::get_string('$column_label');
 
664
  my $col_string = &column_string;
613
665
    ## this is trouble -- need to know difference between one file and many files
614
666
  if (($count > 1) and ($col_string eq $prior_string)) {
615
667
    construct_xmu(0, $group, $label, $data, $stash, $prior_args);
627
679
  $raw -> bind('<Control-d>' => sub{$colsel_geometry = $raw->geometry; $$r_cancel = 1; $raw->destroy; return (-1, $prior_string)});
628
680
  my ($fnlabel, $enlabel, $unlabel);
629
681
  my $grey= '#9c9583';
 
682
  my $active_color = $config{colors}{activehighlightcolor};
630
683
  ##my $preproc_state = (scalar(keys %groups) == 1) ? 'disabled' : 'normal';
631
684
  my $preproc_state = 'normal';
632
685
  my $preproc_number = scalar(keys %groups);
771
824
    $sorted      = $$prior_args{sorted} || "";
772
825
    ($xmustring, @toss) = make_xmu_string(\%numerator, \%denominator, $do_ln, $invert, $energy);
773
826
  } else {
 
827
 
 
828
    ## reset all the preprocessing stuff if this one is different
 
829
    $rebin{do_rebin}      = 0;
 
830
    $preprocess{standard} = 'None';
 
831
    $preprocess{mark_do}  = 0;
 
832
    $preprocess{trun_do}  = 0;
 
833
    $preprocess{deg_do}   = 0;
 
834
    $preprocess{raised}   = 'reference';
 
835
 
774
836
    %reference  = (numerator=>0, denominator=>0, ln=>1, same=>1);
775
837
    $$prior_args{evkev}  = 'ev';
776
838
    foreach (@cols) {
931
993
                              #$widg{pre}->configure(-state=>$preproc_state);
932
994
                              $enlabel -> configure(-text=>'Energy:');
933
995
                              $fnlabel -> configure(-text=>'mu(E):');
934
 
                              $unlabel -> configure(-foreground=>$config{colors}{activehighlightcolor}); });
 
996
                              $unlabel -> configure(-foreground=>$active_color); });
935
997
  $om ->command(-label=>'norm(E)',
936
998
                -command=>sub{$space='n'; $space_label='norm(E)';
937
999
                              $widg{evkev}->configure(-state=>'normal');
938
1000
                              #$widg{pre}->configure(-state=>$preproc_state);
939
1001
                              $enlabel -> configure(-text=>'Energy:');
940
1002
                              $fnlabel -> configure(-text=>'norm(E):');
941
 
                              $unlabel -> configure(-foreground=>$config{colors}{activehighlightcolor}); });
 
1003
                              $unlabel -> configure(-foreground=>$active_color); });
942
1004
  $om ->command(-label=>'xanes(E)',
943
1005
                -command=>sub{$space='a'; $space_label='xanes(E)';
944
1006
                              $widg{evkev}->configure(-state=>'normal');
945
1007
                              #$widg{pre}->configure(-state=>$preproc_state);
946
1008
                              $enlabel -> configure(-text=>'Energy:');
947
1009
                              $fnlabel -> configure(-text=>'mu(E):');
948
 
                              $unlabel -> configure(-foreground=>$config{colors}{activehighlightcolor}); });
 
1010
                              $unlabel -> configure(-foreground=>$active_color); });
949
1011
  $om ->command(-label=>'chi(k)',
950
1012
                -command=>sub{$space='k'; $space_label='chi(k)';
951
1013
                              $widg{evkev}->configure(-state=>'disabled');
959
1021
                              #$widg{pre}->configure(-state=>$preproc_state);
960
1022
                              $enlabel -> configure(-text=>'Energy:');
961
1023
                              $fnlabel -> configure(-text=>'det(E):');
962
 
                              $unlabel -> configure(-foreground=>$config{colors}{activehighlightcolor});});
 
1024
                              $unlabel -> configure(-foreground=>$active_color);});
963
1025
  $om ->command(-label=>'xmu.dat',
964
1026
                -command=>sub{$space='x'; $space_label='xmu.dat';
965
1027
                              $widg{evkev}->configure(-state=>'normal');
966
1028
                              #$widg{pre}->configure(-state=>'disabled');
967
1029
                              $enlabel -> configure(-text=>'Energy:');
968
1030
                              $fnlabel -> configure(-text=>'theory:');
969
 
                              $unlabel -> configure(-foreground=>$config{colors}{activehighlightcolor}); });
 
1031
                              $unlabel -> configure(-foreground=>$active_color); });
970
1032
  $om ->command(-label=>'chi.dat',
971
1033
                -command=>sub{$space='c'; $space_label='chi.dat';
972
1034
                              $widg{evkev}->configure(-state=>'disabled');
984
1046
                                   -borderwidth=>1,
985
1047
                                   -textvariable=>\$evkev, -width=>6)
986
1048
    -> pack(-side=>'left');
987
 
  $widg{evkev} -> command(-label=>'eV',      -command=>sub{$evkev = 'ev';
988
 
                                                           $widg{extras} -> raise(($preproc_number>1) ? 'preprocessing' : 'reference');
989
 
                                                           $$prior_args{old}         = $energy;
990
 
                                                           $$prior_args{numerator}   = \%numerator;
991
 
                                                           $$prior_args{denominator} = \%denominator;
992
 
                                                           $$prior_args{do_ln}       = $do_ln;
993
 
                                                           $$prior_args{invert}      = $invert;
994
 
                                                           $$prior_args{space}       = $space;
995
 
                                                           $$prior_args{evkev}       = $evkev;
996
 
                                                           $$prior_args{is_xmudat}   = $is_xmudat;
997
 
                                                           $$prior_args{sort}        = $sort;
998
 
                                                           $$prior_args{multi}       = $multi;
999
 
                                                           $$prior_args{ref}         = \%reference;
1000
 
                                                           ($xmustring, @toss) = make_xmu_string(\%numerator, \%denominator, $do_ln, $invert, $energy)
1001
 
                                                         });
1002
 
  $widg{evkev} -> command(-label=>'keV',     -command=>sub{$evkev = 'kev';
1003
 
                                                           $widg{extras} -> raise(($preproc_number>1) ? 'preprocessing' : 'reference');
1004
 
                                                           $$prior_args{old}         = $energy;
1005
 
                                                           $$prior_args{numerator}   = \%numerator;
1006
 
                                                           $$prior_args{denominator} = \%denominator;
1007
 
                                                           $$prior_args{do_ln}       = $do_ln;
1008
 
                                                           $$prior_args{invert}      = $invert;
1009
 
                                                           $$prior_args{space}       = $space;
1010
 
                                                           $$prior_args{evkev}       = $evkev;
1011
 
                                                           $$prior_args{is_xmudat}   = $is_xmudat;
1012
 
                                                           $$prior_args{sort}        = $sort;
1013
 
                                                           $$prior_args{multi}       = $multi;
1014
 
                                                           $$prior_args{ref}         = \%reference;
1015
 
                                                           ($xmustring, @toss) = make_xmu_string(\%numerator, \%denominator, $do_ln, $invert, $energy)
1016
 
                                                         });
1017
 
  $widg{evkev} -> command(-label=>'pixel',   -command=>sub{$evkev = 'pixel';
1018
 
                                                           $widg{extras} -> raise(($preproc_number>1) ? 'preprocessing' : 'reference');
1019
 
                                                           $$prior_args{old}         = $energy;
1020
 
                                                           $$prior_args{numerator}   = \%numerator;
1021
 
                                                           $$prior_args{denominator} = \%denominator;
1022
 
                                                           $$prior_args{do_ln}       = $do_ln;
1023
 
                                                           $$prior_args{invert}      = $invert;
1024
 
                                                           $$prior_args{space}       = $space;
1025
 
                                                           $$prior_args{evkev}       = $evkev;
1026
 
                                                           $$prior_args{is_xmudat}   = $is_xmudat;
1027
 
                                                           $$prior_args{sort}        = $sort;
1028
 
                                                           $$prior_args{multi}       = $multi;
1029
 
                                                           $$prior_args{ref}         = \%reference;
1030
 
                                                           ($xmustring, @toss) = make_xmu_string(\%numerator, \%denominator, $do_ln, $invert, $energy)
1031
 
                                                         },
 
1049
  $widg{evkev} -> command(-label  =>'eV',
 
1050
                          -command=>sub{$evkev = 'ev';
 
1051
                                        #$widg{extras} -> raise(($preproc_number>1) ? 'preprocessing' : 'reference');
 
1052
                                        $$prior_args{old}            = $energy;
 
1053
                                        $$prior_args{numerator}   = \%numerator;
 
1054
                                        $$prior_args{denominator} = \%denominator;
 
1055
                                        $$prior_args{do_ln}          = $do_ln;
 
1056
                                        $$prior_args{invert}         = $invert;
 
1057
                                        $$prior_args{space}          = $space;
 
1058
                                        $$prior_args{evkev}          = $evkev;
 
1059
                                        $$prior_args{is_xmudat}   = $is_xmudat;
 
1060
                                        $$prior_args{sort}           = $sort;
 
1061
                                        $$prior_args{multi}          = $multi;
 
1062
                                        $$prior_args{ref}            = \%reference;
 
1063
                                        ($xmustring, @toss) = make_xmu_string(\%numerator, \%denominator, $do_ln, $invert, $energy)
 
1064
                                      });
 
1065
  $widg{evkev} -> command(-label  =>'keV',
 
1066
                          -command=>sub{$evkev = 'kev';
 
1067
                                        #$widg{extras} -> raise(($preproc_number>1) ? 'preprocessing' : 'reference');
 
1068
                                        $$prior_args{old}            = $energy;
 
1069
                                        $$prior_args{numerator}   = \%numerator;
 
1070
                                        $$prior_args{denominator} = \%denominator;
 
1071
                                        $$prior_args{do_ln}          = $do_ln;
 
1072
                                        $$prior_args{invert}         = $invert;
 
1073
                                        $$prior_args{space}          = $space;
 
1074
                                        $$prior_args{evkev}          = $evkev;
 
1075
                                        $$prior_args{is_xmudat}   = $is_xmudat;
 
1076
                                        $$prior_args{sort}           = $sort;
 
1077
                                        $$prior_args{multi}          = $multi;
 
1078
                                        $$prior_args{ref}            = \%reference;
 
1079
                                        ($xmustring, @toss) = make_xmu_string(\%numerator, \%denominator, $do_ln, $invert, $energy)
 
1080
                                      });
 
1081
  $widg{evkev} -> command(-label  =>'pixel',
 
1082
                          -command=>sub{$evkev = 'pixel';
 
1083
                                        #$widg{extras} -> raise(($preproc_number>1) ? 'preprocessing' : 'reference');
 
1084
                                        $$prior_args{old}            = $energy;
 
1085
                                        $$prior_args{numerator}   = \%numerator;
 
1086
                                        $$prior_args{denominator} = \%denominator;
 
1087
                                        $$prior_args{do_ln}          = $do_ln;
 
1088
                                        $$prior_args{invert}         = $invert;
 
1089
                                        $$prior_args{space}          = $space;
 
1090
                                        $$prior_args{evkev}          = $evkev;
 
1091
                                        $$prior_args{is_xmudat}   = $is_xmudat;
 
1092
                                        $$prior_args{sort}           = $sort;
 
1093
                                        $$prior_args{multi}          = $multi;
 
1094
                                        $$prior_args{ref}            = \%reference;
 
1095
                                        ($xmustring, @toss) = make_xmu_string(\%numerator, \%denominator, $do_ln, $invert, $energy)
 
1096
                                      },
1032
1097
                          -state=>($config{pixel}{do_pixel_check}) ? 'normal' : 'disabled');
1033
1098
  if ($space =~ /[ck]/) {
1034
1099
    $widg{evkev}->configure(-state=>'disabled');
1048
1113
 
1049
1114
 
1050
1115
 
 
1116
  $preprocess{raised} ||= "reference";
1051
1117
  $widg{extras} = $left -> NoteBook(-background=>$config{colors}{background},
1052
1118
                                    -backpagecolor=>$config{colors}{background},
1053
1119
                                    -inactivebackground=>$config{colors}{inactivebackground},
1054
1120
                                    -font=>$config{fonts}{small},
1055
 
                                   );
 
1121
                                   )
 
1122
     -> pack(-pady=>2, -expand=>1, -fill=>'x');
1056
1123
  $widg{pre_card} = $widg{extras} ->
1057
1124
    add("preprocessing", -label=>'Preprocess', -anchor=>'center',
1058
1125
        -state=>$preproc_state);
1071
1138
  ##   -> add("favorites",     -label=>'Favorites',   -anchor=>'center',);
1072
1139
  ## set_favorites(\%widg)
1073
1140
  ##   -> pack(-anchor=>'n', -fill=>'x');
 
1141
  $widg{extras} -> raise($preprocess{raised});
1074
1142
 
1075
 
  $$prior_args{extra_shown} = 0;
1076
 
  $widg{extra_button} = $left -> Button(-text=>'Show extra features', @button_list,
1077
 
                                        -command=>
1078
 
                                        sub{
1079
 
                                          my ($h,$w) = ($left->height(), $raw->width());
1080
 
                                          $reference{preproc_state} = $preproc_state;
1081
 
                                          $widg{extra_button} -> packForget;
1082
 
                                          $top -> update; # needed so $raw resizes correctly
1083
 
                                          $widg{extras} -> pack(-pady=>2, -expand=>1, -fill=>'x');
1084
 
                                          $right->pack(-expand=>1, -fill=>'both',
1085
 
                                                       -side=>'right', -anchor=>'n');
1086
 
                                          $databox->pack(-expand=>1, -fill=>'both',
1087
 
                                                         -padx=>4, -pady=>2);
1088
 
                                          $widg{extras} -> raise(($preproc_number>1 eq 'normal') ? 'preprocessing' : 'reference');
1089
 
                                          $$prior_args{extra_shown} = 1;
1090
 
                                        })
1091
 
    -> pack(-expand=>1, -fill=>'x', -pady=>0);
 
1143
  $$prior_args{extra_shown} = 1; # 0;
 
1144
##   $widg{extra_button} = $left -> Button(-text=>'Show extra features', @button_list,
 
1145
##                                      -command=>
 
1146
##                                      sub{
 
1147
##                                        my ($h,$w) = ($left->height(), $raw->width());
 
1148
##                                        $reference{preproc_state} = $preproc_state;
 
1149
##                                        $widg{extra_button} -> packForget;
 
1150
##                                        $top -> update; # needed so $raw resizes correctly
 
1151
##                                        $widg{extras} -> pack(-pady=>2, -expand=>1, -fill=>'x');
 
1152
##                                        $right->pack(-expand=>1, -fill=>'both',
 
1153
##                                                     -side=>'right', -anchor=>'n');
 
1154
##                                        $databox->pack(-expand=>1, -fill=>'both',
 
1155
##                                                       -padx=>4, -pady=>2);
 
1156
##                                        $widg{extras} -> raise(($preproc_number>1 eq 'normal') ? 'preprocessing' : 'reference');
 
1157
##                                        $$prior_args{extra_shown} = 1;
 
1158
##                                      })
 
1159
##     -> pack(-expand=>1, -fill=>'x', -pady=>0);
1092
1160
 
1093
1161
 
1094
1162
  ## help button
1136
1204
                                 return (-1, $prior_string);
1137
1205
                               };
1138
1206
                             };
 
1207
                             $preprocess{raised} = $widg{extras}->raised();
1139
1208
                             $colsel_geometry = $raw->geometry;
1140
1209
                             $$prior_args{old}         = $energy;
1141
1210
                             $$prior_args{numerator}   = \%numerator;
1168
1237
                                -wrap none -scrollbars se -width 50/,
1169
1238
                                -font=>$config{fonts}{fixed})
1170
1239
    -> pack(-expand=>1, -fill=>'both', -padx=>4, -pady=>2);
 
1240
  $databox -> tagConfigure("text", -font=>$config{fonts}{fixedsm});
1171
1241
  $widg{databox} = $databox;
1172
1242
  BindMouseWheel($databox);
1173
1243
  $databox->Subwidget("xscrollbar")->configure(-background=>$config{colors}{background});
1176
1246
  open F, $to_display or die "Could not open $to_display\n";
1177
1247
  while (<F>) {
1178
1248
    s/\r//;
1179
 
    $databox -> insert('end', $_);
 
1249
    $databox -> insert('end', $_, 'text');
1180
1250
  };
1181
1251
  close F;
1182
1252
  ## display the multi-element button properly
1191
1261
  ## print Data::Dumper->Dump([\%reference], [qw(*reference)]);
1192
1262
  if ($reference{numerator} or $reference{denominator}) {
1193
1263
    $reference{preproc_state} = $preproc_state;
1194
 
    $widg{extra_button} -> packForget;
 
1264
    ##$widg{extra_button} -> packForget;
1195
1265
    $top -> update; # needed so $raw resizes correctly
1196
1266
    $widg{extras} -> pack(-pady=>2, -expand=>1, -fill=>'x');
1197
1267
    $right->pack(-expand=>1, -fill=>'both', -side=>'right', -anchor=>'n');
1198
1268
    $databox->pack(-expand=>1, -fill=>'both', -padx=>4, -pady=>2);
1199
 
    $widg{extras} -> raise('reference');
 
1269
    #$widg{extras} -> raise('reference');
1200
1270
    $$prior_args{extra_shown} = 1;
1201
1271
  };
1202
1272
 
1219
1289
  return ($raw, $col_string);
1220
1290
};
1221
1291
 
 
1292
 
 
1293
sub column_string {
 
1294
  my $col_string = q{};
 
1295
  my $i = 1;
 
1296
  my $this = Ifeffit::get_string('$column_label'.$i);
 
1297
  while ($this !~ m{^\s*$}) {
 
1298
    $col_string .= $this . ' ';
 
1299
    ++$i;
 
1300
    $this = Ifeffit::get_string('$column_label'.$i)
 
1301
  };
 
1302
  # $col_string =~ s{^nergy}{energy}i;
 
1303
  return $col_string;
 
1304
};
 
1305
 
1222
1306
## this suppresses a nattering message that warns, in cryptic fashion,
1223
1307
## when you attempt to read a non-zip file as a zip file.  since that
1224
1308
## is the only way to test for zippiness of a file using Archive::Zip,
1348
1432
      ## ifeffit and carry on like normal data
1349
1433
 
1350
1434
      ## This gets a list of column labels
1351
 
      my @cols = split(" ", Ifeffit::get_string("column_label"));
 
1435
      my @cols = split(" ", &column_string);
1352
1436
      my @lol;
1353
1437
      ## energy value is zeroth in each anon list
1354
1438
      my @array = get_array("$en");
1455
1539
      };
1456
1540
    } elsif ($space eq 'a') {
1457
1541
      $groups{$grp} -> make(not_data=>0, is_xmu=>1, is_xanes=>1,
1458
 
                            is_chi=>0, is_rsp=>0, is_qsp=>0);
 
1542
                            is_chi=>0, is_rsp=>0, is_qsp=>0, bkg_nnorm=>2);
1459
1543
      if ($evkev eq 'ev') {
1460
1544
        $groups{$grp} -> dispose("set $grp.energy = $en\n", $dmode);
1461
1545
      } elsif ($evkev eq 'pixel') {
1684
1768
 
1685
1769
sub clean_unused_columns {
1686
1770
  my ($group, $en, $num, $den) = @_;
1687
 
  my @col_string = split(" ", Ifeffit::get_string('$column_label'));
 
1771
  my @col_string = split(" ", &column_string);
1688
1772
  my @words = split(/[() \t+]+/, $num);
1689
1773
  push @words, split(/[() \t+]+/, $den);
1690
1774
  if ($groups{$group}->{reference}) {
1751
1835
 
1752
1836
  $preprocess{keys} = ['None', &sorted_group_list];
1753
1837
  $widgets{standard} = $frame -> BrowseEntry(-variable => \$preprocess{standard_lab},
 
1838
                                             @browseentry_list,
1754
1839
                                             -browsecmd => sub {
1755
1840
                                               my $text = $_[1];
1756
1841
                                               my $this = $1 if ($text =~ /^(\d+):/);
2142
2227
                                                       $groups{$x}->{plot_yoffset});
2143
2228
                   })
2144
2229
    -> pack(-expand=>1, -fill=>'x', -padx=>1, -pady=>2, -side=>'left');
2145
 
  $frame -> Button(-text=>'Dismiss extras', -width=>5, @button_list,
2146
 
                   -command => sub{remove_extras($widg)} )
2147
 
    -> pack(-expand=>1, -fill=>'x', -padx=>1, -pady=>2, -side=>'right');
 
2230
  ##$frame -> Button(-text=>'Dismiss extras', -width=>5, @button_list,
 
2231
  ##               -command => sub{remove_extras($widg)} )
 
2232
  ##  -> pack(-expand=>1, -fill=>'x', -padx=>1, -pady=>2, -side=>'right');
2148
2233
 
2149
2234
  ## initial setup
2150
 
  foreach (keys %labels) {
2151
 
    $labels{$_}->configure(-foreground=>($preprocess{standard} eq 'None') ?
2152
 
                           '#9c9583' : $config{colors}{activehighlightcolor});
 
2235
  my $notnone = $config{colors}{activehighlightcolor};
 
2236
  foreach (qw(deg_emin deg_emax deg_tol)) {
 
2237
    my $active = (($preprocess{standard} ne 'None') and $preprocess{deg_do});
 
2238
    $labels{$_}->configure(-foreground=> $active ? '#9c9583' : $notnone);
 
2239
  };
 
2240
  foreach (qw(trun_e)) {
 
2241
    my $active = (($preprocess{standard} ne 'None') and $preprocess{trun_do});
 
2242
    $labels{$_}->configure(-foreground=> $active ? '#9c9583' : $notnone);
2153
2243
  };
2154
2244
  foreach (keys %widgets) {
2155
2245
    next if ($_ eq 'standard'); # or ($_ =~ /(deg|trun)_check/));
2269
2359
  };
2270
2360
  push @bingrid, $elast;
2271
2361
  Ifeffit::put_array("$group.xxx", \@bingrid);
2272
 
  foreach my $y (split(" ", Ifeffit::get_string('$column_label'))) {
 
2362
  foreach my $y (split(" ", &column_string)) {
2273
2363
    next if ($y eq 'energy');
2274
2364
    ## also do not want to rebin, say, $g.1 if "1" is the energy column
2275
2365
    $groups{$group}->dispose("set $group.rebin = rebin($group.energy, $group.$y, $group.xxx)", $dmode);
2371
2461
                              $$reference{same}        = 1;
2372
2462
                            })
2373
2463
    -> pack(-side=>'left', -fill=>'x', -padx=>8, -anchor=>'e');
2374
 
  $fr -> Button(-text=>'Dismiss extras', @button_list,
2375
 
                -command=>sub{remove_extras($widg)})
2376
 
    -> pack(-side=>'left', -fill=>'x', -padx=>8, -anchor=>'e');
 
2464
  ##$fr -> Button(-text=>'Dismiss extras', @button_list,
 
2465
  ##            -command=>sub{remove_extras($widg)})
 
2466
  ##  -> pack(-side=>'left', -fill=>'x', -padx=>8, -anchor=>'e');
2377
2467
  return $parent;
2378
2468
};
2379
2469
 
2452
2542
 
2453
2543
  $frame = $parent -> Frame(-relief=>'flat', -borderwidth=>0)
2454
2544
    -> pack(-expand=>1, -fill=>'x', -pady=>4);
2455
 
  $frame -> Button(-text=>'Dismiss extras', -width=>5, @button_list,
2456
 
                   -command => sub{remove_extras($widg)} )
2457
 
    -> pack(-expand=>1, -fill=>'x', -padx=>1, -pady=>2, -side=>'right');
 
2545
  ##$frame -> Button(-text=>'Dismiss extras', -width=>5, @button_list,
 
2546
  ##               -command => sub{remove_extras($widg)} )
 
2547
  ##  -> pack(-expand=>1, -fill=>'x', -padx=>1, -pady=>2, -side=>'right');
2458
2548
 
2459
2549
  return $parent;
2460
2550
};
2507
2597
## be saved by this subroutine
2508
2598
sub save_chi {
2509
2599
  Echo('No data!'), return unless ($current);
2510
 
  my $space = lc($_[0]);
 
2600
  my ($space, $in_loop, $dir) = @_;
 
2601
  $space = lc($space);
2511
2602
  Echo("You cannot save chi for the Default Parameters"), return 0
2512
2603
    if ($current eq "Default Parameters");
2513
2604
  $top -> Busy;
2514
 
  my $this = $current;
 
2605
  my $this = $in_loop || $current;
2515
2606
  my ($suffix, $text) = ('chi', 'chi(k)');
2516
2607
 SWITCH: {
2517
2608
    (($suffix, $text) = ('chi1', 'k*chi(k)')),         last SWITCH if ($space eq 'k1');
2518
2609
    (($suffix, $text) = ('chi2', 'k^2*chi(k)')),       last SWITCH if ($space eq 'k2');
2519
2610
    (($suffix, $text) = ('chi3', 'k^3*chi(k)')),       last SWITCH if ($space eq 'k3');
 
2611
    (($suffix, $text) = ('chie', 'chi(E)')),           last SWITCH if ($space eq 'ke');
2520
2612
    (($suffix, $text) = ('xmu',  'mu(E)')),            last SWITCH if ($space eq 'e');
2521
2613
    (($suffix, $text) = ('nor',  'normalized mu(E)')), last SWITCH if ($space eq 'n');
2522
2614
    (($suffix, $text) = ('der',  'derivative mu(E)')), last SWITCH if ($space eq 'd');
2535
2627
  # spaces are common in filenames on Mac and Win, but not on un*x
2536
2628
  ($initial =~ s/\s+/_/g) unless ($is_windows or $is_darwin);
2537
2629
  ($initial =~ s/[\\:\/\*\?\'<>\|]/_/g);# if ($is_windows);
2538
 
  my $file = $top -> getSaveFile(-defaultextension=>$suffix,
2539
 
                                 -filetypes=>$types,
2540
 
                                 #(not $is_windows) ?
2541
 
                                 #  (-sortcmd=>sub{$Tk::FBox::a cmp $Tk::FBox::b}) : () ,
2542
 
                                 -initialdir=>$path,
2543
 
                                 -initialfile=>$initial,
2544
 
                                 -title => "Athena: Save $text data");
 
2630
  my $file = q{};
 
2631
  if ($in_loop) {
 
2632
    $file = File::Spec->catfile($dir, $initial);
 
2633
  } else {
 
2634
    $file = $top -> getSaveFile(-defaultextension=>$suffix,
 
2635
                                -filetypes=>$types,
 
2636
                                #(not $is_windows) ?
 
2637
                                #  (-sortcmd=>sub{$Tk::FBox::a cmp $Tk::FBox::b}) : () ,
 
2638
                                -initialdir=>$path,
 
2639
                                -initialfile=>$initial,
 
2640
                                -title => "Athena: Save $text data");
 
2641
  };
2545
2642
  if ($file) {
2546
2643
    ## make sure I can write to $file
2547
2644
    open F, ">".$file or do {
2661
2758
        $groups{$this}->dispose("erase $this.winout", $dmode);
2662
2759
        last SWITCH;
2663
2760
      };
 
2761
      ($space eq 'ke') and do {
 
2762
        ($groups{$this}->{update_bkg}) and $groups{$this}->dispatch_bkg($dmode);
 
2763
        my $e0      = $groups{$this}->{bkg_e0};
 
2764
        my $command = "$this.eee = $this.k^2/etok+$e0$/\n";
 
2765
        $command   .= "write_data(file=\"$file\", \$id_line, \$id2_line, \$param_line_\*, \$${this}_title_\*, $this.eee, $this.chi)\n";
 
2766
        $groups{$this}->dispose($command, $dmode);
 
2767
        last SWITCH;
 
2768
      };
2664
2769
      ($space eq 'q') and do {
2665
2770
        ($groups{$this}->{update_bkg}) and $groups{$this}->dispatch_bkg($dmode);
2666
2771
        ($groups{$this}->{update_fft}) and $groups{$this}->do_fft($dmode, \%plot_features);
2676
2781
    Echo("Saving $text data ... canceled", 0);
2677
2782
  };
2678
2783
  $top -> Unbusy;
 
2784
  return $text;
2679
2785
};
2680
2786
 
2681
2787
 
2699
2805
      ($x, $y, $mess) = ('k','chi1', "k*chi(k)"),                        last SWITCH if ($sp eq 'k1');
2700
2806
      ($x, $y, $mess) = ('k','chi2', "k^2*chi(k)"),                      last SWITCH if ($sp eq 'k2');
2701
2807
      ($x, $y, $mess) = ('k','chi3', "k^3*chi(k)"),                      last SWITCH if ($sp eq 'k3');
 
2808
      ($x, $y, $mess) = ('energy','chi', "chi(E)"),                      last SWITCH if ($sp eq 'ke');
2702
2809
      ($x, $y, $mess) = ('r','chir_mag', "the magnitude of chi(R)"),     last SWITCH if ($sp eq 'rm');
2703
2810
      ($x, $y, $mess) = ('r','chir_re', "the real part of chi(R)"),      last SWITCH if ($sp eq 'rr');
2704
2811
      ($x, $y, $mess) = ('r','chir_im', "the imaginary part of chi(R)"), last SWITCH if ($sp eq 'ri');
2706
2813
      ($x, $y, $mess) = ('q','chiq_re', "the real part of chi(q)"),      last SWITCH if ($sp eq 'qr');
2707
2814
      ($x, $y, $mess) = ('q','chiq_im', "the imaginary part of chi(q)"), last SWITCH if ($sp eq 'qi');
2708
2815
    };
2709
 
  my $types = [['All Files', '*'],];
 
2816
  my $types = [['All Files', '*'],[$x, '.'.$y]];
2710
2817
  my $path = $current_data_dir || Cwd::cwd;
2711
2818
  my $file = $top -> getSaveFile(-filetypes=>$types,
2712
2819
                                 #(not $is_windows) ?
2824
2931
  Echo("Saving $mess for each marked group ... done!");
2825
2932
};
2826
2933
 
2827
 
 
 
2934
sub save_each {
 
2935
  my ($sp) = @_;
 
2936
  my $m = 0;
 
2937
  map {$m += $_} values %marked;
 
2938
  Error("Saving files aborted.  There are no marked groups."), return 1 unless ($m);
 
2939
 
 
2940
  my $d = $top->DialogBox(-title   => "Artemis: Save each marked group to a directory",
 
2941
                          -buttons => ["Select", "Cancel"],
 
2942
                          ##-popover => 'cursor'
 
2943
                         );
 
2944
 
 
2945
  my $curr_dir = $current_data_dir;
 
2946
  my $label = $d -> add('Label', -textvariable=>\$curr_dir)
 
2947
    -> pack(-fill => "x", -expand => 1);
 
2948
  my $fr = $d -> add('Frame') -> pack(-fill => "both", -expand => 1);
 
2949
  ## ----> need a create new directory button <----
 
2950
  my $dt = $fr->Scrolled('DirTree',
 
2951
                         -scrollbars       => 'osoe',
 
2952
                         -width            => 55,
 
2953
                         -height           => 20,
 
2954
                         -selectmode       => 'browse',
 
2955
                         -exportselection  => 1,
 
2956
                         -directory        => $current_data_dir,
 
2957
                         -browsecmd        => sub { $curr_dir = shift },
 
2958
 
 
2959
                         # With this version of -command a double-click will
 
2960
                         # select the directory
 
2961
                         ##-command        => sub { $ok = 1 },
 
2962
 
 
2963
                         # With this version of -command a double-click will
 
2964
                         # open a directory. Selection is only possible with
 
2965
                         # the Ok button.
 
2966
                         #-command         => sub { $d->opencmd($_[0]) },
 
2967
                        )
 
2968
    ->pack(-fill => "both", -expand => 1);
 
2969
  my $this = $d -> Show();
 
2970
  Echo("Not saving each marked file"), return if ($this eq 'Cancel');
 
2971
 
 
2972
  my $text = q{};
 
2973
  my @list = (&sorted_group_list);
 
2974
  foreach my $g (@list) {
 
2975
    next if not $marked{$g};
 
2976
    Echonow("Saving $groups{$g}->{label} in \"$curr_dir\" ...");
 
2977
    $text = save_chi($sp, $g, $curr_dir);
 
2978
  };
 
2979
  Echo("Saved $text data to \"$curr_dir\" ...");
 
2980
};
2828
2981
 
2829
2982
 
2830
2983
sub set_defaults {
3009
3162
  ($kmin > $kmax) and (($kmin, $kmax) = ($kmax, $kmin));
3010
3163
  ##print "in set_range: $group $kmax\n";
3011
3164
 
 
3165
  ($pre2 = $pre1+5)  if ($pre2 < $pre1);
 
3166
  ($nor2 = $nor1+50) if ($nor2 < $nor1);
 
3167
  ($spl2 = $spl1+50) if ($spl2 < $spl1);
 
3168
  ($kmax = $kmin+5)  if ($kmax < $kmin);
3012
3169
  return ($pre1, $pre2, $nor1, $nor2, $spl1, $spl2, $kmin, $kmax);
3013
3170
};
3014
3171
 
3132
3289
  #local $Tk::FBox::a;
3133
3290
  #local $Tk::FBox::b;
3134
3291
  my $path = $current_data_dir || Cwd::cwd;
3135
 
  my $types = [["Xfit data", "xfit"], ['All', '*']];
 
3292
  my $types = [["Xfit data", ".xfit"], ['All', '*']];
3136
3293
  my $initial = join(".", $groups{$current}->{label}, "xfit");
3137
3294
  # spaces are common in filenames on Mac and Win, but not on un*x
3138
3295
  ($initial =~ s/\s+/_/g) unless ($is_windows or $is_darwin);