150 lines
4 KiB
Perl
150 lines
4 KiB
Perl
use strict;
|
|
use warnings;
|
|
|
|
sub fourFaceCombs {
|
|
my %found = ();
|
|
my @res = ();
|
|
for (my $i = 1; $i <= 4; $i++) {
|
|
for (my $j = 1; $j <= 4; $j++) {
|
|
for (my $k = 1; $k <= 4; $k++) {
|
|
for (my $l = 1; $l <= 4; $l++) {
|
|
my @c = sort ($i, $j, $k, $l);
|
|
my $key = 0;
|
|
for my $p (@c) {
|
|
$key = 10 * $key + $p;
|
|
}
|
|
if (not exists $found{$key}) {
|
|
$found{$key} = 1;
|
|
push @res, \@c;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return @res;
|
|
}
|
|
|
|
sub compare {
|
|
my $xref = shift;
|
|
my $yref = shift;
|
|
|
|
my @x = @$xref;
|
|
my $xw = 0;
|
|
|
|
my @y = @$yref;
|
|
my $yw = 0;
|
|
|
|
for my $i (@x) {
|
|
for my $j (@y) {
|
|
if ($i < $j) {
|
|
$yw++;
|
|
}
|
|
if ($j < $i) {
|
|
$xw++;
|
|
}
|
|
}
|
|
}
|
|
|
|
if ($xw < $yw) {
|
|
return -1;
|
|
}
|
|
if ($yw < $xw) {
|
|
return 1;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
sub findIntransitive3 {
|
|
my $dice_ref = shift;
|
|
my @dice = @$dice_ref;
|
|
my $len = scalar @dice;
|
|
|
|
my @res = ();
|
|
for (my $i = 0; $i < $len; $i++) {
|
|
for (my $j = 0; $j < $len; $j++) {
|
|
my $first = compare($dice[$i], $dice[$j]);
|
|
if ($first == 1) {
|
|
for (my $k = 0; $k < $len; $k++) {
|
|
my $second = compare($dice[$j], $dice[$k]);
|
|
if ($second == 1) {
|
|
my $third = compare($dice[$k], $dice[$i]);
|
|
if ($third == 1) {
|
|
my $d1r = $dice[$i];
|
|
my $d2r = $dice[$j];
|
|
my $d3r = $dice[$k];
|
|
my @itd = ($d1r, $d2r, $d3r);
|
|
push @res, \@itd;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return @res;
|
|
}
|
|
|
|
sub findIntransitive4 {
|
|
my $dice_ref = shift;
|
|
my @dice = @$dice_ref;
|
|
my $len = scalar @dice;
|
|
|
|
my @res = ();
|
|
for (my $i = 0; $i < $len; $i++) {
|
|
for (my $j = 0; $j < $len; $j++) {
|
|
for (my $k = 0; $k < $len; $k++) {
|
|
for (my $l = 0; $l < $len; $l++) {
|
|
my $first = compare($dice[$i], $dice[$j]);
|
|
if ($first == 1) {
|
|
my $second = compare($dice[$j], $dice[$k]);
|
|
if ($second == 1) {
|
|
my $third = compare($dice[$k], $dice[$l]);
|
|
if ($third == 1) {
|
|
my $fourth = compare($dice[$l], $dice[$i]);
|
|
if ($fourth == 1) {
|
|
my $d1r = $dice[$i];
|
|
my $d2r = $dice[$j];
|
|
my $d3r = $dice[$k];
|
|
my $d4r = $dice[$l];
|
|
my @itd = ($d1r, $d2r, $d3r, $d4r);
|
|
push @res, \@itd;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return @res;
|
|
}
|
|
|
|
sub main {
|
|
my @dice = fourFaceCombs();
|
|
my $len = scalar @dice;
|
|
print "Number of eligible 4-faced dice: $len\n\n";
|
|
|
|
my @it3 = findIntransitive3(\@dice);
|
|
my $count3 = scalar @it3;
|
|
print "$count3 ordered lists of 3 non-transitive dice found, namely:\n";
|
|
for my $itref (@it3) {
|
|
print "[ ";
|
|
for my $r (@$itref) {
|
|
print "[@$r] ";
|
|
}
|
|
print "]\n";
|
|
}
|
|
print "\n";
|
|
|
|
my @it4 = findIntransitive4(\@dice);
|
|
my $count = scalar @it4;
|
|
print "$count ordered lists of 4 non-transitive dice found, namely:\n";
|
|
for my $itref (@it4) {
|
|
print "[ ";
|
|
for my $r (@$itref) {
|
|
print "[@$r] ";
|
|
}
|
|
print "]\n";
|
|
}
|
|
}
|
|
|
|
main();
|