use experimental 'signatures', 'lexical_subs', 'declared_refs', 'refaliasing';our $VERSION = '0.07';
our @CARP_NOT = qw( Qhull::PP Qhull::Options );
my sub croak {
goto \&Carp::croak;
}
my sub parse_output_facets;
my sub parse_output_vertices;
my %Parser = (
f => {
func => \&parse_output_facets,
},
p => {
func => \&parse_output_vertices,
},
Fx => {
func => \&parse_extreme_points,
},
FS => {
func => \&parse_size,
},
);
sub supported_output_format( $format ) {
return defined $Parser{$format};
}
sub parse_output( $options, $output, @output_args ) {
my $line_no = 1;
my @output;
for my $arg ( @output_args ) {
my $parser = $Parser{$arg} // croak( "unsupported output format: $arg" );
( $line_no, my $results ) = $parser->{func}->( $options, \$output, $line_no );
push @output, $results;
}
return @output;
}
my $qr_Record = qr/\G\n*([^\n]*?)$/mx;
my $qr_Point = qr/ p(\d+) \(v (\d+) \) /mx;
my $qr_PointRecord = qr/\G\n*- \h* $qr_Point \h* : \h+ ($Num) \h+ ($Num) \h* $ /mx;
my $qr_Facet = qr/f(\d+)/mx;
my $qr_FacetHeader = qr/\G\n*- \h $qr_Facet \h* $/mx;
my $qr_FacetAttr = qr/\G\n* \h+ - \h (?<attr>[^:]+) : \h+ /x;
my %qr_FacetAttr = (
'flags' => qr/\G \h* (\w+) \h*/mx,
'normal' => qr/\G \h* ($Num) \h*/mx,
'offset' => qr/\G \h* ($Num) \h*/mx,
'vertices' => qr/\G \h* $qr_Point \h*/mx,
'neighboring facets' => qr/\G \h* $qr_Facet \h*/mx,
);
sub parse_output_facets ( $option, $buf_ref, $line_no ) {
my \$buffer = $buf_ref;
croak( "end of data in qhull output at line $line_no" )
if $buffer !~ /$qr_Record/g;
if ( ( my $contents = $1 ) !~ /^Vertices and facets/ ) {
croak(
"out of sync in qhull output at line $line_no;" . " expected 'Vertices and facets', got: $contents",
);
}
++$line_no;
my ( @vertices, @facets );
while ( $buffer =~ m/$qr_PointRecord/gc ) {
my ( $point, $vertex, @coords ) = @{^CAPTURE};
push @vertices,
{
( $option->{trace} ? ( line_no => $line_no ) : () ),
point => $point,
vertex => $vertex,
coords => \@coords,
};
}
continue {
++$line_no;
}
croak( "missing vertices at line $line_no" )
if !@vertices;
while ( $buffer =~ m/$qr_FacetHeader/gc ) {
my $id = $1;
my %line_no = ( id => $line_no );
my %facet = ( id => $id, );
$facet{line_no} = \%line_no if $option->{trace};
++$line_no;
while ( $buffer =~ m/$qr_FacetAttr/gc ) {
my $attr = $+{attr};
my $qr = $qr_FacetAttr{$attr} // croak( "unknown facet attribute at line $line_no: $attr" );
my @values = $buffer =~ m/$qr/gc;
@values || croak( "unparseable facet attribute value at line $line_no" );
$facet{$attr} = \@values;
$line_no{$attr} = $line_no;
}
continue {
++$line_no;
}
push @facets, \%facet;
}
croak( "missing facets at line $line_no" )
if !@vertices;
return $line_no, { vertices => \@vertices, facets => \@facets };
}
sub parse_output_vertices( $option, $buf_ref, $line_no ) {
my \$buffer = $buf_ref;
my @results;
for ( 0, 1 ) {
croak( "end of data in qhull output at line $line_no" )
if $buffer !~ /$qr_Record \n/gx;
if ( ( my $contents = $1 ) !~ /\h* ($Int) \h*/x ) {
croak( "out of sync in qhull output at line $line_no;" . " expected an integer, got: $contents", );
}
push @results, $1;
}
continue {
++$line_no;
}
my $nelem = $results[-1];
my ( @vertices );
while ( $nelem-- and my @coords = $buffer =~ m/\G \h* ($Num) \h*?/xmgc ) {
push @vertices, [ ( $option->{trace} ? $line_no : () ), ( map 0+ $_, @coords ), ];
$buffer =~ /\n+/gc;
}
continue {
++$line_no;
}
croak( "missing vertices at line $line_no" )
if !@vertices;
return $line_no, \@vertices;
}
sub parse_extreme_points( $option, $buf_ref, $line_no ) {
my \$buffer = $buf_ref;
croak( "end of data in qhull output at line $line_no" )
if $buffer !~ /$qr_Record \n/gx;
if ( ( my $contents = $1 ) !~ /\h* ($Int) \h*/x ) {
croak( "out of sync in qhull output at line $line_no;" . " expected an integer, got: $contents", );
}
my $nelem = $1;
++$line_no;
my ( @vertices );
while ( $nelem-- and $buffer =~ m/\G \h* ($Int) \h*?\n/xgm ) {
push @vertices, $option->{trace} ? [ $line_no, $1 ] : $1;
}
continue {
++$line_no;
}
croak( "missing vertices at line $line_no" )
if !@vertices;
return $line_no, \@vertices;
}
sub parse_size( $option, $buf_ref, $line_no ) {
my \$buffer = $buf_ref;
croak( "end of data in qhull output at line $line_no" )
if $buffer !~ /$qr_Record \n/gx;
my %results;
my $contents = $1;
my @ints = $contents =~ /\G\h* ($Int) \h*/gxc;
@ints
or
croak( "out of sync in qhull output at line $line_no;" . " expected an integer, got: $contents",
);
$contents =~ /\G\h*$/gcx
or croak( "junk at end of line $line_no: " . substr( $contents, pos( $contents ) ) );
my $nints = shift @ints;
$nints == @ints
or croak( "expected $nints integers; got " . @ints );
++$line_no;
croak( "end of data in qhull output at line $line_no" )
if $buffer !~ /$qr_Record \n/gx;
if ( ( $contents = $1 ) !~ /\h* ($Int) \h*/gx ) {
croak( "out of sync in qhull output at line $line_no;" . " expected an integer, got: $contents", );
}
my $nelem = $1;
my @reals = $contents =~ /\G\h* ($Num) \h*/cgmx;
$contents =~ /\G\h*$/gcx
or croak( "junk at end of line $line_no: " . substr( $contents, pos( $contents ) ) );
@reals
or croak(
sprintf(
'out of sync in qhull output at line %d; expected %d real numbers, got: %s',
$line_no, $nelem, substr( $contents, pos( $contents ) ) ) );
$nelem == @reals
or croak( sprintf( 'expected %d real numbers at line %d; got %d', $nelem, $line_no, 0+ @reals ) );
@results{ 'area', 'volume' } = @reals;
if ( $option->{trace} ) {
$results{line_no} = {
area => $line_no,
volume => $line_no,
};
}
++$line_no;
return $line_no, \%results;
}
1;