#! /usr/bin/perl.exe

###############################################################################
###############################################################################
#
# Patterned dates finder.
#
#	by Andrew Hardwick
#
###############################################################################
###############################################################################
# Version 1, 2006/4/4
#  Outputs date representations for visual checking.
#  Supports ISO, USA & UK orders, 4 & 2 digit years, leading 0 keep or discard.
# Version 2, 2006/4/5
#  Added leap year support.
#  Added removal of duplicates (where different representation look equal).
# Version 3, 2006/4/6
#  Added searching for palindromes.
#  Added searching for 180 rotational symmetry ambigrams = diad symmetry.
#  Debugged removal of duplicates (was removing some non-duplicates too).
#  Added searching for mirror symmetry.
#  Added searching for cyclic sysmmetry.
# Version 4, 2006/4/7
#  Added searching for arithmetic series.
#  Added searching for geometric series.
# Version 5, 2006/4/7
#  Added searching for string patterns common across all same size substrings.
# Version 6, 2007/4/11
#  Source code cosmetic tidying (reduced all lines to <=80 characters).
#  Changed to take year range as command line parameters instead of hardcoded.
# Version 7, 2009/6/21
#  Corrected bug (had '2'<->'5' as diad instead of mirror symmetry).
###############################################################################
# How to use:
#  Set the start & end years in the settings in this file the run the program.
#  It will output dates in which it finds patterns.
###############################################################################
# This file is formated for 80 character (+linebreak) rows & 4 character tabs.
###############################################################################
###############################################################################

# Turn off automatic variables
use strict;

###############################################################################
# Main routine
###############################################################################

{	# Get parameters
	unless(@ARGV)
	{	die("Give a year or start and end years as parameters.\n");}
	my $YearStart=$ARGV[0];
	my $YearEnd=$ARGV[1]||$YearStart;
	# Iterate over years
	for(my $Year=$YearStart;$Year<=$YearEnd;$Year++)
	{	# Iterate over months
		for(my $Month=1;$Month<=12;$Month++)
		{	# Iterate over days
			my $MonthLength=
					($Month==9||$Month==4||$Month==6||$Month==11)?30:31;
			if($Month==2)
			{	# Leap year processing
				$MonthLength=($Year%400==0||$Year%100!=0&&$Year%4==0)?28:27;}
			for(my $Day=1;$Day<=$MonthLength;$Day++)
			{	# Iterate over alternative date representations
				my @Dates=DateFormats($Year,$Month,$Day);
				foreach my $Date (@Dates)
				{	# Search for whole string patterns
					my @Patterns=FindPatternsInString($Date);
					# Search for patterns in regular size chunks
					for(my $Size=1;$Size<=length($Date)/2;$Size++)
					{	if(length($Date)%$Size==0)
						{	my @Chunks=$Date=~/.{$Size}/g;
							# Search for number series
							my @ChunkPatterns=FindSeriesInNumberList(@Chunks);
							# Search for repeated patterns (not single digit)
							if($Size>1)
							{	push(@ChunkPatterns,
										FindPatternsInStringList(@Chunks));}
							# Add the chunk patterns to the pattern list
							foreach my $ChunkPattern (@ChunkPatterns)
							{	push(@Patterns,join(':',@Chunks).
									" = ".$ChunkPattern);}}}
					# Output patterns found (if any)
					foreach my $Pattern (@Patterns)
					{	print "$Year/$Month/$Day: $Date = $Pattern\n";}}}}}}
		
###############################################################################
# Create dates of different formats
###############################################################################
# Formats a dates as ISO, UK & USA formats with years in 2 & 4 digit formats
#  and leading 0s kept & removed in <=2 digit fields. Field separators
#  are not included. It does not check for invalid dates or cope with
#  with years BC.
###############################################################################
# Parameter 0:
#  Year as number.
# Parameter 1:
#  Month as number.
# Parameter 2:
#  Day as number.
# Returns:
#  Array of the different formats as strings.
###############################################################################

sub DateFormats
{	my($Year,$Month,$Day)=@_[0...2];
	my @Dates;
	# 4 digit year
	my @Year;
	$Year="000$Year";
	push(@Year,substr($Year,-4));
	# 2 digit year
	push(@Year,substr($Year,-2));
	# 1 digit year
	if(substr($Year,-2,1)eq'0')
	{	push(@Year,substr($Year,-1));}
	# 2 digit month
	my @Month;
	push(@Month,substr("0$Month",-2));
	# 1 digit month
	if($Month<10)
	{	push(@Month,$Month);}
	# 2 digit day
	my @Day;
	push(@Day,substr("0$Day",-2));
	# 1 digit day
	if($Day<10)
	{	push(@Day,$Day);}
	# Assemble all formats
	foreach my $Year (@Year)
	{	foreach my $Month (@Month)
		{	foreach my $Day (@Day)
			{	# ISO
				push(@Dates,"$Year$Month$Day");
				# UK
				push(@Dates,"$Day$Month$Year");
				# USA
				push(@Dates,"$Month$Day$Year");}}}
	# Remove duplicates
	@Dates=sort(@Dates);
	for(my $c=1;$c<@Dates;$c++)
	{	if($Dates[$c]eq$Dates[$c-1])
		{	splice(@Dates,$c--,1);}}
	return @Dates;}

###############################################################################
# Find text patterns in a string of digits
###############################################################################
# Searches for text based patterns strings of digits and returns
# names/descriptions of any it finds.
###############################################################################
# Parameter 0:
#  A string of digits.
# Returns:
#  Array of names/descriptions of the patterns found.
###############################################################################

sub FindPatternsInString
{	my $String=$_[0];
	my(@Found,$Temp);
	# Check for single digit
	if($String=~/^(.)\1*$/)
	{	push(@Found,'single digit');}
	# Check for palindrome
	my $Reversed=reverse($String);
	if($String eq $Reversed)
	{	push(@Found,'palindrome');}
	# Check for left-right mirror symmetric
	($Temp=$Reversed)=~tr/0123456789/015.2...8./;
	if($String eq $Temp)
	{	push(@Found,'left-right mirror symmetric');}
	# Check for up-down mirror symmetric
	if($String=~/^[0180]*$/)
	{	push(@Found,'up-down mirror symmetric');}
	# Check for diad ambigram
	($Temp=$Reversed)=~tr/0123456789/01....9..6/;
	if($String eq $Temp)
	{	push(@Found,'180 deg rotationally symmetric');}
	# Check for cyclic permuation symmetric
	if(substr($String.$String,1,-1)=~/$String/)
	{	push(@Found,'cyclic permutation symmetric');}
	return @Found;}

###############################################################################
# Find mathematical series in a list of numbers
###############################################################################
# Searches for simple mathematical series in an array of digits and
# returns names/descriptions of any it finds. It is sensitive to the order
# of the numbers (e.g. (1,2,3) is an arithmetic series but (1,3,2) is not).
###############################################################################
# Parameters:
#  The array/list of numbers.
# Returns:
#  Array of names/descriptions of the patterns found.
###############################################################################

sub FindSeriesInNumberList
{	my @List=@_;
	my(@Found,$c);
	# Check for arithmetic series (but not simply equal)
	if(@List>=3&&$List[0]!=$List[1])
	{	my $Increment=$List[1]-$List[0];
		for($c=2;$c<@List;$c++)
		{	if($List[$c-1]+$Increment!=$List[$c])
			{	last;}}
		if($c==@List)
		{	push(@Found,"arthimetic series of increment $Increment");}}
	# Check for geometric series (but not simply equal)
	if(@List>=3&&$List[0]!=$List[1]&&$List[0]!=0)
	{	my $Ratio=$List[1]/$List[0];
		for($c=2;$c<@List;$c++)
		{	if($List[$c-1]*$Ratio!=$List[$c])
			{	last;}}
		if($c==@List)
		{	push(@Found,"geometric series of ratio $Ratio");}}
	# Check for simple ratio (but not just equal or already a geometric series)
	if(@List==2&&$List[0]!=$List[1]&&$List[0]!=0&&$List[1]!=0)
	{	if($List[1]>$List[0])
		{	if($List[1]%$List[0]==0)
			{	push(@Found,"integer ratio of 1 to ".$List[1]/$List[0]);}}
		else
		{	if($List[0]%$List[1]==0)
			{	push(@Found,"integer ratio of ".$List[0]/$List[1]." to 1");}}}
	return @Found;}

###############################################################################
# Find text patterns common to a list of digits
###############################################################################
# Searches for text based patterns that are common to all members of
# list of strings of digits and returns names/descriptions of any it finds.
###############################################################################
# Parameters:
#  The array/list of strings of digits.
# Returns:
#  Array of names/descriptions of the patterns found.
###############################################################################

sub FindPatternsInStringList
{	my @List=@_;
	# Find the patterns which apply each string
	my($Found,%Found,@Found);
	foreach my $String (@List)
	{	foreach $Found (FindPatternsInString($String))
		{	$Found{$Found}++;}}
	# Find the subset of those patterns that apply to to every string
	foreach $Found (keys %Found)
	{	if($Found{$Found}==@List)
		{	push(@Found,"each is $Found");}}
	return @Found;}

###############################################################################
###############################################################################