IRSSI PGN player

chess.pl

use strict;
use warnings;
use Irssi;

# Irssi Script Metadata
our %IRSSI = (
    authors     => 'Paige Thompson',
    contact     => 'paige@paige.bio',
    name        => 'chess',
    description => 'PGN Chess Viewer for Irssi',
    license     => 'Public Domain',
);

my %board;
my $turn = 'w';
my @moves;
my $witem;
my $timer;
my $move_index = 0;
my $current_pgn = "";

my %UNICODE = (
    'K' => '♔', 'Q' => '♕', 'R' => '♖', 'B' => '♗', 'N' => '♘', 'P' => '♙',
    'k' => '♚', 'q' => '♛', 'r' => '♜', 'b' => '♝', 'n' => '♞', 'p' => '♟',
);

my $LIGHT_BG = "00"; # White/Light
my $DARK_BG  = "14"; # Grey/Dark
my $PIECE_FG = "01"; # Black text for pieces

# =========================================================
# BOARD INIT
# =========================================================
sub init_board {
    %board = ();
    for my $f ('a'..'h') {
        $board{"${f}2"} = 'P';
        $board{"${f}7"} = 'p';
    }
    my @back = qw(R N B Q K B N R);
    my @files = ('a'..'h');
    for my $i (0..7) {
        $board{"$files[$i]1"} = $back[$i];
        $board{"$files[$i]8"} = lc $back[$i];
    }
    $turn = 'w';
    $move_index = 0;
}

# =========================================================
# UTILITIES
# =========================================================
sub say_line {
    my ($line) = @_;
    return unless $witem;
    $witem->command("MSG " . $witem->{name} . " $line");
}

sub cell {
    my ($f, $r, $p) = @_;
    my $bg = (($f + $r) % 2 != 0) ? $LIGHT_BG : $DARK_BG;
    if (defined $p) {
        return "\x03$PIECE_FG,$bg $UNICODE{$p} ";
    } else {
        return "\x03$PIECE_FG,$bg   ";
    }
}

sub print_board {
    for my $r (reverse 0..7) {
        my $line = '';
        for my $f (0..7) {
            my $file = chr(ord('a') + $f);
            my $rank = $r + 1;
            $line .= cell($f, $r, $board{"$file$rank"});
        }
        $line .= "\x0f";
        say_line($line);
    }
}

# =========================================================
# MOVE VALIDATION
# =========================================================
sub is_path_clear {
    my ($from, $to) = @_;
    my ($f1, $r1) = $from =~ /([a-h])([1-8])/;
    my ($f2, $r2) = $to =~ /([a-h])([1-8])/;
    $f1 = ord($f1) - ord('a'); $r1--;
    $f2 = ord($f2) - ord('a'); $r2--;

    my $df = $f2 <=> $f1;
    my $dr = $r2 <=> $r1;

    my $f = $f1 + $df;
    my $r = $r1 + $dr;

    while ($f != $f2 || $r != $r2) {
        my $sq = chr(ord('a') + $f) . ($r + 1);
        return 0 if $board{$sq};
        $f += $df;
        $r += $dr;
    }
    return 1;
}

sub can_reach {
    my ($from, $to, $piece, $is_cap) = @_;
    my ($f1, $r1) = $from =~ /([a-h])([1-8])/;
    my ($f2, $r2) = $to =~ /([a-h])([1-8])/;
    $f1 = ord($f1) - ord('a'); $r1--;
    $f2 = ord($f2) - ord('a'); $r2--;
    
    my $df = abs($f1 - $f2);
    my $dr = abs($r1 - $r2);
    my $p = uc $piece;

    if ($p eq 'N') {
        return ($df == 1 && $dr == 2) || ($df == 2 && $dr == 1);
    }
    if ($p eq 'B') {
        return ($df == $dr) && is_path_clear($from, $to);
    }
    if ($p eq 'R') {
        return ($df == 0 || $dr == 0) && is_path_clear($from, $to);
    }
    if ($p eq 'Q') {
        return ($df == $dr || $df == 0 || $dr == 0) && is_path_clear($from, $to);
    }
    if ($p eq 'K') {
        return $df <= 1 && $dr <= 1;
    }
    if ($p eq 'P') {
        my $dir = ($piece eq 'P') ? 1 : -1;
        if ($is_cap) {
            return $df == 1 && $dr == 1 && ($r1 + $dir == $r2);
        } else {
            if ($f1 == $f2) {
                if ($r1 + $dir == $r2) {
                    return !$board{$to};
                }
                if ($r1 + 2*$dir == $r2 && ($r1 == 1 || $r1 == 6)) {
                    my $mid = chr(ord('a') + $f1) . ($r1 + $dir + 1);
                    return !$board{$to} && !$board{$mid};
                }
            }
            return 0;
        }
    }
    return 0;
}

# =========================================================
# PIECE FINDER
# =========================================================
sub find_piece {
    my ($piece, $dest, $dis, $is_cap) = @_;
    my @candidates;

    for my $sq (keys %board) {
        next unless $board{$sq} && $board{$sq} eq $piece;
        
        # Check disambiguation
        if ($dis) {
            if ($dis =~ /^[a-h][1-8]$/) { next if $sq ne $dis; }
            elsif ($dis =~ /^[a-h]$/) { next if $sq !~ /^$dis/; }
            elsif ($dis =~ /^[1-8]$/) { next if $sq !~ /$dis$/; }
        }

        if (can_reach($sq, $dest, $piece, $is_cap)) {
            push @candidates, $sq;
        }
    }
    Irssi::print("DEBUG: find_piece sym=$piece dest=$dest dis=" . ($dis||'') . " cap=" . ($is_cap||0) . " found: " . join(',', @candidates));
    return $candidates[0]; # Return first valid candidate
}

# =========================================================
# MOVE ENGINE
# =========================================================
sub move_piece {
    my ($move) = @_;
    return 0 unless $move;

    $move =~ s/[+#]//g; # strip check/mate
    my $white = ($turn eq 'w');

    # Castling
    if ($move eq 'O-O') {
        if ($white) {
            delete $board{'e1'}; $board{'g1'}='K';
            delete $board{'h1'}; $board{'f1'}='R';
        } else {
            delete $board{'e8'}; $board{'g8'}='k';
            delete $board{'h8'}; $board{'f8'}='r';
        }
        return 1;
    }
    if ($move eq 'O-O-O') {
        if ($white) {
            delete $board{'e1'}; $board{'c1'}='K';
            delete $board{'a1'}; $board{'d1'}='R';
        } else {
            delete $board{'e8'}; $board{'c8'}='k';
            delete $board{'a8'}; $board{'d8'}='r';
        }
        return 1;
    }

    # Pawn Promotion
    my $promo;
    if ($move =~ /=([QRBN])$/) {
        $promo = $1;
        $move =~ s/=[QRBN]$//;
    }

    # Normal moves
    my ($piece, $dis, $cap, $dest);
    if ($move =~ /^([KQRBN])?([a-h]?[1-8]?)(x?)([a-h][1-8])$/) {
        ($piece, $dis, $cap, $dest) = ($1, $2, $3, $4);
    } elsif ($move =~ /^([a-h])x([a-h][1-8])$/) {
        # Pawn capture (e.g., dxe4)
        ($piece, $dis, $cap, $dest) = ('P', $1, 'x', $2);
    } elsif ($move =~ /^([a-h][1-8])$/) {
        # Pawn push (e.g., e4)
        ($piece, $dis, $cap, $dest) = ('P', '', '', $1);
    } else {
        return 0;
    }

    $piece ||= 'P';
    my $sym = $white ? uc($piece) : lc($piece);
    my $from = find_piece($sym, $dest, $dis, $cap ? 1 : 0);

    return 0 unless $from;

    # En Passant detection
    if ($piece eq 'P' && $cap && !$board{$dest}) {
        my ($df, $dr) = $dest =~ /([a-h])([1-8])/;
        my $ep_rank = $white ? $dr - 1 : $dr + 1;
        delete $board{"$df$ep_rank"};
    }

    delete $board{$from};
    $board{$dest} = $promo ? ($white ? uc($promo) : lc($promo)) : $sym;
    return 1;
}

sub step_moves {
    return 0 unless @moves;
    my $m = shift @moves;
    $move_index++;

    my $display_idx = int(($move_index + 1) / 2);
    my $prefix = ($move_index % 2 != 0) ? "$display_idx. " : "";
    say_line("Move: $prefix$m");

    if (move_piece($m)) {
        print_board();
        $turn = $turn eq 'w' ? 'b' : 'w';
    } else {
        say_line(">>> FAILED MOVE: $m");
        say_line("Full PGN: $current_pgn");
        return 0;
    }
    return 1;
}

sub cmd_pgn {
    my ($data, $server, $item) = @_;
    if (!$item || $item->{type} ne 'CHANNEL') {
        Irssi::print("Use this command in a channel.");
        return;
    }
    $witem = $item;
    init_board();
    $current_pgn = $data;

    # Parse PGN tokens
    $data =~ s/\{.*?\}//g; # remove comments
    my @tokens = split(/\s+/, $data);
    @moves = grep { $_ !~ /^\d+\./ && $_ !~ /^(1-0|0-1|1\/2-1\/2)$/ && $_ ne '' } @tokens;

    if ($timer) { Irssi::timeout_remove($timer); }
    $timer = Irssi::timeout_add(50, sub {
        if (!@moves) {
            say_line("Finished. Full PGN: $current_pgn");
            Irssi::timeout_remove($timer);
            $timer = undef;
            return;
        }
        if (!step_moves()) {
            Irssi::timeout_remove($timer);
            $timer = undef;
        }
    }, undef);
}

Irssi::command_bind('pgn', 'cmd_pgn');
Irssi::print("Chess PGN viewer loaded. Use /pgn [moves]");