Perl Weekly Challenge 237.
My solutions (task 1 and task 2 ) to the The Weekly Challenge - 237.
Task 1: Seize The Day
Submitted by: Mark Anderson
Given a year, a month, a weekday of month, and a day of week (1 (Mon) .. 7 (Sun)),
print the day.
Example 1
Input: Year = 2024, Month = 4, Weekday of month = 3, day of week = 2
Output: 16
The 3rd Tue of Apr 2024 is the 16th
Example 2
Input: Year = 2025, Month = 10, Weekday of month = 2, day of week = 4
Output: 9
The 2nd Thu of Oct 2025 is the 9th
Example 3
Input: Year = 2026, Month = 8, Weekday of month = 5, day of week = 3
Output: 0
There isn't a 5th Wed in Aug 2026
I’ll use some results from PWC227, namely, that (extrapolating) the Gregorian calendar to the year 0000, the first day of the year was a Saturday. Furthermore, there is a leap year every four years, except for multiples of 100 which are not leap years, except for multiples of 400 which are leap years. The length of a year is 1 modulo 7 and that of a leap year is 2 modulo 7. In PWC227 I calculated using the information above the days to the beginning of each month. For simplicity I first change to a zero based numbering of days of weeks, weeks, and months. Then I calculate the first day of the week of the year and the first day of the week of the desired month, which I subtract (modulo 7) from the desired day, I add the number of weeks times 7 days a week, check if resulting date is within month and thats it. The code can be crammed into a three and a half liner, though the full code is much easier to follow.
Example 1:
perl -MPOSIX=floor -E 'print "@ARGV -> ";@d=([31,28,31,30,31,30,31,31,30,31,30,31],[31,29,31,30,31,30,
31,31,30,31,30,31]);@s=([0,3,3,6,1,4,6,2,5,0,3,5],[0,3,4,0,2,5,0,3,6,1,4,6]);($y,$m,$w,$n)=@ARGV;
--$w;--$m;$n%=7;$y%=400;$l=(floor(($y+3)/4)-floor(($y+3)/100))%7;$r=($y+$l+6)%7;$g=($y==0|| ($y%100
!=0 && $y%4==0))||0;$b=($s[$g][$m]+$r)%7;$q=1+($n-$b)%7+$w*7;$q=0 if $q>$d[$g][$m];say $q;
' 2024 4 3 2
Results:
2024 4 3 2 -> 16
Example 2:
perl -MPOSIX=floor -E 'print "@ARGV -> ";@d=([31,28,31,30,31,30,31,31,30,31,30,31],[31,29,31,30,31,30,
31,31,30,31,30,31]);@s=([0,3,3,6,1,4,6,2,5,0,3,5],[0,3,4,0,2,5,0,3,6,1,4,6]);($y,$m,$w,$n)=@ARGV;
--$w;--$m;$n%=7;$y%=400;$l=(floor(($y+3)/4)-floor(($y+3)/100))%7;$r=($y+$l+6)%7;$g=($y==0|| ($y%100
!=0 && $y%4==0))||0;$b=($s[$g][$m]+$r)%7;$q=1+($n-$b)%7+$w*7;$q=0 if $q>$d[$g][$m];say $q;
' 2025 10 2 4
Results:
2025 10 2 4 -> 9
Example 3:
perl -MPOSIX=floor -E 'print "@ARGV -> ";@d=([31,28,31,30,31,30,31,31,30,31,30,31],[31,29,31,30,31,30,
31,31,30,31,30,31]);@s=([0,3,3,6,1,4,6,2,5,0,3,5],[0,3,4,0,2,5,0,3,6,1,4,6]);($y,$m,$w,$n)=@ARGV;
--$w;--$m;$n%=7;$y%=400;$l=(floor(($y+3)/4)-floor(($y+3)/100))%7;$r=($y+$l+6)%7;$g=($y==0|| ($y%100
!=0 && $y%4==0))||0;$b=($s[$g][$m]+$r)%7;$q=1+($n-$b)%7+$w*7;$q=0 if $q>$d[$g][$m];say $q;
' 2026 8 5 3
Results:
2026 8 5 3 -> 0
The full code is:
1 # Perl weekly challenge 237
2 # Task 1: Seize The Day
3 #
4 # See https://wlmb.github.io/2023/10/01/PWC237/#task-1-seize-the-day
5 use v5.36;
6 use experimental qw(for_list);
7 use POSIX qw(floor);
8 die <<~"FIN" unless @ARGV && @ARGV%4==0;
9 Usage: $0 Y1 M1 W1 D1 [Y2 M2 W2 D2...]
10 to find the number corresponding to day Dn of week (1=Monday),
11 weekday of month Wn, month Mn, year Yn
12 FIN
13 my @days_of_month=([31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31], # length of months
14 [31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31]); # nonleap and leap
15 my @days_to_month=([0,3,3,6,1,4,6,2,5,0,3,5], # days to start of month nonleap and leap mod7
16 [0,3,4,0,2,5,0,3,6,1,4,6]);
17 my @ordinal=qw(first second third fourth fifth);
18 my @day_name=qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday);
19 my @month_name=qw(January February March April May June
20 July August September October November Dececmber);
21 for my($year, $month, $weekday, $day_of_week) (@ARGV){
22 warn "Weekday should be between 1 and 5: $weekday", next unless 1<=$weekday<=5;
23 warn "Day of week should be between 1 (Mon) and 7 (Sun): $day_of_week", next
24 unless 1<=$day_of_week<=7;
25 warn "Month should be between 1 and 12", next unless 1<=$month<=12;
26 --$_ for $weekday, $month; # start at 0
27 $day_of_week%=7; # Sun is now 0
28 my $reduced_year=$year%400; # Cycle repeats after 400 years
29 my $previous_leaps=(floor(($reduced_year+3)/4)
30 -floor(($reduced_year+3)/100))%7; # Leap years before start of given year
31 my $start=($reduced_year+$previous_leaps+6)%7; # starting day of week of year, counting from sunday==0
32 my $given_is_leap=($reduced_year==0 || ($reduced_year%100!=0 && $reduced_year%4==0))||0;
33 my $beggining=($days_to_month[$given_is_leap][$month]+$start)%7; # first day of week of month
34 my $day=1+($day_of_week-$beggining)%7+$weekday*7; # desired date
35 $day=0 if $day>$days_of_month[$given_is_leap][$month]; # check it lies within month
36 say "The $ordinal[$weekday] $day_name[$day_of_week] of $month_name[$month] in $year is $day";
37 }
Examples:
./ch-1.pl 2024 4 3 2 2025 10 2 4 2026 8 5 3
Results:
The third Tuesday of April in 2024 is 16
The second Thursday of October in 2025 is 9
The fifth Wednesday of August in 2026 is 0
Task 2: Maximise Greatness
Submitted by: Mohammad S Anwar
You are given an array of integers.
Write a script to permute the give array such that you get the maximum possible greatness.
To determine greatness, nums[i] < perm[i] where 0 <= i < nums.length
Example 1
Input: @nums = (1, 3, 5, 2, 1, 3, 1)
Output: 4
One possible permutation: (2, 5, 1, 3, 3, 1, 1) which returns 4 greatness as below:
nums[0] < perm[0]
nums[1] < perm[1]
nums[3] < perm[3]
nums[4] < perm[4]
Example 2
Input: @ints = (1, 2, 3, 4)
Output: 3
One possible permutation: (2, 3, 4, 1) which returns 3 greatness as below:
nums[0] < perm[0]
nums[1] < perm[1]
nums[2] < perm[2]
The greatness of an array X is obtained comparing its members to those of an optimized permuted array Y. Clearly, greatness is invariant under an initial arbitrary permutation of the elements of X. It is just necessary to perform the same permutation on the elements of Y. Thus, we can put X in numerical order first, yielding X’. Then we can build the permutted Y’ by going through all elements of X’, x’n in order, choosing the smallest unused number y’n such that x’n<y’n. If not possible anymore, greatness has been achieved, we can count how many elements we have in Y’ to obtain the result, and we could finish filling Y’ with arbitrary unused numbers to finish the permutation, although this is unnecesary.
The code fits a one and a half liner.
Example 1:
perl -E '@x=sort {$a<=>$b}@ARGV;@y=@x;$x=shift @x;while(@y){$y=shift @y;push(@z, $y),
$x=shift @x if $x<$y} say "@ARGV -> ", 0+@z;
' 1 3 5 2 1 3 1
Results:
1 3 5 2 1 3 1 -> 4
Example 2:
perl -E '@x=sort {$a<=>$b}@ARGV;@y=@x;$x=shift @x;while(@y){$y=shift @y;push(@z, $y),
$x=shift @x if $x<$y} say "@ARGV -> ", 0+@z;
' 1 2 3 4
Results:
1 2 3 4 -> 3
The full code is very similar:
1 # Perl weekly challenge 237
2 # Task 2: Maximise Greatness
3 #
4 # See https://wlmb.github.io/2023/10/01/PWC237/#task-2-maximise-greatness
5 use v5.36;
6 die <<~"FIN" unless @ARGV;
7 Usage: $0 N1 [N2...]
8 to find the greatness of the array N1 N2...
9 FIN
10 my @copy=my @sorted=sort {$a<=>$b} @ARGV;
11 my $current=shift @sorted;
12 my @permutation;
13 while(@copy){
14 my $next=shift @copy;
15 push(@permutation, $next), $current=shift @sorted if $current<$next
16 }
17 say "@ARGV -> ", 0+@permutation;
Examples:
./ch-2.pl 1 3 5 2 1 3 1
./ch-2.pl 1 2 3 4
Results:
1 3 5 2 1 3 1 -> 4
1 2 3 4 -> 3