view release on metacpan or  search on metacpan

bin/MorphometryI  view on Meta::CPAN

   $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;
   $w-> {recWindow}-> RestoreBtn-> enabled( 0) if $w-> {recWindow};
}

sub win_syncrecdata
{
   my $w = $_[0];
   return unless $w-> {recWindow};
   my $r = $w-> {recWindow};
   my $i = $w-> {ini};
   $i-> {UFThreshold}  = $r-> Union-> value;
   $i-> {BinThreshold} = $r-> Binary-> value;
   $i-> {EdgeSize}     = $r-> Edge-> value;
   $i-> {MinArea}      = $r-> Min-> value;
   $i-> {MaxArea}      = $r-> Max-> value;
}

sub win_validate
{
   my ( $w, $silent) = @_;
   my ( $min, $max, $edge);
   my ( $umax, $umin, $j, $iptr);

   return unless defined $w-> {file};

   $w-> win_syncrecdata;
   $umin = $w-> {ini}-> {MinArea};
   $umax = $w-> {ini}-> {MaxArea};

   unless ( $silent) {
      $w-> iv_cancelmode( $w-> IV);
      $iptr = $::application-> pointer;
      $::application-> pointer( cr::Wait);
   }

   my @is = $w-> IV-> image-> size;

   for ( $j = 0; $j < 2; $j++) {

      if ( $j == 0) {
         $min = $umin;
         $max = $umax;
      } else {
         $min = 0;
         $max = $is[0] * $is[1];
      }

      $edge = $w-> {ini}-> {EdgeSize};

      my $i = Prima::Image-> create(
         width        => $is[0],
         height       => $is[1],
         type         => im::BW,
         preserveType => 1,
      );

      $i-> begin_paint;
      $i-> color( cl::Black);
      $i-> bar(0,0,@is);
      $i-> color( cl::White);
      my $k;
      my $lastLW = 0;

      if ( defined $w-> {lineStorage}) {
         my $wwl  = $w->{lineStorage}->[$j];
         my $wwlw = $w->{lwStorage}  ->[$j];
         next unless defined $wwl;
         for ( $k = 0; $k < @$wwl; $k++) {
            $i-> lineWidth( $$wwlw[$k]), $lastLW = $$wwlw[$k] if $lastLW != $$wwlw[$k];
            $i-> polyline( $$wwl[ $k]);
         }
      }
      $i-> end_paint;
      $i-> type( im::Byte);

      $i = Prima::IPA::Global::fill_holes( $i,
         edgeSize => $edge,
      );

      if ( defined $w-> {lineStorage} && defined $w->{lineStorage}->[ 2]) {
         $i-> begin_paint;
         $i-> color( cl::Black);
         my $wwl  = $w->{lineStorage}->[ 2];
         my $wwlw = $w->{lwStorage}->[ 2];
         for ( $k = 0; $k < @$wwl; $k++) {
            $i-> lineWidth( $$wwlw[$k]), $lastLW = $$wwlw[$k] if $lastLW != $$wwlw[$k];
            $i-> polyline( $$wwl[ $k]);
         }
         $i-> end_paint;
         $i-> type( im::Byte);

         $i = Prima::IPA::Global::fill_holes( $i,
            edgeSize => $edge,
         );
      }

      $i = Prima::IPA::Global::area_filter( $i,
         edgeSize => $edge,
         minArea  => $min,
         maxArea  => $max,
      );

      my $cc = [ grep { ($w->win_calcbasicparameters(@$_))[0] }
                    @{Prima::IPA::Global::identify_contours( $i, edgeSize => $edge)} ];
      $cc = undef unless scalar @$cc;
      $w-> {lineStorage}-> [ $j] = $cc;
      $w-> {lwStorage}-> [ $j] = defined $cc ? [ (1) x scalar @$cc] : undef;
   }
   $w-> {lineStorage}-> [ 2] = undef;
   $w-> {lwStorage}-> [ 2] = undef;

   unless ( $silent) {
      $w-> modified( 1);
      $w-> pt_newset;
      $w-> IV-> repaint;
      $::application-> pointer( $iptr);
   }
}

sub win_outline_convex_hull
{
   my ($w) = @_;

   init_convex( $w->{ini}->{NumberOfRotations});
   my $ptr = $w-> {lineStorage}->[0];
   return unless defined $ptr;
   my @bubik = ();
   for my $pp ( @$ptr) {
      my ( $fc, $fnc, $len, $brd) = $w-> get_convex( @$pp);
      push @bubik, $fc;
   }
   $w-> {lineStorage}-> [ 1] = \@bubik;
   $w-> {lwStorage}-> [ 1] = [ (1) x @bubik];
   $w-> modified( 1);
   $w-> pt_newset;
   $w-> IV-> repaint;
}

sub win_applycontours
{
   my $w = $_[0];
   $w-> iv_cancelmode( $w-> IV);
   return if defined $w-> {lineStorage}->[0] &&
        ( Prima::MsgBox::message( "Erase present contours?", mb::YesNoCancel|mb::Warning) != mb::Yes);

   $w-> win_syncrecdata;
   my $i = $w-> {ini};
   my ( $u, $b, $e, $mi, $ma) = (
      $i-> {UFThreshold},
      $i-> {BinThreshold},
      $i-> {EdgeSize},
      $i-> {MinArea},
      $i-> {MaxArea},
   );

   $w-> win_objectsetsmenuaction( 0);
   $w-> pt_clear;
   my $im = Prima::IPA::Local::unionFind(
      $w-> win_entersubplace,
      method    => 'ave',
      threshold => $u);

   $im = Prima::IPA::Point::threshold(
      $im,
      minvalue => 0,
      maxvalue => $b);

   $im = Prima::IPA::Global::fill_holes( $im,
      edgeSize => $e,
   );
   $im = Prima::IPA::Global::area_filter( $im,
      edgeSize => $e,
      minArea  => $mi,
      maxArea  => $ma,
   );

   my $cc = Prima::IPA::Global::identify_contours( $im, edgeSize => $e);
   ${$w-> pt_lines_ptr()} = $cc if scalar @$cc;
   ${$w-> pt_lw_ptr()}    = [ (1) x scalar @$cc] if scalar @$cc;
   $w-> pt_newset;
   $w-> modified( 1);

   $::application-> pointer( $w-> {savePointer});
   $w-> win_restore;
}

sub win_set_negative
{
   my ( $w, $neg) = @_;
   $neg = $neg ? 1 : 0;
   return if $w-> {ini}-> {InvertImage} == $neg;
   $w-> {ini}-> {InvertImage} = $neg;
   $w-> menu-> EditInvertImage-> checked( $neg);
   return unless $w-> IV-> image;
   $w-> win_loadfile( $w-> {file});
}

sub win_abortpacket
{
   $_[0]-> {packetAborted} = 1;
}

sub win_xmlerror
{
   # bad
   my ($w, $xmlname) = @_;

bin/MorphometryI  view on Meta::CPAN

use constant PI => 4 * atan2 1, 1;

sub win_calcbasicparameters
{
   my $w = shift;

   # input: xy array
   # output in array context: (area,perimeter,formfactor,xcen,ycen,fxcen,fycen)
   # initialization:
   my ($xCalib, $yCalib) = ( $w-> {ini}-> {XCalibration}, $w-> {ini}-> {YCalibration});

   # algorithm
   my $xflag = 1;
   my( @x, @y);
   for (@_) {
      push @x, $_ if $xflag;
      push @y, $_ unless $xflag;
      $xflag = !$xflag;
   }
   return () unless @x;
   unless ($x[$#x] == $x[0] && $y[$#y] == $y[0]) {
      push @x, $x[0];
      push @y, $y[0];
   }
   my ($xyCalib,$xxCalib,$yyCalib) = ($xCalib*$yCalib,$xCalib*$xCalib,$yCalib*$yCalib);
   my ($area,$perimeter,$xcen,$ycen,$fxcen,$fycen,$ff) = (0,0,0,0,0,0,0,0,0);
   for my $i ( 1..$#x) {
      $area += $xyCalib * ($x[$i-1] * $y[$i] - $x[$i] * $y[$i-1]);
      my $dx = $x[$i-1] - $x[$i];
      my $dy = $y[$i-1] - $y[$i];
      $perimeter += sqrt( $xxCalib * $dx * $dx + $yyCalib * $dy *$dy);
      $xcen += $x[$i];
      $ycen += $y[$i];
      $fxcen += $xCalib * $x[$i];
      $fycen += $yCalib * $y[$i];
   }
   $area = abs( $area / 2);
   $ff = 4 * PI * $area / $perimeter / $perimeter
      if $perimeter > 0;
   $xcen /= @x;
   $ycen /= @y;
   $fxcen /= @x;
   $fycen /= @y;
   return ($area,$perimeter,$ff,$xcen,$ycen,$fxcen,$fycen);
}


sub win_saveframe
{
   my $w = $_[0];
   my $xmlname = $w-> win_extname( $w-> {file});

   return 1 unless $w-> {modified};

   if ( open F, "> $xmlname") {
      my $waitPtr = $::application-> pointer;
      $::application-> pointer( cr::Wait);
      $w-> sb_text("saving $xmlname");
      $w-> win_validate(1);
      $w-> win_syncrecdata;
      my $image = $w-> IV-> image;
      if ( $w->{ini}->{CalcBrightness} && $w->{ini}->{EqualBrightness}) {
         # subtracting low frequencies
         $w-> sb_text("Equalizing background ...");
         my $i1 = Prima::IPA::Global::butterworth( $image, 
            low        => 1,
            homomorph  => 0,
            power      => 2,
            cutoff     => 20,
            boost      => 0.7,
            spatial    => 1,
            lowquality => 1,
         );
         $i1-> type( $image-> type);
         $image = Prima::IPA::Point::subtract( $image, $i1);
         $w-> sb_text("saving $xmlname");
      }   
         

      my ( $iname, $ix, $iy, $path, $datestr, $xc, $yc, $objects, $i) = (
         $w->{file}, $image-> size, $w->{ini}->{path}, scalar(gmtime(time)),
         $w->{ini}->{XCalibration}, $w->{ini}->{YCalibration}, 0
      );
      $iname =~ m{[/\\]([^/\\]*)$};
      $iname = $1;

      for ( $i = 0; $i < 2; $i++) {
         my $ptr = $w-> {lineStorage}->[$i];
         next unless defined $ptr;
         $objects += scalar @$ptr;
      }
      $objects += scalar @{$w-> {points}} / 2 if defined $w-> {points};
      my $objCount = 0;

print F <<HEADER;
<?xml version="1.0"?>
<!DOCTYPE morphology_data SYSTEM "morphology_data.dtd">
<!-- This is a generated file.  Do not edit! -->
<morphology_data
  imagename    = "$iname"
  imagewidth   = "$ix"
  imageheight  = "$iy"
  directory    = "$path"
  creator      = "MorphologyI"
  creationdate = "$datestr"
  xcalib       = "$xc"
  ycalib       = "$yc"
  objects      = "$objects"
>

HEADER

      for ( $i = 0; $i < 2; $i++) {
         my $ptr = $w-> {lineStorage}->[$i];
         next unless defined $ptr;
         my $type = $w-> menu-> text( $i);
         $type =~ s[\~][]g;
         $type = lc $type;
         for ( @$ptr) {
             $objCount++;