OpenCV.pd

#  -*- cperl -*-

our $VERSION = 0.07;
use PDL::Exporter;
use Regexp::Common;
use IPC::Run;
use Data::Dumper;

my %PDL_CV_typemapping =
  ( B => 'CV_8UC1',
    S => 'CV_16SC1',
    U => 'CV_16UC1',
    L => 'CV_32SC1',
    F => 'CV_32FC1',
    D => 'CV_64FC1' );

# maps from PP type overrides to opencv types
my %explicit_PDL_CV_typemapping =
  ( int    => 'CV_32SC1',
    float  => 'CV_32FC1',
    double => 'CV_64FC1' );

pp_setversion($VERSION);


pp_addhdr('
#include <opencv/cv.h>
#include <stdio.h>
');

pp_addpm( {At=>'Top'}, <<'EOD');

use strict;
use warnings;


=head1 NAME

PDL::OpenCV - PDL interface to OpenCV

=head1 SYNOPSIS

 use PDL;
 use PDL::NiceSlice;
 use PDL::OpenCV qw(%cvdef Add Cmp);

 my $a = sequence(3,3)->byte;
 my $b = $a->copy->byte;
 $b(0,0) .= 5;

 Add( $a, $b, my $c = $b->zeros, null);
 Cmp( $a, $b, my $d = $b->zeros, $cvdef{CV_CMP_EQ} );

=head1 DESCRIPTION

This is a PDL interface to OpenCV. All the API functions are auto-generated form
the OpenCV headers. The function names and arguments match the OpenCV
C-interface. Arguments are passed I<exactly> like in the C interface: all the
arguments are requires, inputs and output both need to be passed in as
arguments, C<null> should be passed in place of C<NULL>, etc. All C<#define>
constants are available in the C<%cvdef> hash.

=head2 CAVEATS

All output piddles I<must> be passed in preallocated, with the correct dimensions.

All piddles passed into any function I<must> have the same type.

Only functions that take in matrix or scalar arguments are supported: anything
using custom OpenCV structures is I<not> supported.


EOD

pp_addpm( {At=>'Bot'}, <<'EOD');
=head1 REPOSITORY

L<https://github.com/dkogan/PDL-OpenCV>

=head1 AUTHOR

Dima Kogan, C<< <dima@secretsauce.net> >>

=head1 LICENSE AND COPYRIGHT

Copyright 2011-2012 Dima Kogan.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.

=cut
EOD


my @headers = split /\s+/, `find /usr/include/opencv2/ -name *.h -o -name *.hpp`;
my %cvdef; # all defines
foreach my $header (@headers)
{
  next unless -r $header && -f $header; # readable files

  importHeader($header);
}

if( %cvdef )
{
  $Data::Dumper::Terse = 1;
  pp_addpm('our %cvdef = %{ ' . Dumper(\%cvdef) . '};');
  pp_add_exported('%cvdef');
}


pp_done();



sub importHeader
{
  my $header = shift;
  print STDERR "importing header $header\n";

  parseHeader($header);

  sub parseHeader
  {
    my $file = shift;
    open HEADER, "<$file" or die "Couldn't open header $file";
    local $/ = undef;
    my $header = <HEADER>; # slurp in the file
    close HEADER;

    $header =~ s/\r//g;     # strip all CRs
    $header =~ s/\t/ /g;    # tabs to spaces
    $header =~ s/\\\n/ /mg; # convert all escaped newlines to spaces. This allows simple #define handling

    %cvdef = ( %cvdef, %{ parseDefines(\$header, $file ) } );

    my $apire = qr{ \s*CVAPI\s*
                    \(\s*(.*?)\s*\)       # return type as CVAPI(type)
                    \s*([a-zA-Z0-9_]*)    # function name
                    \s*\((.*?)\)\s*; }xs; # argument list;

    while($header =~ /$apire/g)
    {
      my $return  = $1;
      my $name    = $2;
      my $argstr  = $3;

      say STDERR "Trying to import API function $name";

      if($name !~ /^cv(.*)/)
      {
        say STDERR "API function $name doesn't start with 'cv'. Skipping";
        next;
      }
      my $rootname = $1;

      my $docs = makeDocs ($return, $name, $argstr);
      my $args = parseArgs($return, $name, $argstr) or next;
      my $code = makeCode ($args, $name);
      my $pars = join(';', map {$_->{parstring}} @$args);

      pp_def($rootname,
             HandleBad    => 0,
             Pars         => $pars,
             GenericTypes => [B,S,U,L,F,D],
             Code         => $code,
             Doc          => $docs);

      sub parseDefines
      {
        my $header          = shift;
        my $header_filename = shift;

        # Here I need to go through the header, and collect all the #define
        # values. This is a bit tricky since there could be comments,
        # definitions built on other definitions, etc. I thus do this in two
        # steps:
        #   1. Parse the header myself to get a list of all the #defines
        #   2. Run the C preprocessor to expand each of those #defines
        return getDefines( $header_filename,
                           getKeys( $header ) );



        sub getKeys
        {
          my $header = shift;

          my @keys;
          while ($$header =~ /^ \s* \# \s* define \s+   # #define ...
                              ([a-zA-Z0-9_]+) \s+/mgx ) # key. I do not allow '(', so NOT a macro
          {
            push @keys, $1;
          }

          return \@keys;
        }

        sub getDefines
        {
          my $header_filename = shift;
          my $keys            = shift;

          # I run the preprocessor to construct the #define values. First, I
          # construct the input file
          my $input = qq/#include "$header_filename"\n/;
          my $separator = "PDL-OpenCV separator";
          $input .= join '', map { "$separator\n$_\n" } ( @$keys );

          my $output;
          my $err;
          IPC::Run::run( [qw( gcc -E - )], \$input, \$output, \$err)
              or return;

          # I now have the output. Each expanded token is preceded by
          # $separator. I match these and pull out the expansions
          my @expansions = split( "$separator\n", $output );
          shift @expansions; # toss out the body of the #include

          if( scalar @expansions != scalar @$keys )
          {
            die "Error parsing #defines from file '$header_filename'; mismatched token counts";
          }

          for my $i (0..$#$keys)
          {
            my $key   = $keys->[$i];
            my $value = $expansions[$i];

            # the value may have mathematical expressions in it, and it must be
            # evaluateable at compile time, so I try to eval it (perl has the
            # same basic syntax as C :) ). If the eval works, I take the result.
            #
            # I only allow mathematical expressions, so the only letter allowed
            # is 'e' for scientific notation
            next if $value =~ /[a-df-z]/i;
            my $value_eval = eval $value;
            storeValue( \%defines, $key, $value_eval ) if defined $value_eval;
          }

          return \%defines;



          sub storeValue
          {
            my ( $defines, $key, $value ) = @_;

            if (exists $defines->{$key})
            {
              print STDERR "$key already defined.. Using older value\n";
            }
            else
            {
              $defines->{ $key } = $value;
            }
          }
        }
      }

      sub makeDocs
      {
        my ($return, $name, $argstr) = @_;

        my $docs = <<EOD;
=for ref

 $return $name( $argstr );

EOD
        return $docs;
      }

      sub parseArgs
      {
        my ($return, $name, $argstr) = @_;

        # I want to split the argument list on commas, but I need to ignore the commas inside sets
        # of nested parentheses

        my @args = $argstr =~
          / ( (?:
                [^(,]+                             # no parens or commas
                (?:$RE{balanced}{-parens=>'()'})?  # unless they're in a nested set
                [^(,]* )+? )                       # and followed by more no-parens, no-commas
            [,]?/gx;                               # end in a comma (or not, if it's the end)

        # keep only non-empty arguments that aren't all (...)
        @args = grep {/./ && !/^ *\(.*\) *$/} @args;

        foreach my $arg (@args)
        { $arg = parseArg($arg, $name) or return undef; }

        $return = parseArg($return, $name, 1) or return undef;

        # returned value is the first output, unless there is none
        unless( $return->{explicit_type} eq 'void' )
        {
          unshift @args, $return;
        }

        return \@args;



        sub parseArg
        {
          my $argstr   = shift;
          my $funcname = shift;
          my $isreturn = shift;

          my %arg;

          # get rid of newlines and leading/trailing whitespace
          $argstr =~ s/\n/ /g;
          $argstr =~ s/^ *//g;
          $argstr =~ s/ *$//g;

          # read const-ness
          if($argstr =~ /^\s*const\s*/gc)
          { $arg{const} = 1; }

          # get the type. IT's a word with maybe some '*'
          $argstr =~ /\G\s*([0-9A-Za-z_]+[\s*]*)/gc;
          unless( $arg{type} = $1 )
          {
            say STDERR "Can't parse argument type of '$argstr'";
            return undef;
          }

          if(! $isreturn)
          {
            # get the argument name
            $argstr =~ /\G([A-Za-z0-9_]+)\s*/gc;
            unless( $arg{name} = $1 )
            {
              say STDERR "Can't parse argument name of '$argstr'";
              return undef;
            }
            # get the qualifiers, if any
            $argstr =~ /\G(.*?)\s*$/gc;
            $arg{qualifiers} = $1;
          }
          else
          {
            $arg{name} = '_return';
          }

          # I can now interpret the string
          interpretArg(\%arg, $argstr, $isreturn) or return undef;
          makeParString(\%arg) or return undef;
          return \%arg;




          sub interpretArg
          {
            my ($arg, $argstr, $isreturn) = @_;

            # count up the pointers in the type
            my $pointercount = 0;
            while ($arg->{type} =~ /\*/g)
            { $pointercount++; }
            $arg->{type} =~ s/\*/ /g;

            # remove leading/trailing whitespace from the type
            $arg->{type} =~ s/^\s+//g;
            $arg->{type} =~ s/\s+$//g;

            if ($pointercount > 1)
            {
              say STDERR "I can parse at most single pointers: '$argstr'";
              return undef;
            }

            if ( $arg->{type} =~ /CvMat|CvArr/ )
            {
              if( $pointercount < 1)
              {
                say STDERR "Don't know what to do with non-pointer CvMat/CvArr: '$argstr'";
                return undef;
              }

              if( $isreturn )
              {
                say STDERR "Don't know how to return matrices: '$argstr'";
                return undef;
              }

              $arg->{explicit_type} = '';
              $arg->{input}  = 1;
              $arg->{output} = 1 unless $arg->{const};

              # By default the arguments are assumed to simply be data. Some
              # OpenCV functions have requirements on types that aren't obvious
              # beforehand. I apply some heuristics here to get this right. If a
              # variable name is ...count or ...counts, force the type to be an
              # integer
              if( $arg->{name} =~ /counts?$/i )
              {
                $arg->{explicit_type} = 'int';
              }

              # dimensions are assumed 2D for opencv matrices
              # PP complains if the dim name has _ in it
              my $dimno_ = $arg->{name};
              $dimno_ =~ s/_//g; 

              $arg->{dims} = [map {"$dimno_$_"} 0..1];
            }
            else
            {
              if ($pointercount > 0)
              {
                say STDERR "Don't know what to do with a pointer to NOT a CvMat/CvArr: '$argstr'";
                return undef;
              }

              $arg->{input}  = 1;
              $arg->{output} = 1 if( $pointercount > 0 && !$arg->{const} );

              if ( $arg->{type} =~ /^(?:double|float|int)$/)
              {
                $arg->{explicit_type} = $arg->{type};
                $arg->{dims}          = [1]; # this is one-dimensional and that dimension has length 1
              }

              # most of these are from cxtypes.h. I can parse that too, but it's
              # unlikely to change
              elsif ( $arg->{type} =~ /^Cv(?:Point|Size)$/ )
              {
                $arg->{explicit_type}   = 'int';
                $arg->{dims} = [2]; # 1D, len 2
              }
              elsif ( $arg->{type} =~ /^Cv(?:Point|Size)(.)D(..)f$/ )
              {
                if ($2 !~ /32|64/)
                {
                  say STDERR "I can only parse 32-bit and 64-bit floats: '$argstr'";
                  return undef;
                }

                $arg->{explicit_type} = $2 eq '32' ? 'float' : 'double';
                $arg->{dims} = [$1]; # 1D
              }
              elsif ( $arg->{type} =~ /^CvScalar$/ )
              {
                $arg->{explicit_type}   = 'double';
                $arg->{dims} = [4]; # 1D, len 4
              }
              elsif ($arg->{type} =~ /^void$/ && $isreturn )
              {
                $arg->{explicit_type}   = 'void';
                $arg->{dims} = [1];
              }
              else
              {
                say STDERR "Type of '$argstr' not yet supported";
                return undef;
              }
            }

            if ($isreturn)
            {
              $arg->{input}  = 0;
              $arg->{output} = 1;
            }

            return 1;
          }

          sub makeParString
          {
            my $arg = shift;

            my $str = '';

            if($arg->{explicit_type} )
            { $str .= "$arg->{explicit_type} "; }

            if($arg->{output} )
            {
              if($arg->{input}) { $str .= '[io]'; }
              else              { $str .= '[o]'; }
            }

            $str .= $arg->{name};
            $str .= '(';
            $str .= join(',', @{$arg->{dims}});
            $str .= ')';

            $arg->{parstring} = $str;

            return 1;
          }
        }
      }

      sub makeCode
      {
        my $args     = shift;
        my $funcname = shift;

        my $code = '';

        # each argument needs to be tied to opencv. After that is done, we can call the opencv
        # routine itself. The order of the arguments is as specified in @$args. If there is a return
        # value, it comes first

        # first, construct opencv matrices for all the arguments that need this
        foreach my $pdltype( qw(B S U L F D) )
        {
          $code .= "types($pdltype) \%{\n";
          foreach my $arg (@$args)
          {
            my $cvtype;
            if( $arg->{explicit_type} )
            {
              $cvtype = $explicit_PDL_CV_typemapping{ $arg->{explicit_type} };
            }
            else
            {
              $cvtype = $PDL_CV_typemapping{$pdltype};
            }

            if ( $arg->{type} =~ /CvMat|CvArr/ )
            {
              my $argname = $arg->{name};
              $code .= <<EOC;
                CvMat ${argname}_cv;
                CvMat* _p_${argname}_cv;
                if(\$SIZE($arg->{dims}[0]) > 0)
                {
                  ${argname}_cv = cvMat(\$SIZE($arg->{dims}[1]), \$SIZE($arg->{dims}[0]),
                                        $cvtype, \$P($argname));
                  _p_${argname}_cv = &${argname}_cv;
                }
                else
                  _p_${argname}_cv = NULL;
EOC
            }
          }
          $code .= '%}' . "\n";
        }

        # now construct the function call
        if(! @$args)
        {
          $code .= "$funcname();\n ";
          return $code;
        }

        my @argstrs;
        my $arg0;
        if( $args->[0]{name} eq '_return' )
        {
          $arg0 = 1;
          $code .= "*($args->[0]{type} *)\$P($args->[0]{name}) = ";
        }
        else
        {
          $arg0 = 0;
        }


        $code .= "$funcname( ";

        foreach my $arg (@{$args}[$arg0..$#$args])
        {
          my $argname = $arg->{name};

          if( $arg->{type} =~ /CvMat|CvArr/ )
          {
            push @argstrs, "_p_${argname}_cv";
          }
          else
          {
            push @argstrs, "*($arg->{type} *)\$P($argname)";
          }
        }

        $code .= join(', ', @argstrs) . ");\n";

        return $code;
      }
    }
  }
}