Deconvolution/2D+: Difference between revisions

m
→‎{{header|Raku}}: sync rref/trim-system with other tasks, general tidying
m (→‎{{header|Phix}}: added syntax colouring the hard way)
m (→‎{{header|Raku}}: sync rref/trim-system with other tasks, general tidying)
Line 1,748:
=={{header|Raku}}==
(formerly Perl 6)
Works with Rakudo 2018.03.
 
Translation of Tcl.
Line 1,764 ⟶ 1,763:
@h.AT-POS(|$_) = $v;
}
return @h;
}
 
Line 1,775 ⟶ 1,774:
for ^@hc -> $i {
my $window = @gcoord[$i] - @hc[$i];
@fcoord.push($window) and next if 0 <= $window < @f.shape[$i];
last;
}
Line 1,781 ⟶ 1,780:
}
@row.push: @g.AT-POS(|@gcoord);
return @row;
}
 
# Constructs an AoA of coordinates to all elements of N dimensional array
sub coords ( @dim ) {
@[reverse $_ for [X] ([^$_] for reverse @dim)];
}
 
Line 1,792 ⟶ 1,791:
# Can handle over-specified systems (N unknowns in N + M equations)
sub rref (@m) {
return@m unless= trim-system @m;
my ($lead, $rows, $cols) = 0, +@m, +@m[0];
 
# Trim off over specified rows if they exist, for efficiency
if $rows >= $cols {
@m = trim_system(@m);
$rows = +@m;
}
 
for ^$rows -> $r {
return @m unless $lead < $cols or return @m;
my $i = $r;
until @m[$i;$lead] {
next unless ++$i == $rows or next;
$i = $r;
return @m if ++$lead == $cols and return @m;
}
@m[$i, $r] = @m[$r, $i] if $r != $i;
my@m[$r] »/=» $lv = @m[$r;$lead];
@m[$r] »/=» $lv;
for ^$rows -> $n {
next if $n == $r;
@m[$n] »-=» @m[$r] »*×» (@m[$n;$lead] // 0);
}
++$lead;
}
return @m;
}
 
# Reduce ato system ofN equations toin N equationsunknowns; witha Nno-op unless unknownsrows > cols
sub trim_systemtrim-system ($@m) {
return @m my ($vars,unless @t)m = +$@m[0]-1;
my (\vars, @t) = for ^$vars@m[0] -> $lead {1;
for ^$mvars -> $row\lead {
for ^@t.push:m |-> $m.splice( $\row, 1 ) and last if $m[$row;$lead];{
@t.append: @m.splice(row, 1) and last if @m[row;lead];
}
}
while (+@t < $vars) and +$m { @t.push: $m.splice(0, 1) };
return @t;
}
while (+@t < $vars) and +$@m { @t.push: $m.splice(0,shift 1)@m };
}@t
}
 
# Pretty printer for N dimensional arrays
# Assumes if first element in level is an array, then all are
sub pretty_printpretty-print ( @array, $indent = 0 ) {
if @array[0] ~~ Array {
say ' ' x $indent,"[";
pretty_printpretty-print( $_, $indent + 2 ) for @array;
say ' ' x $indent, "]{$indent??','!!''}";
} else {
Line 1,892 ⟶ 1,884:
my @h = deconvolve-N( @g, @f );
say "h =";
pretty_printpretty-print( @h );
my @h-shaped[2;3;4] = @(deconvolve-N( @g, @f ));
my @ff = deconvolve-N( @g, @h-shaped );
say "\nff =";
pretty_printpretty-print( @ff );</lang>
 
Output:
2,392

edits