#!/usr/bin/perl
use strict;
use Storable qw(dclone nstore lock_nstore retrieve lock_retrieve);

# Define text constants for ease of maintenance
use constant PROMPT1 => "Command ('h' for help): ";
use constant PROMPT2 => "Answer 'y' for yes or 'n' for no: ";

use constant I_DEALING => 'Dealing cards...';
use constant I_UNDOING => 'Undoing last move...';
use constant I_LOADING => "Trying to load from '%s'";
use constant I_SAVING => "Trying to save to '%s'...";
use constant I_SAVING_OVER => "Trying to save over '%s'";
use constant I_SAVE_OK => 'Save complete';
use constant I_NOTSAVING => "Not saving over '%s'";
use constant I_HAS_READLINE => 'Using Term::ReadLine';
use constant I_NO_READLINE => 'No readline enabled';
use constant I_LOAD_NEEDS_FILE => 'You need to supply a filename to load';
use constant I_SAVE_NEEDS_FILE => 'You need to supply a filename to save';

use constant Q_QUIT => 'Are you sure you want to quit - the current game will be lost?';
use constant Q_LOAD => 'Loading a game will delete the current game. Are you sure?';
use constant Q_DEAL => 'Dealing a new game will delete the current game. Are you sure?';
use constant Q_REPLAY => 'Replaying a saved game will delete the current game. Are you sure?';
use constant Q_EXEC => 'Re-executing will delete the current game. Are you sure?';
use constant Q_OVERWRITE => "File '%s' exists already. Do you want to overwrite it?";

use constant E_UNREC => "Unrecognized command '%s' or bad syntax. Type 'h', then hit Return, for help";
use constant E_ILLEGALMOVE => 'Illegal move';
use constant E_NOUNDO => 'Cannot undo - no levels of undo left!';
use constant E_SAVING => "Problem while saving '%s': %s";
use constant E_LOADING => "Problem while loading '%s': %s";
use constant E_BADCOL => "Column must be from 1 to 7 - you said %s";
use constant E_BADCOL2 => "Columns must be from 1 to 7 - you said %s and %s";

use constant E_NOTHING_TO_MOVE => "No card to move";
use constant E_NO_DEST_CARD => "No card to put that down onto";
use constant E_NO_EXEC => 'Cannot re-execute on this platform';

use vars qw(%Settable $has_readline $rl
@SUITS @VALUES %collut %ansioffset %nextcard
@UNDO @cards @cols %aces $deckptr
$VERSION
$is_mac_classic
);

$| = 1;
($VERSION) = ('$Revision: 1.2 $' =~ /([\d\.]+)/);

# derive flags for OS here
if ($^O eq 'MacOS') {
    $is_mac_classic = 1;
}

# to start with, can we offer the user a nicer interface?
eval {
    require Term::ReadLine;
    $rl = new Term::ReadLine or die 'do not care';
    $has_readline = 1;
};

# some static data
@SUITS = qw(♠ ♣ ♦ ♥);
@VALUES = qw(A 2 3 4 5 6 7 8 9 T J Q K);
%collut = (
    $SUITS[0] => 'black',
    $SUITS[1] => 'black',
    $SUITS[2] => 'red',
    $SUITS[3] => 'red',
);
%ansioffset = (
    'black' => 0,
    'red' => 1,
    'green' => 2,
    'yellow' => 3,
    'blue' => 4,
    'magenta' => 5,
    'cyan' => 6,
    'white' => 7,
);

my @tmp = @VALUES;
while (@tmp > 1) {
    my $l = shift @tmp;
    my $h = shift @tmp;
    $nextcard{$h} = $l;
    unshift @tmp, $h;
}

%Settable = (
    replaydelay => 0.3,
    trace => 0,
    pid => $$,
);

warning("klondike $VERSION");
if ($has_readline) {
    warning(I_HAS_READLINE);
} else {
    warning(I_NO_READLINE);
}

_init();
redisplayall();

# main command loop
while (1) {
    # prompt for and read a command
    my $rcommand = get_a_line(PROMPT1);

    $rcommand =~ s/^\s+//g;
    $rcommand =~ s/\s+$//g;
    TRACE("read command '$rcommand'");

    # parse the command
    my ($command, @args);
    if ($rcommand =~ /^\S+$/) {
        $command = $rcommand;
    } elsif ($rcommand =~ /^(\w+)\s+(\w+)\s+(.+)$/) {
        ($command, @args) = ($1, $2, $3);
    } elsif ($rcommand =~ /^(\w+)\s+(.+)$/) {
        ($command, @args) = ($1, $2);
    } else {
        $command ||= '';
    }
    TRACE("Parsed command to <$command> ". (@args? '<'.join('> <', @args).'>' : ''));

    # decide what to do
    if ($command eq '') {
        # nothing
    } elsif ($command eq 'q' or $command eq 'quit' or $command eq 'exit') {
        if (ask_yn(Q_QUIT)) {
            exit;
        }
    } elsif ($command eq 'q!') {
        exit;
    } elsif ($command eq 't') {
        turncard();
    } elsif ($command eq 'h' or $command eq 'help') {
        showhelp();
    } elsif ($command eq 'r') {
        redisplayall();
    } elsif ($command =~ /^d(\d)$/) {
        deck_to_col($1);
    } elsif ($command eq 'da') {
        deck_to_aces();
    } elsif ($command =~ /^(\d)a$/) {
        column_to_aces($1);
    } elsif ($command =~ /^1(\d)(\d)$/) {
        column_to_column_1($1, $2);
    } elsif ($command =~ /^s(\d)(\d)$/) {
        column_to_column_stack($1, $2);
    } elsif ($command eq 'deal') {
        if (ask_yn(Q_DEAL)) {
            warning(I_DEALING);
            _init();
            redisplayall();
        }
    } elsif ($command eq 'undo') {
        warning(I_UNDOING);
        undo_restore();
    } elsif ($command eq 'save') {
        if (@args) {
            file_save(@args);
        } else {
            warning(I_SAVE_NEEDS_FILE);
        }
    } elsif ($command eq 'load') {
        if (@args) {
            if (ask_yn(Q_LOAD)) {
                file_load(@args);
            }
        } else {
            warning(I_LOAD_NEEDS_FILE);
        }
    } elsif ($command eq 'replay') {
        if (@args) {
            if (ask_yn(Q_REPLAY)) {
                file_load(@args);
                my @state = @UNDO;
                @UNDO = ();
                while (@state) {
                    @UNDO = shift @state;
                    undo_restore();
                    select(undef, undef, undef, 0.3);
                }
            }
        } else {
            warning(I_LOAD_NEEDS_FILE);
        }
    } elsif ($command eq 'set') {
        $Settable{$args[0]} = $args[1];
    } elsif ($command eq 'show') {
        my @l = $args[0];
        if ($args[0] eq 'all') { @l = sort keys %Settable; }
        foreach (@l) {
            print "- Variable '$_' is '$Settable{$_}\n";
        }
    } elsif ($command eq 'reexec') {
        if ($is_mac_classic) {
            warning(E_NO_EXEC);
        } else {
            if (ask_yn(Q_EXEC)) {
                exec($0, @ARGV);
            }
        }
    } else {
        warning(E_UNREC, $command);
    }
}

### Subroutines

### General interface subs
sub ask_yn {
    my $prompt = shift || 'Internal Error: no prompt given!';
    warning($prompt);
    my $x = get_a_line(PROMPT2);
    $x = lc($x);
    if ($x eq 'y') {
        return 1;
    } else {
        return 0;
    }
}

sub get_a_line {
    my $pr = shift;
    if ($has_readline) {
        return $rl->readline($pr);
    } else {
        print $pr;
        my $x = <STDIN>;
        chomp $x;
        return $x;
    }
}

sub showhelp {
    print q{-- Klondike Command Line

Column are numbered 1 to 7, left to right

Interactive commands:
h or help - help
q or quit or exit - quit ('q!' immediately quits)
deal - restarts the game
undo - undoes the last move (repeat as often as required)
save n - saves the current game as file 'n'
load n - loads the game 'n'
replay n - loads the saved game 'n' and plays it onscreen noninteractively
set x y - sets the value of variable x to be y (y may be ommitted to clear the variable)
show x - display the value of variable x
show all - display all variables
reexec - re-execute the program

t - turn a card on the deck
r - redisplay the playing field
d# - move 1 card off deck to column #
da - move 1 card off the deck to aces
#a - move 1 card from column # to aces
1#* - move 1 card from column # to column *
s#* - move the stack in column # to column *

};
}

sub _init {
    # this is the undo stack
    @UNDO = ();

    # this is the deck
    @cards = ();

    # this is the playing area
    @cols = ([], [], [], [], [], [], []);

    # these are the Ace holders
    %aces = ( $SUITS[0] => [], $SUITS[1] => [], $SUITS[2] => [], $SUITS[3] => [] );

    # this keeps track of where you are in the deck
    $deckptr = 0;

    # create the deck in order...
    for my $suit (@SUITS) {
        for my $num (@VALUES) {
            push @cards, { 'suit' => $suit, 'value' => $num, 'hid' => 1 };
        }
    }

    # shuffle it
    fisher_yates_shuffle( \@cards );
    my $str;
    foreach (@cards) { $str .= " $_->{value}$_->{suit}"; }
    TRACE("Deck $str");

    # deal into the usual pattern
    my $i = 7;
    while ($i) {
        for my $j ((@cols-$i)..$#cols) {
            my $card = pop @cards;
            if ($j == (@cols-$i)) { $card->{'hid'} = 0; }
            push @{ $cols[$j] }, $card;
        }
        $i--;
    }
    foreach (@cards) { $_->{'hid'} = 0; }
}

### Undo operations
sub undo_save {
    my $state = {
        cards => dclone(\@cards),
        cols => dclone(\@cols),
        aces => dclone(\%aces),
        deckptr => $deckptr,
    };
    push @UNDO, $state;
}

sub undo_restore {
    if (@UNDO) {
        my $state = pop @UNDO;
        @cards = @{ $state->{'cards'} };
        @cols = @{ $state->{'cols'} };
        %aces = %{ $state->{'aces'} };
        $deckptr = $state->{'deckptr'};

        redisplayall();
    } else {
        warning(E_NOUNDO);
    }
}

### File operations
sub file_save {
    my $f = shift;
    warning(I_SAVING, $f);

    if (-e $f) {
        if (ask_yn(sprintf(Q_OVERWRITE, $f))) {
            warning(I_SAVING_OVER, $f);
        } else {
            warning(I_NOTSAVING, $f);
            return;
        }
    }
    undo_save();
    eval {
        if ($is_mac_classic) {
            nstore(\@UNDO, $f);
        } else {
            lock_nstore(\@UNDO, $f);
        }
        warning(I_SAVE_OK);
    };
    if ($@) {
        chomp $@;
        $@ =~ s/ at \S+ line \d+$//;
        warning(E_SAVING, $f, $@);
    }
    pop @UNDO;
}

sub file_load {
    my $f = shift;
    warning(I_LOADING, $f);
    eval {
        my $r;
        if ($is_mac_classic) {
            $r = retrieve($f);
        } else {
            $r = lock_retrieve($f);
        }

        @UNDO = @$r;
        undo_restore();
    };
    if ($@) {
        chomp $@;
        $@ =~ s/ at \S+ line \d+$//;
        warning(E_LOADING, $f, $@);
    }
}

### Card movement logic
sub _can_card_col {
    my ($topcard, $destcol) = @_;

    my $flag = 0;
    if ($topcard) {
        my $botcard = get_top($destcol);
        if ($botcard) {
            my $topcol = $collut{ $topcard->{'suit'} };
            my $botcol = $collut{ $botcard->{'suit'} };

            my $topval = $topcard->{'value'};
            my $botval = $botcard->{'value'};

            if (($topcol ne $botcol) && ($nextcard{$botval} eq $topval)) {
                $flag = 1;
            } else {
                warning(E_ILLEGALMOVE);
            }
        } elsif ($topcard->{'value'} eq $VALUES[-1]) {
            $flag = 1;
        } else {
            warning(E_NO_DEST_CARD);
        }
    } else {
        warning(E_NOTHING_TO_MOVE);
    }
    return $flag;
}

sub _can_card_aces {
    my $topcard = shift;

    my $flag = 0;
    if ($topcard) {
        my $botcard = get_top_ace($topcard->{'suit'});
        if ($botcard) {
            my $topval = $topcard->{'value'};
            my $botval = $botcard->{'value'};

            if ($nextcard{$topval} eq $botval) {
                $flag = 1;
            } else {
                warning(E_ILLEGALMOVE);
            }
        } else {
            if ($topcard->{'value'} eq $VALUES[0]) {
                $flag = 1;
            } else {
                warning(E_NO_DEST_CARD);
            }
        }
    } else {
        warning(E_NOTHING_TO_MOVE);
    }
    return $flag;
}

### Card movement entry points
sub turncard {
    undo_save();
    $deckptr++;
    if ($deckptr > @cards) {
        $deckptr = 0;
    }
    show_deck();
}

sub column_to_column_1 {
    my ($f, $t) = @_;
    if ($f < 1 or $f > 7 or $t < 1 or $t > 7) {
        warning(E_BADCOL2, $f, $t);
    } else {
        $f--; $t--;
        my $topcard = get_top($f);
        if (_can_card_col($topcard, $t)) {
            undo_save();
            my $card = pop @{ $cols[$f] };
            push @{ $cols[$t] }, $card;
            expose($f);
            redisplayall();
        }
    }
}

sub column_to_column_stack {
    my ($f, $t) = @_;
    if ($f < 1 or $f > 7 or $t < 1 or $t > 7) {
        warning(E_BADCOL2, $f, $t);
    } else {
        $f--; $t--;
        my ($topcard, $runlength) = get_top_stack($f);
        if (_can_card_col($topcard, $t)) {
            undo_save();
            my @movecard;
            for (1..$runlength) {
                unshift @movecard, pop @{ $cols[$f] };
            }
            push @{ $cols[$t] }, @movecard;
            expose($f);
            redisplayall();
        }
    }
}

sub column_to_aces {
    my $col = shift;
    if ($col < 1 or $col > 7) {
        warning(E_BADCOL, $col);
    } else {
        $col--;

        my $topcard = get_top($col);
        if (_can_card_aces($topcard)) {
            my $suit = $topcard->{'suit'};

            undo_save();
            my $card = pop @{ $cols[$col] };
            push @{ $aces{$suit} }, $card;
            expose($col);
            redisplayall();
        }
    }
}

sub deck_to_aces {
    my $topcard;
    if (@cards && $deckptr < @cards) {
        $topcard = $cards[$deckptr];
    }

    if (_can_card_aces($topcard)) {
        my $suit = $topcard->{'suit'};
        undo_save();
        my $card = splice @cards, $deckptr, 1;
        push @{ $aces{$suit} }, $card;
        show_aces();
        show_deck();
    }
}

sub deck_to_col {
    my $col = shift;
    if ($col < 1 or $col > 7) {
        warning(E_BADCOL, $col);
    } else {
        $col--;
        my $topcard;
        if (@cards && $deckptr < @cards) {
            $topcard = $cards[$deckptr];
        }

        if (_can_card_col($topcard, $col)) {
            undo_save();
            my $card = splice @cards, $deckptr, 1;
            push @{ $cols[$col] }, $card;
            redisplayall();
        }
    }
}

### Card housekeeping
sub get_top {
    my $n = shift;
    my $column = $cols[$n];
    if (@$column) {
        return $column->[-1];
    } else {
        return undef;
    }
}

sub get_top_stack {
    my $n = shift;
    my $column = $cols[$n];
    if (@$column) {
        my $i = 1;
        my $len;
        while (($column->[-1*$i]) && (! $column->[-1*$i]->{'hid'})) {
            $len = $i++;
        }
        return ($column->[-1*$len], $len);
    } else {
        return (undef);
    }
}

sub expose {
    my $n = shift;
    my $col = $cols[$n];
    if (@$col) {
        $col->[-1]->{'hid'} = 0;
    }
}

sub get_top_ace {
    my $s = shift;
    my $column = $aces{$s};
    if (@$column) {
        return $column->[-1];
    } else {
        return undef;
    }
}

### Display to screen routines
sub redisplayall {
    print "\033[2J";    #clear the screen
    print "\033[0;0H"; #jump to 0,0
    print '-'x50;
    print "\n";
    show_aces();
    show_deck();
    show_cards();
    my $n = @UNDO;
    print "You have $n levels of undo\n";
    print '-'x50;
    print "\n";
}

sub show_aces {
    print "Aces:";
    for (@SUITS) {
        print ' ';
        my $stack = $aces{$_};
        if (@$stack) {
            print_card( $stack->[-1] );
        } else {
            print_empty_place();
        }
    }
    print "\n";
}

sub show_deck {
    print "Deck: ";
    if (@cards) {
        my $lhs = @cards - $deckptr;
        my $rhs = $deckptr;

        print "($lhs) ";
        if ($deckptr == @cards) {
            print_empty_place();
        } else {
            print_card($cards[$deckptr]);
        }

        print ' -> ';

        if ($deckptr == 0) {
            print_empty_place();
        } else {
            print_hidcard();
        }
        print " ($rhs)";
    } else {
        print '(0) ';
        print_empty_place();
        print ' -> ';
        print_empty_place();
        print ' (0)';
    }
    print "\n";
}

sub show_cards {
    for my $col (1..7) { print " $col "; }
    print "\n";

    my $flag = 1;
    ROW: for my $row (0..19) {
        $flag = 0;
        for my $col (0..6) {
            print ' ';
            if (defined $cols[$col][$row]) {
                $flag++;
                print_card($cols[$col][$row]);
            } else {
                print_card(undef)
            }
        }
        print "\n";
        last ROW unless $flag;
    }
    for my $col (1..7) { print " $col "; }
    print "\n";
}

### Routines which print non-trivially to the screen
sub print_card {
    my $card = shift;

    if ($card) {
        if ($card->{'hid'}) {
            print_hidcard();
        } else {
            print colourstring("$card->{value}$card->{suit}", 'white', $collut{ $card->{'suit'} } );
        }
    } else {
        print '  ';
    }
}

sub print_hidcard {
    print colourstring('🎴', 'white', 'green');
}

sub print_empty_place {
    print colourstring('--', 'white', 'blue');
}

sub warning {
    my $str;
    if (@_ > 1) {
        my $f = shift;
        $str = sprintf($f, @_);
    } else {
        $str = shift;
    }
    print colourstring("! ", 'red', 'black')."$str\n";
}

sub colourstring {
    if ($is_mac_classic) {
        return $_[0];
    } else {
        return _ansi_colourstring(@_);
    }
}

sub _ansi_colourstring {
    my ($s, $fg, $bg)  = @_;
    $fg = 30 + $ansioffset{$fg};
    $bg = 40 + $ansioffset{$bg};
    return "\033[0m\033[${fg}m\033[${bg}m$s\033[0m";
}

### Utilities
sub fisher_yates_shuffle { # from perldoc
    my $deck = shift;
    my $i = @$deck;
    while ($i--) {
        my $j = int rand ($i+1);
        @$deck[$i,$j] = @$deck[$j,$i];
    }
}

sub TRACE {
    return unless $Settable{'trace'};
    my $m = shift;
    print "<TRACE> $m\n";
}

=pod

=head1 NAME

klondike.pl - play the Klondike solitaire card game on the command line

=head1 SYNOPSIS

    klondike.pl

No command line options.

=head1 DESCRIPTION

Play "klondike" solitaire card game in text mode. You can undo moves, save games, restore games, and even replay old
games. Colour is used where available.

There are 7 columns of cards in the main area of play, 4 spaces for stacking up each suit, and a stack of cards that you
turn one at a time. In the main field of play you alternate black and red cards, placing lower cards on top
of higher cards. In the spaces for each suit you put down the ace first, and follow with cards in ascending order.
If you want to move cards around the 7 columns of cards you can move either the uppermost card, or the entire run
of face-up cards. If you've played solitaire before this should be pretty standard.

The state of play is presented graphically using ASCII characters, using colour where available.

Card values are denoted like this, in ascending order: A 2 3 4 5 6 7 8 9 T J Q K

Card suits are: S (spades) H (hearts) C (clubs) D (diamonds)

This program uses Term::ReadLine where available for friendlier interaction, with free command history.

You tell the program what to do by entering simple, albeit terse, commands. Type 'h' or 'help' at the prompt
to get a full list of commands. See below for examples.

WARNING: as with any program that saves files, take care not to overwrite anything else when
writing files (e.g. saving a game)

=head1 EXAMPLE COMMANDS

=over 4

=item save filename.klon

Saves the current state of play to the given filename as a Storable file. Take care not to overwrite existing files.

=item t

Turn over one card on the stack of cards.

=item d3

Move the exposed card on the stack to column number 3 in the main field of play.

=item 4a

Move the card at the top of column 4 onto one of the 4 stacks of cards which start with Aces.

=item 175

Move the top card on column 7 to the top of column 5.

=item s26

Move the run of upturned cards in column 2 onto column 6.

=item q

Quit the program.

=back

=head1 DISPLAY

Here are some examples of what you'll see on screen, and their meanings:

    Aces: -- -- -- --

These are the 4 stacks in which you build up each suit. Aces go down first, then 2's and so on. This
arrangement:

    Aces: 3S 2H -- --

Shows that we have placed the Ace, 2 and 3 of Spades, and the Ace and 2 of Hearts.

    Deck: (20) 5H -> // (3)

This is your deck of cards that you can go through one at a time. The numbers in parentheses show the
number of cards on each side - there are 20 cards on the side from which you turn cards, and 3 cards on the
side which turned cards go onto. So, we have a 5 of Hearts face up, and you can see the back of a card, '//',
which was the one we have just moved across.

This is the main area of play:

    . 1  2  3  4  5  6  7
    . TC // // // // // //
    . 9D JS // // // // //
    .    TD 3S 8C // // //
    .          7H // // //
    .          6S 2D // //
    .                AS 5S

There are the 7 columns of cards. The run of 3 upturned cards in column 4, starting at the 8 of Clubs,
could be moved onto the 9 of Diamonds in column 1.
The 1 card at the top of column 5, 2 of Diamonds, could move onto column 3 (which has a 3 of Spades).
The Ace of Spades at the top of column 6 could move off to the Spades stack to start building up that suit.

=head1 PREREQUISITES

Storable.

=head1 COREQUISITES

None.

=begin comment

=pod OSNAMES

any

=pod SCRIPT CATEGORIES

Games

=pod README

Play the Klondike solitaire card game on the command line, in text mode. Tested on MacOS, Solaris and Linux.

=end comment

=head1 COPYRIGHT

Copyright P Kent 2003. This is distributed under the same terms as perl itself.

=head1 VERSION

$Revision: 1.2 $

=cut