File Coverage

lib/Graphics/Fig/Matrix.pm
Criterion Covered Total %
statement 56 71 78.8
branch 8 12 66.6
condition 2 3 66.6
subroutine 5 6 83.3
pod 0 2 0.0
total 71 94 75.5


line stmt bran cond sub pod time code
1             #
2             # XFig Drawing Library
3             #
4             # Copyright (c) 2017 D Scott Guthridge
5             #
6             # This program is free software: you can redistribute it and/or modify it under
7             # the terms of the Artistic License as published by the Perl Foundation, either
8             # version 2.0 of the License, or (at your option) any later version.
9             #
10             # This program is distributed in the hope that it will be useful, but WITHOUT
11             # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12             # FOR A PARTICULAR PURPOSE. See the Artistic License for more details.
13             #
14             # You should have received a copy of the Artistic License along with this
15             # program. If not, see .
16             #
17             package Graphics::Fig::Matrix;
18             our $VERSION = 'v1.0.8';
19              
20 12     12   69 use strict;
  12         19  
  12         307  
21 12     12   53 use warnings;
  12         18  
  12         286  
22 12     12   43 use Carp;
  12         17  
  12         663  
23              
24 12     12   54 use constant EPS => 1.0e-14;
  12         15  
  12         4993  
25              
26             #
27             # matrix_reduce: reduce a matrix (in-place) to reduced row eschelon form
28             # $a: matrix [ [ a, b, ... ], [ d, e, ...], ... ]
29             #
30             # Return:
31             # determinant
32             #
33             sub reduce {
34 11     11 0 21 my $a = shift;
35              
36 11         15 my $m = scalar(@{$a});
  11         18  
37 11 50       31 my $n = ($m == 0) ? 0 : scalar(@{${$a}[0]});
  11         14  
  11         23  
38 11         13 my $i = 0;
39 11         14 my $j = 0;
40 11         18 my $d = 1.0;
41              
42 11   66     49 while ($i < $m && $j < $n) {
43 36         35 my $scale;
44              
45             #
46             # Find the largest value at or below row $i in column $j and
47             # swap with row $i.
48             #
49 36         35 my $max_abs = 0.0;
50 36         33 my $max_idx = undef;
51 36         58 for (my $r = $i; $r < $m; ++$r) {
52 81 100       62 if (abs(${$a}[$r][$j]) > $max_abs) {
  81         144  
53 57         45 $max_abs = abs(${$a}[$r][$j]);
  57         59  
54 57         82 $max_idx = $r;
55             }
56             }
57 36 50       63 if ($max_abs <= EPS) {
58 0         0 $d = 0.0;
59 0         0 ++$j;
60 0         0 next;
61             }
62 36 100       53 if ($max_idx != $i) {
63 18         19 ( ${$a}[$i], ${$a}[$max_idx] ) = ( ${$a}[$max_idx], ${$a}[$i] );
  18         26  
  18         31  
  18         24  
  18         19  
64 18         25 $d = -$d;
65             }
66              
67             #
68             # Scale pivot to 1.0.
69             #
70 36         33 $scale = ${$a}[$i][$j];
  36         42  
71 36         40 $d /= $scale;
72 36         61 for (my $s = $j; $s < $n; ++$s) {
73 117         95 ${$a}[$i][$s] /= $scale;
  117         164  
74             }
75              
76             #
77             # Clear other entries in column.
78             #
79 36         59 for (my $r = 0; $r < $m; ++$r) {
80 126 100       183 if ($r != $i) {
81 90         66 $scale = -${$a}[$r][$j];
  90         91  
82 90         112 for (my $s = $j; $s < $n; ++$s) {
83 309         230 ${$a}[$r][$s] += $scale * ${$a}[$i][$s];
  309         249  
  309         435  
84             }
85             }
86             }
87 36         56 ++$i;
88 36         78 ++$j;
89             }
90 11         27 return $d;
91             }
92              
93             #
94             # matrix_print: print a matrix
95             # $a: matrix [ [ a, b, ... ], [ d, e, ...], ... ]
96             #
97             sub print {
98 0     0 0   my $a = shift;
99              
100 0           my $m = scalar(@{$a});
  0            
101 0 0         my $n = ($m == 0) ? 0 : scalar(@{${$a}[0]});
  0            
  0            
102 0           for (my $i = 0; $i < $m; ++$i) {
103 0           for (my $j = 0; $j < $n; ++$j) {
104 0           printf(" %10.5g", ${$a}[$i][$j]);
  0            
105             }
106 0           printf("\n");
107             }
108 0           printf("\n");
109             }
110              
111             1;