App-PLab
6 results

 view release on metacpan or  search on metacpan

bin/MorphometryI  view on Meta::CPAN 

	 push @hx, $x[$j];
	 push @hy, $y[$j];
	 $j++;
	 $j = 0 if $j >= $#x;
      }
      push @hx, $x[$j];
      push @hy, $y[$j];
      my ($hx,$hy) = make_contour_continuous([@hx], [@hy]);
      push @$hx, $hx->[0];
      push @$hy, $hy->[0];
      # flatten
      my @ret = ();
      while (@$hx) {
	 push @ret, shift(@$hx), shift(@$hy);
      }
      push @holes, [@ret];
   }
   return @holes;
}


# WIN

sub win_objectsetsmenuaction
{
   my ( $self, $id) = @_;
   my $menu = $self-> menu;
   return if $self-> {currentSet} == $id;
   $menu-> checked( 'lw'.($self-> {ini}-> {'LW'.$self-> {currentSet}}), 0);
   $menu-> checked( 'lw'.($self-> {ini}-> {'LW'.$id}), 1);
   $menu-> checked( $self-> {currentSet}, 0);
   $menu-> checked( $id, 1);
   my $iv = $self-> IV;
   $self-> iv_cancelmode( $iv);
   $self-> {currentSet} = $id;
   $self-> pt_newset();
   $iv-> {bone}-> backColor( $self-> {ini}-> {$self-> {setColors}->[ $self-> {currentSet}]});
   my $c = $menu-> text( $id);
   $c =~ s/\~//;
   $self-> sb_text("Object set:$c");
}

sub win_objectlwmenuaction
{
   my ( $self, $id) = @_;
   my $width = $id;
   $width =~ s/lw//;
   $width = 9 if $width > 9;
   $width = 1 if $width < 1;
   return if $width == $self-> {ini}-> {'LW'.$self-> {currentSet}};
   $self-> {ini}-> {'LW'.$self-> {currentSet}} = $width;
   $self-> sb_text("Line width set:$width");
}

sub win_inidefaults
{
   my $w = $_[0];
   my $calcopt = '';
   vec( $calcopt, 0, 32) = ocq::Files | ocq::Basics;
   return (
      $w-> SUPER::win_inidefaults,
      RecWindowPos     => '100 100',
      RecWindowVisible => 0,
      UFThreshold      => 40,
      BinThreshold     => 128,
      EdgeSize         => 3,
      MinArea          => 0,
      MaxArea          => 0,
      LW0              => 1,
      LW1              => 1,
      LW2              => 3,
      EqualBrightness  => 0,
      CalcBrightness   => 0,
      CalcConvex       => 0,
      CalcHoles        => 0,
      HolesPercent     => 5,
      NumberOfRotations=> 128,
      StatPath         => '.',
      CalcOptions      => $calcopt,
      FrameWidth       => 0,
      FrameColor       => 0,
      InvertImage      => 0,
   );
}


sub on_create
{
   my $self = $_[0];

   $self-> SUPER::on_create;

   my $w = $self;
   $w-> {dataExt} = 'xml';
   my $i = $w-> {ini};
   my $xref = [
      ['*0' => "~Features"   => \&win_objectsetsmenuaction],
      ['1'  => "~Background" => \&win_objectsetsmenuaction],
      ['2'  => "~Remove"     => \&win_objectsetsmenuaction],
      [],
      [ LineWidthIncrement =>  '~Increase line width' => sub {
         $_[0]-> win_objectlwmenuaction( 'lw'.($_[0]-> {ini}-> {'LW'.$_[0]-> {currentSet}} + 1));
      }],
      [ LineWidthDecrement => '~Decrease line width' => sub {
         $_[0]-> win_objectlwmenuaction( 'lw'.($_[0]-> {ini}-> {'LW'.$_[0]-> {currentSet}} - 1));
      }],
   ];
   $w-> {setColors}      = [ qw( Color_Features Color_Background Color_Remove)];
   $w-> menu-> insert( [[ "~Object sets" => $xref]], 'edit' , 6);
   $w-> {currentSet} = 0;
   $w-> pt_init();
   my $iv = $w-> IV;
   my $bone = $iv-> {bone};
   $bone-> backColor( $w-> {ini}-> {$w-> {setColors}->[$w-> {currentSet}]});
   $bone-> set( onMouseClick => sub {
      my ( $cs, $mx) = ( $w-> {currentSet} + 1, scalar @{$w-> {setColors}});
      $cs = 0 if $cs >= $mx;
      $w-> win_objectsetsmenuaction($cs);
      $_[0]-> clear_event;
   });
   my $scale = $::application-> uiScaling;
   $scale = 1 if $scale < 1;

   my $cck = $self-> ToolBar-> insert(
       SpeedButton =>
       name        => "Contours",
       origin      => [120 * $scale, 1],
       size        => [ 36 * $scale, 36 * $scale],
       image       => App::PLab::ImageAppGlyphs::icon( bga::drawprocesses),
       enabled     => 0,
       checkable   => 1,
       checked     => 1,
       hint        => 'Toggle contours tickmarks drawing',
       onClick     => sub { $self-> iv_togglemode( $iv)},
       glyphs      => 2,
       text        => "",
       selectable  => 0,
       transparent => 1,
       flat        => 1,
       borderWidth => 1,
       glyphs => 1,
   );

   $self-> ToolBar-> insert(
       SpeedButton =>
       name        => "CalcStatistics",
       origin      => [ 162 * $scale, 1],
       size        => [ 36 * $scale, 36 * $scale],
       image       => App::PLab::ImageAppGlyphs::icon( bga::calcstatistics),
       enabled     => 1,
       hint        => 'Calculate statistics',
       onClick     => sub { $self-> opt_statistics(); },
       text        => "",
       selectable  => 0,
       transparent => 1,
       flat        => 1,
       borderWidth => 1,
   );
   $iv-> {drawmode} = $cck-> checked ? 1 : undef;
   init_convex( $w->{ini}->{NumberOfRotations});
}

sub on_destroy
{
   my ($w,$i) = ($_[0],$_[0]->{ini});
   $i-> {RecWindowVisible} = defined $w-> {recWindow} ? 1 : 0;
   $w-> SUPER::on_destroy;
}

sub win_closeframe
{
   my $w = $_[0];
   $w-> SUPER::win_closeframe;
   $w-> pt_clear_all();
   $w-> rpt_clear();
}

sub win_framechanged
{
   my $w = $_[0];
   $w-> SUPER::win_framechanged;
   $w-> {mirrorImage} = undef;
   my $i = $w-> IV-> image;
   my $canApply = defined $i && $i-> type == im::Byte;
   $w-> menu-> EditToggleMode-> enabled( defined $i);
   $w-> menu-> EditApplyContours-> enabled( $canApply);
   $w-> menu-> EditValidate-> enabled( defined $i);
   $w-> menu-> EditImport-> enabled( defined $i);
   $w-> ToolBar-> Contours-> enabled( defined $i);
   if ( $w-> {recWindow}) {
      my $r = $w-> {recWindow};
      if ( defined $i) {
         my @sz = $i-> size;
         $r-> Min-> max( $sz[0] * $sz[1]);
         $r-> Max-> max( $sz[0] * $sz[1]);
         $r-> Edge-> max(int(($sz[0] < $sz[1] ? $sz[0] : $sz[1]) / 2));
      }
      $r-> ApplyBtn-> enabled( $canApply);
      $r-> RestoreBtn-> enabled( $canApply && defined $w-> {mirrorImage});
      $r-> Preview1-> enabled( $canApply);
      $r-> Preview2-> enabled( $canApply);
      $r-> Preview3-> enabled( $canApply);
   }
   $w-> pt_newset;
}

sub win_showrec
{
   my $w = $_[0];
   if ( $w-> {recWindow}) {
      $w-> {recWindow}-> bring_to_front;
      $w-> {recWindow}-> select;
      return;
   }
   $w-> {recWindow} = PropRollup-> create( owner => $w);
}

sub win_entersubplace
{
   my $w = $_[0];
   $w-> {savePointer} = $::application-> pointer;
   $::application-> pointer( cr::Wait);
   return defined $w-> {mirrorImage} ? $w-> {mirrorImage} : $w-> IV-> image;
}

sub win_leavesubplace
{
   my $w = $_[0];
   $::application-> pointer( $w-> {savePointer});
   $w-> {mirrorImage} = $w-> IV-> image unless defined $w-> {mirrorImage};
   $w-> IV-> image( $_[1]);
   $w-> {recWindow}-> RestoreBtn-> enabled( 1) if $w-> {recWindow};
   $w-> {savePointer} = undef;
}

sub win_restore
{
   my ( $w, $i) = @_;
   $w-> IV-> repaint, return unless defined $w-> {mirrorImage};
   $w-> IV-> image($w-> {mirrorImage});
   $w-> {mirrorImage} = undef;

bin/MorphometryI  view on Meta::CPAN 

      Handlers => {
         Start => sub {
            my ($obj, $el, %attrs) = @_;
            return if $state{finished_header};
            if ($el eq 'morphology_data') {
               return if $state{seen_header};
               $state{morphology_data} = {%attrs};
               $state{seen_header} = 1;
            } elsif ( $el eq 'object') {
               return unless $state{seen_header};
               return if $state{reading_object};
               $state{reading_object} = 1;
               for ( qw( type x y)) {
                  die "No tag:$_" unless defined $attrs{$_};
               }
               if ( $objsub) {
                  $_ = $objsub-> ( \%attrs, $n0, $n1);
                  return if $_ && $_ eq 'nocalc';
               }   
               
               if ( $attrs{type} eq $n0 || $attrs{type} eq $n1) {
                  my @xs = split( ' ', $attrs{x});
                  my @ys = split( ' ', $attrs{y});
                  return if scalar @xs != scalar @ys;
                  my @poly = ();
                  my $i;
                  for ( $i = 0; $i < scalar @xs; $i++) {
                     next if $xs[$i] < 0 || $ys[$i] < 0;
                     next if scalar( @is) && ( $xs[$i] >= $is[0] || $ys[$i] >= $is[1]);
                     next if scalar @poly and $xs[$i] == $poly[-2] and $ys[$i] == $poly[-1];
                     push( @poly, $xs[$i], $ys[$i]);
                  }
                  $i = $attrs{type} eq $n0 ? $state{feats} : $state{backs};
                  push ( @$i, \@poly) if scalar @poly > 3;
               } elsif ( $attrs{type} eq $n2) {
                  return if $attrs{x} < 0 || $attrs{y} < 0;
                  return if scalar( @is) && (  $attrs{x} >= $is[0] || $attrs{y} >= $is[1]);
                  push( @{$state{points}}, $attrs{x}, $attrs{y});
               }
            } else {
               $state{has_extras} = 1;
            }
         },
         End => sub {
            my ($obj, $el) = @_;
            $state{finished_header} = 1 if $el eq 'morphology_data';
            $state{reading_object}  = 0 if $el eq 'object';
         },
      });
   eval { parsefile $xml $xmlname; };
   if ($@) {
      $w-> win_xmlerror( $xmlname);
      return 0;
   }
   return \%state;
}   

sub win_newframe
{
   my $w = $_[0];
   $w-> SUPER::win_newframe;

   return unless defined $w-> {file};

   $w-> win_extwarn if defined $w-> {ini}-> {path} &&
      defined $w-> {oldPath} && $w-> {oldPath} ne $w-> {ini}-> {path};
   $w-> {oldPath} = $w-> {ini}-> {path};

   
   my $img = $w-> IV-> image;
   
   if ( $w-> {ini}-> {InvertImage}) {
      my ( $gray, $bpp) = ( $img-> type & im::GrayScale, $img-> type & im::BPP);
      if ( $gray && $bpp > 1) {
         $img-> resample( 0, 255, 255, 0);
      } elsif ( $bpp < 24) {
         $img-> palette([ map { 255 - $_} @{$img-> palette}]);
      } else {
         my $c = $img-> data;
         $c =~ s/(.)/chr(255-ord($1))/ge;
         $img-> data( $c); 
      }
   }

   my @is = $img-> size;
   my $i;
   my $lw = $w-> {ini}-> {FrameWidth};
   my $c  = $w-> {ini}-> {FrameColor} ? 0xffffff : 0;
   while ( $lw--) {
      for ( $i = $lw; $i < $is[0] - $lw; $i++) {
         $img-> pixel( $i, $lw, $c);
         $img-> pixel( $i, $is[1]-$lw-1, $c);
      }
      for ( $i = $lw; $i < $is[1] - $lw; $i++) {
         $img-> pixel( $lw, $i, $c);
         $img-> pixel( $is[0]-$lw-1, $i, $c);
      }
   }


   my $xmlname = $w-> win_extname( $w-> {file});
   return unless -f $xmlname;

   $w-> {file} =~ m{[/\\]([^/\\]*)$};
   my $iname = $1;


   my $state = $w-> win_xmlload( $xmlname);
   return unless $state;

   for ( qw( imagename imagewidth imageheight xcalib ycalib)) {
      next if defined $state->{morphology_data}->{$_};
      $@ = "Tag $_ not present into morphology_data section.\n";
      $w-> win_xmlerror( $xmlname);
   }   

   if ( !$w->{silence} && (
         ($state->{morphology_data}->{imagename}  ne $iname) ||
         ($state->{morphology_data}->{imagewidth}  != $is[0]) ||
         ($state->{morphology_data}->{imageheight} != $is[1])
      )) {

bin/MorphometryI  view on Meta::CPAN 

   breadth          = "$brd"
   convex_area      = "$carea"
   convex_width     = "$cwidth"
   convex_perimeter = "$perimeter"
   convex_formfactor= "$ff"
   convex_xcentroid = "$xcen"
   convex_ycentroid = "$ycen"
   convex_fxcentroid= "$fxcen"
   convex_fycentroid= "$fycen"
   convex_length_width= "$clw"
   spreading_index  = "$si"
PARAMS
                       if ( $w->{ini}->{CalcHoles}) {
                          my @holz = get_holes( $pp, $fnc);
                          my $h = '"';
                          for ( @holz) {
                             my ($harea) = ($w-> win_calcbasicparameters( @$_));
                             $h .= "$harea ";
                          }
                          $h =~ s/\s*$//; $h .= '"';
                          print F "   harea = $h\n";
                       }
                   }
                }
# End calc
             print F "/>\n\n";
          }
      }

      my $ww = $w-> {points};
      if ( defined $ww) {
         for ( $i = 0; $i < scalar @$ww; $i+=2) {
            print F <<POINTS;          
<object type = "point"
  x = "$$ww[$i]"
  y = "$$ww[$i+1]"
\/>
POINTS
         }
      }

      print F "</morphology_data>\n";
      close F;
      $w-> sb_text( 'saved ok.');
      $w-> modified( 0);
      $::application-> pointer( $waitPtr);
   } else {
      if ( $w->{silence}) {
         $w-> win_abortpacket;
         return 0;
      }
      return 0 if Prima::MsgBox::message(
         "Error saving file $xmlname. Ignore changes?", mb::YesNo|mb::Warning) == mb::No;
   }
   return 1;
}

sub win_newextras
{
   my $w = $_[0];
   $w-> SUPER::win_newextras;

   return unless defined $w-> {prevFile};
   my $num = $w->{cypherMask};
   my $xmlname;
   my ( $min, $max) = $w-> win_getseriesrange;
   $xmlname = $w-> win_formfilename( $min);
   $xmlname = $w-> win_extname( $xmlname);

   return unless -f $xmlname;

   my $state = $w-> win_xmlload( $xmlname);
   return unless $state;
   $w-> {extraPoints} = $state-> {points} if scalar @{$state-> {points}};
}

sub win_importextras
{
   my $w   = $_[0];
   $w-> iv_cancelmode( $w-> IV);
   my $d   = $w-> dlg_file(
      cwd         => 1,
      directory   => $w->{ini}->{path},
      filterIndex => 0,
      multiSelect => 0,
      filter    => [
         ['Data files' => '*.xml'],
         ['All files' => '*']
      ],
   );
   return 0 unless $d-> execute;
   my $state = $w-> win_xmlload( $d-> fileName);
   return unless $state;
   my $x = 0;
   if ( scalar @{$state->{feats}}) {
      $w-> {lineStorage}->[0] = [] unless defined $w->{lineStorage}->[0]; 
      $w-> {lwStorage}->[0]   = [] unless defined $w->{lwStorage}->[0]; 
      push( @{$w-> {lineStorage}->[0]}, @{$state->{feats}});
      push( @{$w-> {lwStorage}->[0]},   (1) x scalar @{$state->{feats}});
      $x |= 1;
   }
   if ( scalar @{$state->{backs}}) {
      $w-> {lineStorage}->[1] = [] unless defined $w->{lineStorage}->[0]; 
      $w-> {lwStorage}->[1]   = [] unless defined $w->{lwStorage}->[0]; 
      push( @{$w-> {lineStorage}->[1]}, @{$state->{backs}});
      push( @{$w-> {lwStorage}->[1]},   (1) x scalar @{$state->{backs}});
      $x |= 2;
   }
   return unless $x; # no contours to import
   $w-> pt_updatemenu;
   $w-> IV-> repaint;
   $w-> modified(1);
}   

sub win_closeextras
{
   my $w = $_[0];
   $w-> SUPER::win_closeextras;
   $w-> rptex_clear();
}

sub win_extraschanged
{
   my $w = $_[0];
   $w-> SUPER::win_extraschanged;
   $w-> menu-> EditOptCalib-> enabled( defined $w-> {nextFile} || defined $w-> {prevFile});
}


# WIN_END
# OPT

sub opt_colors
{
   return {
       Features    => [ cl::LightGreen,    'Features'],
       Background  => [ cl::Yellow,        'Background'], 
       Remove      => [ cl::White,         'Remove'], 
       Points      => [ cl::LightRed,      'Points'],  
   },
}

sub opt_colormount
{
   my $w = $_[0];
   $w-> IV-> {bone}-> backColor( $w-> {ini}-> {$w-> {setColors}->[$w-> {currentSet}]});
}

sub opt_keys
{
   return {
      %{$_[0]-> SUPER::opt_keys()},
      EditImport    => [ kb::NoKey , "Import another contours into document"],
      EditOptCalib  => [ kb::NoKey , "Recalculate series"],
      EditCalcStats => [ '@C'      , "Calculate and display statistics"],
      Undo1         => [ kb::Backspace , "Undo drawing"],
      Undo2         => [ km::Alt|kb::Backspace , "Undo group of lines"],
      Undo3         => [ '@U'          , "Show undo dialog"],
      EditInvertImage => [ kb::NoKey   , "Invert image"],
      EditClearAll  => [ kb::NoKey     , "Clear all drawings"],
      EditRemovePoints   => [ kb::NoKey     , "Remove all points"],
      EditToggleMode     => [ 'F11'     , "Toggle drawings/points mode"],
      EditValidate       => [ km::Ctrl|kb::Enter , "Validate contours"], 
      EditRecSetup       => [ kb::NoKey  , "Display recognition setup dialog"],
      EditApplyContours  => [ km::Alt|kb::Enter , "Apply contours to document"],
      EditHack           => [ kb::NoKey         , "Outline convex hull of current drawing"],
      HelpAbout        => [ kb::NoKey,      'Standard about box'],
      HelpPlabApps     => [ kb::NoKey,      'Online PlabApps overview'],
      HelpContents     => [ kb::NoKey,      'Online Morphometry I overview'],
      LineWidthIncrement => [ '@+',   'Increment line width for current object'],
      LineWidthDecrement => [ '@-',   'Decrement line width for current object'],
   };
};

sub opt_changecalib
{
   my $w = $_[0];

   Prima::MsgBox::message( "No series to convert"), return if ( !defined $w-> {nextFile} && !defined $w-> {prevFile});

   my $num = $w-> {cypherMask};
   my ( $fn, $tn) = $w-> win_getseriesrange;

   return if Prima::MsgBox::message( "This will recalculate series ".
      $w-> {fileBeg}.('X' x $num).$w-> {fileEnd}." [$fn-$tn] . Proceed?",
      mb::OKCancel|mb::Information) != mb::OK;

   my $fnsave = $w->{fileNum};
   my $f;
   my $ok = 1;

   $w->{silence} = 1;
   $w->{packetAborted} = 0;

   my $userAborted = 0;

   my $statwin = $w-> insert( Dialog =>
      centered    => 1,
      text        => 'Processing',
      size        => [ 300, 60],
      onKeyDown   => sub {
         my ( $self, $code, $key, $mod) = @_;
         if ( $key == kb::Esc &&
            ( Prima::MsgBox::message("Abort process?", mb::OKCancel|mb::Warning) == mb::OK)) {
            $userAborted = 1;
            $_[0]-> text('Cancelling');
         }
      },
      onClose     => sub {
         $_[0]-> clear_event;
         return if Prima::MsgBox::message("Abort process?", mb::OKCancel|mb::Warning) != mb::OK;
         $userAborted = 1;

bin/MorphometryI  view on Meta::CPAN 

      $dir = '' unless -d $dir;
      my $d = Prima::SaveDialog-> create(
         owner   => $dlg,
         filter  => [
            ['Text files' => '*.txt'],
            ['All files' => '*']
         ],
         directory => $dir,
      );
      my $res = $d-> execute;
      if ( $res) {
         open F, '>'.$d-> fileName;
         print F $$textRef;
         close F;
      };
      $w-> {ini}-> {StatPath} = $d-> directory;
      $d-> destroy;
   }

   my $dlg = Prima::Window-> create(
      size => [ 520, 430],
      text => 'Statistic results',
      widgetClass => wc::Dialog,
      centered => 1,
      menuItems   => [
         [ '~Export' => [
            ["~Summary..." => "F2" => kb::F2 => sub { esummary( $_[0], \$meta2, $w)} ],
            ["~Experiment data..." => "Ctrl+F2" => km::Ctrl|kb::F2 => sub { esummary( $_[0], \$meta1, $w)} ],
         ]],
         [ 'Copy' => "" => kb::NoKey => sub { $::application-> Clipboard-> store( 'Text', $texts);}],
      ],
   );

   $dlg-> insert( Edit =>
      origin   => [ 1, 1],
      size     => [ $dlg-> width - 2, $dlg-> height - 2],
      text     => $texts,
      growMode => gm::Client,
      hScroll  => 1,
      vScroll  => 1,
      readOnly => 1,
      font     => { pitch => fp::Fixed},
      wordWrap => 0,
      syntaxHilite => 1,
      hiliteNumbers     => undef,
      hiliteQStrings    => undef,
      hiliteQQStrings   => undef,
      hiliteIDs         => undef,
      hiliteChars       => undef,
      hiliteREs         => [ '(N\/A)', cl::Red,
          '(([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?\*)', cl::Red],
   );

   $dlg-> select;
}


sub opt_propcreate
{
   my ( $w, $dlg, $nb, $nbpages) = @_;
   $w-> SUPER::opt_propcreate( $dlg, $nb, $nbpages);
   $nb-> tabs( @{$nb-> tabs}, 'Calculations', 'Frame');
   $nb-> insert_to_page( $nb-> pageCount - 2,
      [ Label =>
        text     => 'By default, only the area, the perimeter, the formfactor and centroid locations are calculated,though the program is perfectly capable of calculating all other parameters.  The reason for disabling the rest is that it normally ta...
        wordWrap => 1,
        designScale => [ $nbpages-> font-> width, $nbpages-> font-> height],
        valignment => ta::Top,
        name       => 'TopText',
    ],[ CheckBox =>
        origin => [ 5, 185],
        name => 'CalcBrightness',
        size => [ 300, 27],
        text => 'Calculate ~brightness',
        onCheck => sub {
           $nbpages-> EqualBrightness-> set(
              checked => ($_[0]-> checked ? $nbpages-> EqualBrightness-> checked : 0),
              enabled => $_[0]-> checked,
           );
        },   
    ],[ CheckBox =>
        origin => [ 5, 155],
        name => 'EqualBrightness',
        size => [ 300, 27],
        text => 'E~qualize brightness',
    ],[ CheckBox =>
        origin => [ 5, 125],
        name => 'CalcConvex',
        size => [ 248, 27],
        text => 'Convex ~hull derived parameters',
    ],[ Label =>
        origin => [ 5, 100],
        height => 20,
        name => 'SigRot',
        text => '~Number of rotations',
    ],[ SpinEdit =>
        origin => [ 5, 80],
        name => 'NumberOfRotations',
        size => [ 100, 20],
        min  => 1,
        max  => 256,
    ],[ CheckBox =>
        origin => [ 5, 50],
        name => 'CalcHoles',
        size => [ 248, 27],
        text => '~Process index / domain',
        onCheck => sub {
           $nbpages-> CalcConvex-> set(
              checked => ($_[0]-> checked ? 1 : $nbpages-> CalcConvex-> checked),
              enabled => !$_[0]-> checked,
           );
        },
    ],[ Label =>
        origin => [ 5, 25],
        name => 'SigPce',
        height => 20,
        text => 'Significance level for holes, %',
    ],[ SpinEdit =>
        origin => [ 5, 5],
        name => 'HolesPercent',
        size => [ 100, 20],

bin/MorphometryI  view on Meta::CPAN 

   );
   $fcnt[2]-> focusLink( $fcnt[1]);

   $fcnt[0]-> insert( [ Radio => 
      origin => [ 9, 5],
      size   => [ 89, 28],
      name   => 'FT_Black',
      text   => 'B~lack',
   ], [ Radio => 
      origin => [ 102, 5],
      size   => [ 89, 28],
      name   => 'FT_White',
      text   => 'W~hite',
   ]);

   my $s1 = $nb-> insert_to_page( 1, Slider =>
       origin => [ 100, 10],
       size   => [ 270, 56],
       min    => 1,
       max    => 10,
       name   => 'LineWidth',
       scheme => ss::Gauge,
       snap   => 1,
       increment => 1,
       step      => 1,
       onChange  => sub {
          unless ( $nbpages-> {deprecate}) {
             my $widths = $dlg-> {page2}-> {widths};
             $$widths[ $nbpages-> NameSel-> focusedItem] = $_[0]-> value;
          }
       },
   );
   my $s2 = $nb-> insert_to_page( 1, Label =>
       origin => [ 10, 10],
       size   => [ 90, 56],
       text   => "Line ~width\n[Alt + - and 1-9]",
       focusLink  => $s1,
       autoWidth  => 0,
       valignment => ta::Center,
       wordWrap   => 1,
   );
   my $delta = $nbpages-> LineWidth-> top;
   for ( $nbpages-> widgets_from_page(1)) {
      next if $_ == $s1 || $_ == $s2;
      $_-> bottom( $_-> bottom + $delta);
   }

   my $namesel = $nbpages-> NameSel;
   $namesel-> set( onChange => sub {
      $nbpages-> {deprecate} = 1;
      $nbpages-> LineWidth-> value( $dlg-> {page2}-> {widths}-> [ $_[0]-> focusedItem]);
      $nbpages-> {deprecate} = undef;
   });
}

my %widcolors = ( Features => 1, Background => 1, Remove => 1);

sub opt_proppush
{
   my ( $w, $dlg, $nb, $nbpages) = @_;
   $w-> SUPER::opt_proppush( $dlg, $nb, $nbpages);
   my $nbc = $nbpages-> pageIndex;
   $nbpages-> pageIndex(3);
   for ( qw( CalcBrightness EqualBrightness CalcConvex CalcHoles)) {
      $nbpages->bring($_)->checked( $w->{ini}->{$_});
   }   
   $nbpages-> CalcBrightness-> notify(q(Check)); # force dependent disablements
   $nbpages-> CalcHoles->      notify(q(Check)); 
   for ( qw( HolesPercent NumberOfRotations)) {
      $nbpages->bring($_)->value( $w->{ini}->{$_});
   }   
   $nbpages-> pageIndex( $nbc);
   $dlg->{page3}->{NumberOfRotations} = $w->{ini}->{NumberOfRotations};
   my $i = 0;
   my %colors = %{$w-> opt_colors};
   my %ids    = map { ( $_ , $i++ ) } keys %colors;
   my @widths = (1) x scalar keys %colors;
   $widths[$ids{Features}]   = $w-> {ini}-> {LW0};
   $widths[$ids{Background}] = $w-> {ini}-> {LW1};
   $widths[$ids{Remove}]     = $w-> {ini}-> {LW2};
   $dlg-> {page2}-> {widths} = \@widths;
   $nbpages-> LineWidth-> value( $widths[ $nbpages-> NameSel-> focusedItem]);
   $nbpages-> FrameWidth-> value( $w-> {ini}-> {FrameWidth});
   $nbpages-> FrameColor-> index( $w-> {ini}-> {FrameColor} ? 1 : 0);
}

sub opt_proppop
{
   my ( $w, $dlg, $nb, $nbpages, $mr) = @_;
   $w-> SUPER::opt_proppop( $dlg, $nb, $nbpages, $mr);
   if ( $mr) {
      for ( qw( EqualBrightness CalcBrightness CalcConvex CalcHoles)) {
         $w->{ini}->{$_} = $nbpages-> bring($_)-> checked;
      }   
      for ( qw( HolesPercent NumberOfRotations)) {
         $w->{ini}->{$_} = $nbpages-> bring($_)-> value;
      }   
      my $i = 0;
      my %colors = %{$w-> opt_colors}; 
      my %ids    = map { ( $_ , $i++ ) } keys %colors;
      $w-> {ini}-> {LW0} = $dlg-> {page2}-> {widths}-> [$ids{Features}];
      $w-> {ini}-> {LW1} = $dlg-> {page2}-> {widths}-> [$ids{Background}];
      $w-> {ini}-> {LW2} = $dlg-> {page2}-> {widths}-> [$ids{Remove}];
      init_convex( $w->{ini}->{NumberOfRotations}) if
         $w->{ini}->{NumberOfRotations} != $dlg->{page3}->{NumberOfRotations};
      my @v = ( $nbpages-> FrameWidth-> value, $nbpages-> FrameColor-> index ? 1 : 0);
      if ( $v[0] != $w-> {ini}-> {FrameWidth} || $v[1] != $w-> {ini}-> {FrameColor}) {
         $w-> {ini}-> {FrameWidth}  = $v[0]; 
         $w-> {ini}-> {FrameColor}  = $v[1];
         $w-> win_loadfile( $w-> {file});
      }
   }
}


# OPT_END
# PT

sub pt_lines
{
   return $_[0]-> {lineStorage}->[$_[0]->{currentSet}];
}

sub pt_lines_ptr
{
   return \$_[0]-> {lineStorage}->[$_[0]->{currentSet}];
}

sub pt_lw
{
   return $_[0]-> {lwStorage}->[$_[0]->{currentSet}];
}

sub pt_lw_ptr
{
   return \$_[0]-> {lwStorage}->[$_[0]->{currentSet}];
}



sub pt_init
{
   $_[0]-> pt_clear_all();
}

sub pt_undo1
{
   my $w  = $_[0];
   $w-> iv_cancelmode( $w-> IV);
   return unless defined $w-> pt_lines;

bin/MorphometryI  view on Meta::CPAN 

sub pt_clear
{
   my $w = $_[0];
   ${$w-> pt_lines_ptr()} = undef;
   ${$w-> pt_lw_ptr()} = undef;
   for ( qw( Undo1 Undo2 Undo3)) {
      $w-> menu-> action( $_, sub{});
      $w-> menu-> disable( $_);
   }
}

sub pt_clear_all
{
   my $w = $_[0];
   $w-> pt_clear;
   my $sc = scalar @{$w->{setColors}};
   $w-> {lineStorage} = [];
   $w-> {lwStorage} = [];
   while ( $sc--) {
      push( @{$w-> {lineStorage}}, undef);
      push( @{$w-> {lwStorage}}, undef);
   }
}

# PT_END
# RPT

sub rpt_toggle
{
   my ( $w, $x, $y) = @_;
   $w-> {points} = [] unless defined $w-> {points};
   $w = $w->{points};
   my $i = 0;
   my $found = undef;
   for ( $i = 0; $i < scalar @$w; $i+=2) {
      my ( $ax, $ay) = @$w[$i,$i+1];
      $found = $i, last if abs( $ax - $x) < $App::PLab::ImageAppWindow::pointClickTolerance &&
       abs( $ay - $y) < $App::PLab::ImageAppWindow::pointClickTolerance;
   }
   defined $found ? splice( @$w, $i, 2) : push( @$w, $x, $y);
   return !defined $found;
}

sub rpt_clear
{
   $_[0]-> {points} = undef;
}

sub rptex_clear
{
   $_[0]-> {extraPoints} = undef;
}

# RPT_END
# IV

sub IV_MouseDown
{
   my ( $w, $self, $btn, $mod, $x, $y) = @_;

   $w-> SUPER::IV_MouseDown( $self, $btn, $mod, $x, $y);
   return unless $self-> eventFlag;

   $self-> clear_event, return if $btn != mb::Left;

   if ($self->{transaction}) {
      if ( $self->{transaction} == 2) {
         my ( $ax, $ay) = $self-> screen2point( $x, $y);
         $self-> {transaction} = 1;
         $w-> pt_add( $ax, $ay);
         $w-> sb_text( "Freehand: $ax $ay");
         $w-> modified( 1);
         $self-> repaint;
      }
      $self-> clear_event;
      return;
   }

   unless ( $self->{drawmode}) {
      my ( $ax, $ay) = $self-> screen2point( $x, $y);
      if ( $w-> rpt_toggle( $ax, $ay)) {
         $self-> begin_paint;
         $self-> color( $w->{pointColor});
         my $p = ( 6 * $self-> zoom < 1) ? 1 : ( 6 * $self-> zoom);
         $self-> fill_ellipse( $x, $y, $p, $p);
         $self-> end_paint;
         $w-> sb_text( "New reference point: $ax $ay");
      } else {
         my $p = ( 32 * $self-> zoom < 1) ? 1 : ( 32 * $self-> zoom);
         $self-> invalidate_rect( $x - $p, $y - $p, $x + $p, $y + $p);
         $w-> sb_text( "Reference point deleted: $ax $ay");
      }
      $w-> modified( 1);
      $self-> clear_event;
      return;
   }

   {
      #starting freehand session
      $w-> iv_entermode( $self, 1);
      $w-> pt_start;
      my ( $ax, $ay) = $self-> screen2point( $x, $y);
      $w-> pt_add( $ax, $ay);
      $w-> modified( 1);
      $w-> sb_text( "Freehand: $ax $ay");
   }
   $self-> clear_event;
}

sub IV_MouseClick
{
   my ( $w, $self, $btn, $mod, $x, $y, $dbl) = @_;

   if ( $btn == mb::Right and ( $self-> {transaction})) {
      $w-> iv_cancelmode( $self) if $self-> {transaction} == 2;
      $self-> clear_event;
      return;
   }
}

sub IV_MouseUp
{
   my ( $w, $self, $btn, $mod, $x, $y) = @_;
   return unless $self->{transaction};
   $w-> SUPER::IV_MouseUp( $self, $btn, $mod, $x, $y);
   return unless $self-> eventFlag;
   if ( $btn == mb::Left and $self-> {transaction} == 1) {
      $self-> {transaction} = 2;
      $self-> {xors} = undef;
      $w-> sb_text("Lineplot:");
      $self-> clear_event;
   }
}

sub IV_MouseMove
{
   my ( $w, $self, $mod, $x, $y) = @_;
   unless ( $self->{transaction}) {
      if (( $mod & km::Shift) && defined $self-> image) {
         my $i = $self-> image;
         my $pix = $i-> pixel( $self-> screen2point( $x, $y));
         $w-> sb_text((( $i-> type & im::BPP) > 8) ?
            sprintf("%02x %02x %02x", ($pix>>16)&0xFF, ($pix>>8)&0xFF, $pix&0xFF) :
            $pix
         ) if $pix != cl::Invalid;
      }
   }
   $w-> SUPER::IV_MouseMove( $self, $mod, $x, $y);
   return unless $self-> eventFlag && $self-> {transaction};
   if ( $self-> {transaction} == 1) {
      my ( $x1, $y1) = $self-> point2screen( @{$w-> pt_lines->[-1]}[-2,-1]);
      $w-> pt_add( $self-> screen2point( $x, $y));
      $self-> begin_paint;
      $self-> color( $w-> {ini}-> {$w->{setColors}->[$w->{currentSet}]});
      $self-> lineWidth( $self-> zoom * $w-> {ini}-> {'LW'.$w->{currentSet}});
      $self-> line( $x, $y, $x1, $y1);
      $self-> end_paint;
      $w-> sb_text("Freehand: $x1 $y1");
   } elsif ( $self-> {transaction} == 2) {
      my ( $ax, $ay) = $self-> point2screen( @{$w-> pt_lines->[-1]}[-2,-1]);
      $self-> begin_paint;
      $self-> color( cl::White);
      $self-> rop( rop::XorPut);
      $self-> linePattern( lp::Dot);
      $self-> line( $ax, $ay, @{$self->{xors}}) if defined $self->{xors};
      $self-> line( $ax, $ay, $x, $y);
      $self-> {xors} = [$x, $y];
      $self-> end_paint;
      my ( $x1, $y1) = $self-> screen2point( $x, $y);
      $w-> sb_text("Lineplot: $x1 $y1");
   }
}

sub IV_Paint
{
   my ( $w, $self, $canvas) = @_;
   $self-> on_paint( $canvas);
   my $wl = $w-> {lineStorage};
   $canvas-> translate( $self-> point2screen( 0, 0));
   my $z = $self-> zoom;
   my $p = ( 6 * $z < 1) ? 1 : ( 6 * $z);
   if ( defined $wl) {
      my $i;
      for ( $i = 0; $i < scalar @{$w->{setColors}}; $i++) {
         my $wwl  = $w->{lineStorage}->[$i];
         my $wwlw = $w->{lwStorage}->[$i];
         next unless defined $wwl;
         $canvas-> color( $w-> {ini}-> {$w->{setColors}->[$i]});
         my $j;
         my $lastLW = 0;
         for ( $j = 0; $j < @$wwl; $j++) {
            my @x = map { $_ * $z } @{$$wwl[$j]};
            $canvas-> lineWidth( $$wwlw[$j] * $z), $lastLW = $$wwlw[$j] if $lastLW != $$wwlw[$j];
            $canvas-> polyline( \@x);
         }
      }
   }
   $wl = $w-> {points};
   if ( defined $wl) {
      my $i;
      $canvas-> color( $w->{pointColor});
      for ( $i = 0; $i < scalar @$wl; $i+=2) {
         my ( $x, $y) = @$wl[ $i, $i+1];
         $canvas-> fill_ellipse( $x * $z, $y * $z, $p, $p);
      }
   }
   $wl = $w-> {extraPoints};
   if ( defined $wl) {
      my $i;
      $canvas-> color( $w->{pointColor});
      $canvas-> lineWidth( $z);
      for ( $i = 0; $i < scalar @$wl; $i+=2) {
         my ( $x, $y) = @$wl[ $i, $i+1];
         $canvas-> line( $x * $z - $p, $y * $z - $p, $x * $z + $p, $y * $z + $p);
         $canvas-> line( $x * $z + $p, $y * $z - $p, $x * $z - $p, $y * $z + $p);
      }
   }
}

sub iv_cancelmode
{
   my ( $w, $self) = @_;
   my $t = $self->{transaction};
   $w-> SUPER::iv_cancelmode( $self);
   $w-> pt_close() if $t;
}

sub iv_togglemode
{
   my ( $w, $self) = @_;
   return if !$ImageApp::testing and !defined $self-> image;
   $w-> iv_cancelmode( $self);
   $self-> {drawmode} = defined $self-> {drawmode} ? undef : 1;
   $w-> ToolBar-> Contours-> checked( defined $self-> {drawmode});
   $w-> sb_text( defined $self-> {drawmode} ? "Drawing mode on - Esc or right button to cancel" : "Reference point mode on");
}

# IV_END

package PropRollup;
use vars qw(@ISA);
@ISA = qw(Prima::Dialog);

sub profile_default
{
   my $def = $_[ 0]-> SUPER::profile_default;
   my %prf = (
       borderIcons => bi::SystemMenu | bi::TitleBar,
       width => 207,
       height => 306,
       sizeDontCare => 0,

       text => 'Parameters',
       visible => 0,
   );
   @$def{keys %prf} = values %prf;
   return $def;
}

sub init
{
   my $self = shift;
   my %profile = $self-> SUPER::init(@_);

   my $image = Prima::Icon->create( width=>16, height=>16, type => im::bpp1,
     palette => [ 0,0,0,0,0,0],
     data =>
     "\x01\x00\x00\x00A\x08\x00\x00\!\x10\x00\x00\x10 \x00\x00\x07\xc0\x00\x00".
     "\x080\x00\x001\x88\x00\x00C\xc0\x00\x00\x03\xc4\x00\x00\!\x88\x00\x00".
     "\x18p\x00\x00\x07\x80\x00\x00\x10\x10\x00\x00\!\x08\x00\x00A\x04\x00\x00".
     "\x01\x00\x00\x00".
   '');

   my $w = $self-> owner;

   my $i = $w-> IV-> image;
   my @sz = defined $i ? $i-> size : (0,0);
   my $canApply = defined $i && $i-> type == im::Byte;

   $self-> insert(
     [ Label =>
       origin => [ 5, 280],
       name => 'UF',
       size => [ 148, 20],
       text => 'Union ~find threshold',
   ],[ SpinEdit =>
       origin => [ 5, 255],
       name => 'Union',
       size => [ 148, 20],
       min => 1,
       value => $w-> {ini}-> {UFThreshold},
       max => 255,
   ],[ Label =>
       origin => [ 5, 230],
       name => 'BT',
       size => [ 148, 20],
       text => '~Binary threshold',
   ],[ SpinEdit =>
       origin => [ 5, 205],
       name => 'Binary',
       size => [ 148, 20],
       min => 0,
       value => $w-> {ini}-> {BinThreshold},
       max => 255,
   ],[ Label =>
       origin => [ 5, 180],
       name => 'ES',
       size => [ 148, 20],
       text => '~Edge size',
   ],[ SpinEdit =>
       origin => [ 5, 155],
       name => 'Edge',
       size => [ 148, 20],
       value => $w-> {ini}-> {EdgeSize},
       min  => 1,
       max  => defined $i ? ( int(($sz[0] < $sz[1] ? $sz[0] : $sz[1]) / 2)) : 16383,
   ],[ Label =>
       origin => [ 5, 130],
       name => 'MIN',
       size => [ 148, 20],
       text => 'Mi~n area',
   ],[ SpinEdit =>
       origin => [ 5, 105],

bin/MorphometryI  view on Meta::CPAN 

          $w-> win_leavesubplace(
             Prima::IPA::Point::threshold(
                $im,
                minvalue => 0,
                maxvalue => $self-> Binary-> value,
          ));
       },
   ],[ SpeedButton =>
       origin => [ 164, 54],
       name => 'Preview3',
       size => [ 36, 120],
       image => $image,
       enabled => $canApply,
       hint    => 'Previews all methods',
       onClick => sub {
          my $im = Prima::IPA::Local::unionFind(
             $w-> win_entersubplace,
             method    => 'ave',
             threshold => $self-> Union-> value);
          $im = Prima::IPA::Point::threshold(
             $im,
             minvalue => 0,
             maxvalue => $self-> Binary-> value);
          $im = Prima::IPA::Global::fill_holes( $im,
             edgeSize => $self-> Edge-> value,
          );
          $im = Prima::IPA::Global::area_filter( $im,
             edgeSize => $self-> Edge-> value,
             minArea  => $self-> Min-> value,
             maxArea  => $self-> Max-> value,
          );
          $w-> win_leavesubplace( $im);
       },
   ],);
   my @p = split( ' ', $w->{ini}->{RecWindowPos});
   my @as = $::application-> size;
   my @ss = $self-> size;
   for ( 0..1) {
      $p[$_] = 100 unless defined $p[$_];
      $p[$_] = 0 if $p[$_] < -$ss[$_] + 100;
      $p[$_] = $as[$_] - $ss[$_] - 30 if $p[$_] > $as[$_] - $ss[$_] - 30;
   }

   $self-> origin( @p);
   $self-> visible(1);
   return %profile;
}

sub cleanup
{
   my $self = $_[0];
   my $w = $self-> owner;
   $w-> {recWindow} = undef;
   my $i = $w-> {ini};
   $i-> {RecWindowPos}  = join( ' ', $self-> origin);
   $i-> {UFThreshold} = $self-> Union-> value;
   $i-> {BinThreshold} = $self-> Binary-> value;
   $i-> {EdgeSize} = $self-> Edge-> value;
   $i-> {MinArea}  = $self-> Min-> value;
   $i-> {MaxArea}  = $self-> Max-> value;
   $self-> SUPER::cleanup();
}

package Run;

my $wfil = App::PLab::ImageAppWindow::winmenu_file();
splice( @{$$wfil[1]}, -2, 0,
   [],
   [ EditImport      => "~Import contours" => q(win_importextras)],
   [ '-EditOptCalib' => "~Recalculate series"  => q(opt_changecalib)],
   [ EditCalcStats   => "~Calculate statistics"  => q(opt_statistics)],
);

my $wedt = App::PLab::ImageAppWindow::winmenu_edit();
splice( @{$$wedt[2]}, 0, 0,
   [ '-Undo1' => "~Undo drawing" => "BkSp" => kb::Backspace , sub {},],
   [ '-Undo2' => "~Group undo" => "Alt+BkSp" => km::Alt|kb::Backspace , sub {},],
   [ '-Undo3' => "Undo ~dialog" => "Alt+U" => '@U' => sub {},],
   [ EditClearAll => "Clear all ~drawings"  => sub {
      $_[0]-> iv_cancelmode( $_[0]-> IV);
      $_[0]-> pt_clear;
      $_[0]-> IV-> repaint;
      $_[0]-> modified( 1);
   }, ],
   [ EditRemovePoints => "Clear all ~points"    => sub {
      $_[0]-> rpt_clear;
      $_[0]-> IV-> repaint;
      $_[0]-> modified( 1);
   }, ],
   [],
   [ '-EditToggleMode' => "~Toggle points <-> drawings" => 'F11'=>'F11' => sub { $_[0]-> iv_cancelmode( $_[0]-> IV); $_[0]-> iv_togglemode( $_[0]-> IV)}],
   [],
   [ 'EditInvertImage' => '~Invert image' => sub { $_[0]-> win_set_negative( $_[0]-> {ini}-> {InvertImage} ? 0 : 1); } ],
   [ '-EditValidate' => "~Validate contours" => 'Ctrl+Enter'=> km::Ctrl|kb::Enter ,
       sub { $_[0]-> win_validate(0) }],
   [ EditRecSetup => "Recognition ~setup"  => sub { $_[0]-> win_showrec; }, ],
   [ '-EditApplyContours' => "~Apply contours" => 'Alt+Enter'=> km::Alt|kb::Enter , q(win_applycontours)],
   [],
   [ 'EditHack' => "~Outline convex ~hull" => q(win_outline_convex_hull)],
);

my $w = MorphoWindow-> create(
   visible   => 0,
   menuItems => [
      $wfil,
      $wedt,
      App::PLab::ImageAppWindow::winmenu_view(),
      [],["~Help" => [
         [ HelpAbout =>  "~About" => sub {Prima::MsgBox::message("PLab application series, Morphometry I, version $App::PLab::VERSION", mb::OK|mb::Information)}],
         [ HelpPlabApps => "~PLab Apps" => sub { $_[0]-> open_help(); }],
         [ HelpContents => "~Contents" => sub { $_[0]-> open_help("MorphometryI"); }],
      ]],
   ],
   accelItems => [
      ( map {[ "lw$_" => $_ => "Alt+$_" => "\@$_" => q(win_objectlwmenuaction)]} 1..9),
   ],
);
$w-> IV-> delegations(['MouseClick', 'Paint']);

$w-> sb_text("Started OK");
$w-> visible(1);



( run in 0.903 second using v1.01-cache-2.11-cpan-8f98c5d2c55 )