Merge pull request #7843 from fluca1978/PWC211

Pwc211

12 files changed, 228 insertions, 0 deletions

diff --git a/challenge-211/luca-ferrari/blog-1.txt b/challenge-211/luca-ferrari/blog-1.txt
new file mode 100644
index 0000000000..20aa3248b4
--- /dev/null
+++ b/challenge-211/luca-ferrari/blog-1.txt
@@ -0,0 +1 @@
+https://fluca1978.github.io/2023/04/03/PerlWeeklyChallenge211.html#task1
diff --git a/challenge-211/luca-ferrari/blog-2.txt b/challenge-211/luca-ferrari/blog-2.txt
new file mode 100644
index 0000000000..af2ebde9dd
--- /dev/null
+++ b/challenge-211/luca-ferrari/blog-2.txt
@@ -0,0 +1 @@
+https://fluca1978.github.io/2023/04/03/PerlWeeklyChallenge211.html#task2
diff --git a/challenge-211/luca-ferrari/blog-3.txt b/challenge-211/luca-ferrari/blog-3.txt
new file mode 100644
index 0000000000..26e77011ea
--- /dev/null
+++ b/challenge-211/luca-ferrari/blog-3.txt
@@ -0,0 +1 @@
+https://fluca1978.github.io/2023/04/03/PerlWeeklyChallenge211.html#task1plperl
diff --git a/challenge-211/luca-ferrari/blog-4.txt b/challenge-211/luca-ferrari/blog-4.txt
new file mode 100644
index 0000000000..87794d6a99
--- /dev/null
+++ b/challenge-211/luca-ferrari/blog-4.txt
@@ -0,0 +1 @@
+https://fluca1978.github.io/2023/04/03/PerlWeeklyChallenge211.html#task2plperl
diff --git a/challenge-211/luca-ferrari/blog-5.txt b/challenge-211/luca-ferrari/blog-5.txt
new file mode 100644
index 0000000000..45531804ca
--- /dev/null
+++ b/challenge-211/luca-ferrari/blog-5.txt
@@ -0,0 +1 @@
+https://fluca1978.github.io/2023/04/03/PerlWeeklyChallenge211.html#task1plpgsql
diff --git a/challenge-211/luca-ferrari/blog-6.txt b/challenge-211/luca-ferrari/blog-6.txt
new file mode 100644
index 0000000000..534fca5816
--- /dev/null
+++ b/challenge-211/luca-ferrari/blog-6.txt
@@ -0,0 +1 @@
+https://fluca1978.github.io/2023/04/03/PerlWeeklyChallenge211.html#task2plpgsql
diff --git a/challenge-211/luca-ferrari/postgresql/ch-1.plperl b/challenge-211/luca-ferrari/postgresql/ch-1.plperl
new file mode 100644
index 0000000000..d2085bdc4c
--- /dev/null
+++ b/challenge-211/luca-ferrari/postgresql/ch-1.plperl
@@ -0,0 +1,29 @@
+--
+-- Perl Weekly Challenge 211
+-- Task 1
+-- See <https://perlweeklychallenge.org/blog/perl-weekly-challenge-211/>
+--
+
+CREATE SCHEMA IF NOT EXISTS pwc211;
+
+/*
+testdb=> select pwc211.task1_plperl( array[ array[4,3,2,1], array[ 5,4,3,2], array[6,5,4,3] ] );
+ task1_plperl 
+--------------
+ t
+(1 row)
+
+*/
+CREATE OR REPLACE FUNCTION
+pwc211.task1_plperl( int[][] )
+RETURNS bool
+AS $CODE$
+   my ( $array ) = @_;
+
+   my $diag;
+   $diag->{ $array->[ $_ ]->[ $_ ] }++ for ( 0 .. scalar( $array->@* ) - 1 );
+   return 0 if ( keys( $diag->%* ) != 1 );
+   return 0 if ( $diag->{ $array->[ 0 ]->[ 0 ] } != scalar( $array->@* ) );
+   return 1;
+$CODE$
+LANGUAGE plperl;
diff --git a/challenge-211/luca-ferrari/postgresql/ch-1.sql b/challenge-211/luca-ferrari/postgresql/ch-1.sql
new file mode 100644
index 0000000000..23a33447de
--- /dev/null
+++ b/challenge-211/luca-ferrari/postgresql/ch-1.sql
@@ -0,0 +1,36 @@
+--
+-- Perl Weekly Challenge 211
+-- Task 1
+--
+-- See <https://perlweeklychallenge.org/blog/perl-weekly-challenge-211/>
+--
+
+CREATE SCHEMA IF NOT EXISTS pwc211;
+
+CREATE OR REPLACE FUNCTION
+pwc211.task1_plpgsql( a int[][])
+RETURNS bool
+AS $CODE$
+DECLARE
+	current_row  int := 1;
+	current_col  int := 1;
+	previous_val int := NULL;
+BEGIN
+	WHILE current_row <= array_length( a, 1 ) LOOP
+	      IF current_row > array_length( a, 2 ) THEN
+	      	 RETURN false;
+              END IF;
+
+	      IF previous_val IS NULL THEN
+	      	 previous_val := a[ current_row ][ current_row ];
+	      ELSIF previous_val <> a[ current_row ][ current_row ] THEN
+	      	   RETURN false;
+             END IF;
+
+	     current_row := current_row + 1;
+	END LOOP;
+
+	RETURN true;
+END
+$CODE$
+LANGUAGE plpgsql;
diff --git a/challenge-211/luca-ferrari/postgresql/ch-2.plperl b/challenge-211/luca-ferrari/postgresql/ch-2.plperl
new file mode 100644
index 0000000000..6513b34abf
--- /dev/null
+++ b/challenge-211/luca-ferrari/postgresql/ch-2.plperl
@@ -0,0 +1,40 @@
+--
+-- Perl Weekly Challenge 211
+-- Task 2
+-- See <https://perlweeklychallenge.org/blog/perl-weekly-challenge-211/>
+--
+
+CREATE SCHEMA IF NOT EXISTS pwc211;
+
+/*
+estdb=# select pwc211.task2_plperl( array[ 1,2,3,4,5,6,7,8] );
+ task2_plperl 
+--------------
+ {1,2,7,8}
+ {3,4,5,6}
+(2 rows)
+
+*/
+CREATE OR REPLACE FUNCTION
+pwc211.task2_plperl( int[] )
+RETURNS SETOF int[]
+AS $CODE$
+   use List::Permutor;
+   use List::Util qw/sum/;
+   my ( $array ) = @_;
+
+   my $permutator   = List::Permutor->new( $array->@* );
+   while ( my @current = $permutator->next ) {
+     my ( $split_at ) = ( $#current + 1) / 2;
+     my ( $left, $right ) = ( [ @current[ 0 .. ( $split_at - 1 ) ] ], [ @current[ $split_at .. $#current ] ] );
+
+     if ( ( sum( $left->@* ) / scalar( $left->@* ) ) == ( sum( $right->@* ) / scalar( $right->@* ) ) ) {
+     	return_next( $left );
+	return_next( $right );
+	return undef;
+     }
+   }
+
+return undef;
+$CODE$
+LANGUAGE plperlu;
diff --git a/challenge-211/luca-ferrari/postgresql/ch-2.sql b/challenge-211/luca-ferrari/postgresql/ch-2.sql
new file mode 100644
index 0000000000..802a8f6932
--- /dev/null
+++ b/challenge-211/luca-ferrari/postgresql/ch-2.sql
@@ -0,0 +1,65 @@
+--
+-- Perl Weekly Challenge 211
+-- Task 2
+--
+-- See <https://perlweeklychallenge.org/blog/perl-weekly-challenge-211/>
+--
+
+CREATE SCHEMA IF NOT EXISTS pwc211;
+
+-- see <https://wiki.postgresql.org/wiki/Permutations>
+CREATE FUNCTION pwc211.permute(anyarray)
+  RETURNS SETOF anyarray
+  LANGUAGE SQL IMMUTABLE
+AS $f$
+  SELECT (WITH RECURSIVE r(n,p,a,b)
+               AS (SELECT i, $1[1:0], $1, array_upper($1,1)
+                   UNION ALL
+                   SELECT n / b, p || a[n % b + 1], a[1:n % b] || a[n % b + 2:b], b-1
+                     FROM r
+                    WHERE b > 0)
+          SELECT p FROM r WHERE b=0)
+  FROM generate_series(0,factorial( (array_upper($1,1)) )::integer-1) i;
+$f$;
+
+
+
+
+CREATE OR REPLACE FUNCTION
+pwc211.task2_plpgsql( a int[] )
+RETURNS SETOF int[]
+AS $CODE$
+DECLARE
+	split_at int := 0;
+	current_array int[];
+	l int[];
+	r int [];
+	avg_l numeric;
+	avg_r numeric;
+BEGIN
+	split_at := array_length( a, 1 ) / 2;
+
+	FOR current_array IN SELECT * FROM pwc211.permute( a ) LOOP
+	    l := current_array[ 1:split_at ];
+	    r := current_array[ (split_at + 1): array_length( a, 1 ) ];
+
+
+	    SELECT avg( v )
+	    INTO   avg_l
+	    FROM   unnest( l ) v;
+
+	    SELECT avg( v )
+	    INTO   avg_r
+	    FROM   unnest( r ) v;
+
+	    IF avg_r = avg_l THEN
+	       RETURN NEXT l;
+	       RETURN NEXT r;
+	       RETURN;
+	    END IF;
+	END LOOP;
+
+RETURN;
+END
+$CODE$
+LANGUAGE plpgsql;
diff --git a/challenge-211/luca-ferrari/raku/ch-1.p6 b/challenge-211/luca-ferrari/raku/ch-1.p6
new file mode 100644
index 0000000000..6c506c4842
--- /dev/null
+++ b/challenge-211/luca-ferrari/raku/ch-1.p6
@@ -0,0 +1,22 @@
+#!raku
+
+#
+# Perl Weekly Challenge 211
+# Task 1
+#
+# See <https://perlweeklychallenge.org/blog/perl-weekly-challenge-211/>
+#
+
+sub MAIN() {
+
+    my @matrix = [ [4, 3, 2, 1],
+                   [5, 4, 3, 2],
+                   [6, 5, 4, 3],
+                 ];
+
+    my %diag;
+    %diag{ @matrix[ $_ ][ $_ ] }++ for 0 ..^ @matrix.elems;
+    'False'.say if ( %diag.keys.elems != 1 || %diag{ @matrix[ 0 ][ 0 ] } != @matrix.elems );
+    'True'.say;
+
+}
diff --git a/challenge-211/luca-ferrari/raku/ch-2.p6 b/challenge-211/luca-ferrari/raku/ch-2.p6
new file mode 100644
index 0000000000..aa425afa73
--- /dev/null
+++ b/challenge-211/luca-ferrari/raku/ch-2.p6
@@ -0,0 +1,30 @@
+#!raku
+
+#
+# Perl Weekly Challenge 211
+# Task 2
+#
+# See <https://perlweeklychallenge.org/blog/perl-weekly-challenge-211/>
+#
+
+sub MAIN( *@list where{ @list.elems == @list.grep( * ~~ Int ).elems } ) {
+
+    for @list.permutations -> @current {
+	# for 0 ..^ @current.elems {
+	#     # find the first couple that gives the same average
+	#     my ($left, $right) = @current[ 0 .. $_ ], @current[ $_ + 1 .. * ];
+	#     if ( ( $left.sum / $left.elems ) == ( $right.sum / $right.elems ) ) {
+	# 	say "{ $left.join( ',' ) } = { $left.sum / $left.elems }  and { $right.join( ',' ) } = { $right.sum / $right.elems } ";
+	# 	exit;
+	#     }
+	# }
+
+	my $split-at = ( @current.elems - 1 ) / 2;
+	my ($left, $right) = @current[ 0 .. $split-at ], @current[ $split-at + 1  .. *  ];
+	if ( ( $left.sum / $left.elems ) == ( $right.sum / $right.elems ) ) {
+	    say "{ $left.join( ',' ) } = { $left.sum / $left.elems }  and { $right.join( ',' ) } = { $right.sum / $right.elems } ";
+	    exit;
+	}
+
+    }
+}