country-splitting-algorithm.pl

#! /usr/local/bin/perl -w

use strict;
use warnings;

# See <URL: https://twitter.com/gro_tsen/status/1530670251871899650 >
# for explanations as to what this does.

my $size = 64;

my $zoomfactor = 8;

my $outfname = "function.pgm";
my $outgname = "giving.pgm";

# Create an input function on which to apply the algorithm (noisy gradient):
my @results;
for ( my $i=0 ; $i<$size ; $i++ ) {
    my $t = $i/($size-1);
    my $r = $t*(1-$t)*4;
    for ( my $j=0 ; $j<$size ; $j++ ) {
        $results[$i][$j] = $j/($size-1)*$r + rand(1)*(1-$r);
    }
}

# Save image with input function (as grayscale):
open my $outf, ">", $outfname or die "can't open $outfname for writing: $!";
printf $outf "P2\n%d %d 255\n", $size*$zoomfactor, $size*$zoomfactor;
for ( my $i=0 ; $i<$size ; $i++ ) {
    for ( my $ii=0 ; $ii<$zoomfactor ; $ii++ ) {
        for ( my $j=0 ; $j<$size ; $j++ ) {
            for ( my $jj=0 ; $jj<$zoomfactor ; $jj++ ) {
                printf $outf " %03d", int($results[$i][$j]*255+0.5);
            }
        }
        print $outf "\n";
    }
}
close $outf;

# --- The algorithm proper starts here ---

my @given;

# Fill an array with all quadruples:
#   (i, j, country, votes for this country in district (i,j))
my @votes;
for ( my $i=0 ; $i<$size ; $i++ ) {
    for ( my $j=0 ; $j<$size ; $j++ ) {
        for ( my $k=0 ; $k<2 ; $k++ ) {
            push @votes, [$i, $j, $k, ($k ? $results[$i][$j] : 1-$results[$i][$j])];
        }
    }
}
# Sort by reverse number of votes:
@votes = sort { $b->[3] <=> $a->[3] } @votes;

# The algorithm's main loop:
MAINLOOP:
while ( 1 ) {
    for ( my $idx=0 ; $idx<scalar(@votes) ; $idx++ ) {
        # Examine district votes in decreasing order:
        my $i = $votes[$idx]->[0];
        my $j = $votes[$idx]->[1];
        if ( defined($given[$i][$j]) ) {
            # This district has already been given out - remove it.
            splice(@votes, $idx, 1);
            next MAINLOOP;
        }
        my $k = $votes[$idx]->[2];
        # Should we give district (i,j) to country k?  Is it adjacent
        # to the edge or to a district already given to this country?
        if ( ( $j==0 && $k==0 ) || ( $j==$size-1 && $k==1 )
             || ( $i>0 && defined($given[$i-1][$j]) && $given[$i-1][$j]==$k )
             || ( $i<$size-1 && defined($given[$i+1][$j]) && $given[$i+1][$j]==$k )
             || ( $j>0 && defined($given[$i][$j-1]) && $given[$i][$j-1]==$k )
             || ( $j<$size-1 && defined($given[$i][$j+1]) && $given[$i][$j+1]==$k ) ) {
            # Yes: give it, remove from the list, and continue looping.
            $given[$i][$j] = $k;
            splice(@votes, $idx, 1);
            next MAINLOOP;
        }
    }
    last MAINLOOP;
}

# --- The algorithm proper ends here ---

# Save image with result:
open my $outg, ">", $outgname or die "can't open $outgname for writing: $!";
printf $outg "P2\n%d %d 255\n", $size*$zoomfactor, $size*$zoomfactor;
for ( my $i=0 ; $i<$size ; $i++ ) {
    for ( my $ii=0 ; $ii<$zoomfactor ; $ii++ ) {
        for ( my $j=0 ; $j<$size ; $j++ ) {
            for ( my $jj=0 ; $jj<$zoomfactor ; $jj++ ) {
                die "this is impossible" unless defined($given[$i][$j]);
                if ( $given[$i][$j] ) {
                    printf $outg " 255";
                } else {
                    printf $outg "   0";
                }
            }
        }
        print $outg "\n";
    }
}
close $outg;