create a fair tournament schedule for n ranked players

turnier.pl

#!/usr/bin/env perl
# create a fair tournament schedule for n ranked players,
# where each player plays only against his ranked neighbors, not round-robin.
# this is much better than a round-robin. and also better than swiss, because
# all matches are predefined, you don't have to wait for matches to end at
# the end of each round, thus it will be much faster.
# args: n players, default 18.
#       r rounds, default 6
# FIXME: odd number of players, just add 1.
# Note: Neither deepseek-r1 not claude sonnet was able to come up with such a system, even
#       when I explained them the disadvantages of round-robin and swiss.

use strict;
use warnings;
use List::Util qw(shuffle);

my $n = shift || 18;
my $r = shift || 6;
# list of ranked players
my @players = 1 .. $n;
my %played;
my @schedule;
my $round = 0;

# Validate input
die "Number of players must be at least 2\n" if $n < 2;
die "Number of rounds must be at least 1\n" if $r < 1;

# choose the next best picks
my @picks;
for my $i (1 .. $n) {
    push @picks, ($i, -$i);
}
my @all_picks = @picks;

sub next_pick {
    my $i = shift;
    my $pick = shift @picks;
    if (!@picks) {
        return 0;
        #push @picks, ($r/2 + 1, - $r/2 - 1);
    }
    if ($pick + $i > $n || $pick + $i <= 0) {
        return next_pick($i);
    } else {
        return $pick + $i;
    }
}

# Generate rounds
for my $round (1 .. $r) {
    my (@round_matches, %round, $k);
        
    # Find pairs not yet played from ranked picks
    for (my $i = 1; $i <= $n; $i++) {
        $i++ if $round{$i};
        next if $i > $n;
        my $j = next_pick($i);
        while ($played{$i}{$j} or $played{$j}{$i} or $round{$j}) {
            # Players already played against each other, choose the next best pick
            $j = next_pick($i);
            if (!$j or $k++ > 2 * $n * $r) { # give up these round, try again
                for my $match (@round_matches) {
                    my ($i, $j) = @$match;
                    $played{$i}{$j} = 0;
                    $round{$i} = $round{$j} = 0;
                }
                print "  Gave up, try again...\n";
                @round_matches = ();
                @picks = shuffle(@all_picks);
                next;
            }
            #print "  Try $i vs $j...\n";
        }
        push @round_matches, [$i, $j];
        #print "  Matched $i vs $j...\n";
        $played{$i}{$j} = 1;
        $round{$i} = $round{$j} = 1;
        @picks = @all_picks;
        last if @round_matches == $n/2;
    }
    push @schedule, \@round_matches;
    #print "Round $round:\n";
    #for my $match (@round_matches) {
    #    my ($player1, $player2) = @$match;
    #    print "  Player $player1 vs " . ($player2 eq 'bye' ? '-' : "$player2") . "\n";
    #}
    print "------\n";
}

print "Tournament Schedule (Players: $n, Rounds: " . scalar(@schedule) . "):\n";
for my $round (0..$#schedule) {
    print "Round " . ($round + 1) . ":\n";
    for my $match (@{$schedule[$round]}) {
        my ($player1, $player2) = @$match;
        print "  Player $player1 vs " . ($player2 == 0 ? '-' : "$player2") . "\n";
    }
    print "\n";
}