#!/usr/bin/perl -w

use strict;

our $black = '0 0 0 1 setcmykcolor';

my $pumpkin = ["0 .50 0 1.00 0", "0 0 0 1"];
my $green = ["1 0 1 0", "0 0 0 0"];
my $red = ["0 1 1 0", "0 0 0 1"];
my $blue = ["0.6 0.6 0 0", "0 0 0 0"];
my $yellow = ["0 0 1 0", "0 0 0 1"];
my $moth = ["0 0 0 1", "0 0 0 0"];
my $purple = ["0 1 0 0", "0 0 0 1"];

sub chip ($$) {
  my ($cary, $pips) = @_; # put in a gsave translate
  my $o = <<END;
  newpath
  0 0 chip 0.5 mul 0 360 arc
  gsave 1 setlinewidth $black stroke grestore
  $cary->[0] setcmykcolor fill
  $cary->[1] setcmykcolor
END
  my $spot = sub {
    my ($x,$y) = @_;
    $o .= <<END;
    newpath
    spot 0.5 sqrt mul 1.1 mul dup
    $x mul exch $y mul
    spot 0.5 mul
    0 360 arc fill
END
  };

  $spot->( 0, 0) if $pips & 1;
  $spot->(-1,-1) if $pips & 6;
  $spot->(+1,+1) if $pips & 6;
  $spot->(-1,+1) if $pips & 4;
  $spot->(+1,-1) if $pips & 4;

  $o;
}

sub anychip ($) {
  my ($pips) = @_;
  my $fsz = 10;
  <<END;
gsave
  chip -0.5 mul  $fsz -0.30 mul  moveto
  /Helvetica-Bold findfont $fsz scalefont setfont
  (Any) dup stringwidth  3 2 roll show
  pop pop
  20 0 translate
  ${\ chip(['0 0 0 0.5', '0 0 0 0'], $pips) }
grestore
END
}

sub ruby () { # put in gsave translate
  <<END;
  newpath
    rubysz neg  0 moveto
    0  rubysz neg lineto
    rubysz      0 lineto
    0      rubysz lineto
    closepath
    0 1 0.5 0 setcmykcolor gsave fill grestore
    $black 1 setlinewidth stroke
END
}

sub exposition ($) {
  my ($text) = @_;
  my $fontsz = 6;
  my $o = <<END;
    /Times-Roman findfont $fontsz scalefont setfont $black
END
  $text =~ s/\n$//;
  my @lines = split /\n/, $text;
  foreach my $y (0..$#lines) {
    my $l = $lines[$y];
    $l =~ s/[()\\]/\\$&/g;
    my $yd = $fontsz * (0.5*@lines - $y);
    $o .= <<END;
    0 0.70 dc moveto
    0 $yd rmoveto
    ($l)  dup stringwidth pop -0.5 mul 0 rmoveto
    show
END
  }
  $o;
}


sub general_book ($$) { # put in a gsave
  my ($this, $costs) = @_;
  my $o = <<END;
tw  0  translate

3 setlinewidth
0 0 0 0.2 setcmykcolor
newpath
0 0 dc moveto
0 1 dc lineto stroke

$black
1 setlinewidth

newpath
-1 0  dc moveto
+1 0  dc lineto
+1 1  dc lineto
-1 1  dc lineto
closepath stroke

newpath
0 0 dc         moveto
0 thirdlineh dc rlineto
-1 thirdlineh dc lineto stroke

/thirddivline {               % xprop
  newpath
  dup -3 div  0               dc moveto
      -3 div  thirdlineh      dc lineto stroke
                              %
} def

1 thirddivline
2 thirddivline

END

  foreach my $costi (0..2) {
    my $cost = $costs->[$costi];
    my $pips = qw(1 2 4)[$costi];
    $o .= <<END
  costfont setfont
  -2.5 $costi add 3 div
gsave
  dup costcirch dc translate
  ${\ chip($this,$pips) }
grestore
  costtexth exch costtextdx add exch dc moveto
  $black
  ($cost)
  dup stringwidth pop  -0.5 mul  costtextsz neg  rmoveto
  show
END
  }

  $o;
}
  
sub green_book () {
  my $o = general_book($green, [qw(5 9 15)]);

  $o .= <<END;
gsave 0.25 0.15 dc translate ${\ chip($pumpkin,0) } grestore
gsave 0.25 0.40 dc translate ${\ chip($green,0) } grestore

/Times-Bold findfont
dup
  6 scalefont setfont
  0.40 0.17 dc moveto (last) show
%
  8 scalefont setfont
  0.40 0.09 dc moveto (3) show
/Times-Roman findfont
  38 scalefont setfont
  0.45 0.14 dc moveto (}) show

gsave
  0.85 0.275 dc translate
  ${\ ruby() }
grestore
END

  $o .= exposition(<<END);
For each pumpkin in the last 3 chips,
receive 1 ruby.
But, not more rubies than the number
of green chips in your pot.
END

  $o;
}
  
sub red_book () {
  my $o = general_book($red, [qw(4 9 16)]);

  $o .= <<END;
gsave 0.35 0.30 dc translate ${\ chip($pumpkin,0) } grestore

/Times-Bold findfont
  15 scalefont setfont
  0.50 0.24 dc moveto (+1) show

END

  $o .= exposition(<<END);
The next 1/2/4 pumpkins you place are
each moved one extra space.
(After applying any other special effects;
one extra space no matter how many reds)
END

  $o;
}

sub blue_book () {
  my $o = general_book($blue, [qw(4 9 16)]);

  $o .= <<END;
/Times-Bold findfont 15 scalefont setfont $black
END

  my $exchip = sub {
    my ($that, $pips) = @_;
    <<END;
  gsave ${\ chip($that, $pips) } grestore
END
  };
  my $exslash = sub {
    <<END;
    8 -5 moveto (/) show
    20 0 translate
END
  };
  
  my $exchline = sub {
    my ($y, $pips, $content) = @_;
    <<END;
gsave 
  0.16 0.15 0.16 $y mul add dc translate
  0.60 dup scale
  gsave ${\ chip($blue,$pips) } grestore
  8 -3 moveto (:) show
  3 0 translate
  0.8 dup scale
  21 0 translate
$content
grestore

gsave
  0.50 0.65 dc translate
  0.65 dup scale
  gsave -10 0 translate ${\ chip($pumpkin,1) } grestore
  arrow
grestore
END
  };

  $o .= $exchline->(2, 1, <<END);
  ${\ $exchip->($green,1) }  ${\ $exslash->() }
  ${\ $exchip->($red,  1) }  ${\ $exslash->() }
  ${\ $exchip->($blue, 1) }  ${\ $exslash->() }
  ${\ $exchip->($yellow, 1) }
END

  $o .= $exchline->(1, 2, <<END);
  ${\ $exchip->($moth,1) }  ${\ $exslash->() }
  ${\ $exchip->($purple,1) }  ${\ $exslash->() }
  ${\ anychip(2) }
END

  $o .= $exchline->(0, 4, <<END);
  ${\ anychip(4) }
END

  $o .= exposition(<<END);
If the previous chip placed was a pumpkin,
you may exchange it as follows:

 
END

  $o;
}

sub tile {
  my $pos = 0;
  my $o = '';
  my $showpage = sub {
    $o .= <<END;
showpage
END
  };
  while (my $d = shift @_) {
    if ($pos >= 5) {
      $pos -= 5;
      $showpage->();
    }
    $o .= <<END;
gsave
END
    if ($pos < 3) {
      $o .= <<END
        0   th 10 add  $pos mul  translate
END
    } else {
      $o .= <<END
tw 2 mul 7 add
   dup    th add  0 translate
   90 rotate
   $pos 3 sub mul  0 translate
END
    }
    $o .= "\n".$d."\n";
    $o .= <<END;
grestore
END
    $pos++;
  }
  $showpage->();
  $o;
}

print <<END or die $!;
%!

72 25.4 div dup scale
%210 0 translate
%90 rotate
7 10 translate

/tw 57.5 def
/th 73 def
/bdiag 5 def
/thirdlineh 0.45 def
/costcirch 0.3 def
/chip 15 def
/spot 3.5 def
/arrowlen 6 def
/arrowhead 3 def

/costtexth 0.215 def
/costtextsz 12 def
/costtextdx -0.03 def
/costfont /Heletica-BoldOblique findfont costtextsz scalefont def

/rubysz 4 def

% diagonal conversion
/dc {                    % xprop yprop
    dup th mul           % xprop yprop y
    3 1 roll             % y xprop yprop
    bdiag mul neg        % y xprop x-margin-at-this-height
    tw add               % y xprop x-width-at-this-height
    exch mul             % y x-width-at-this-height xprop
    exch                 % x y
} def

/arrow {
  $black 1 setlinewidth
    newpath
       0 0 moveto  arrowlen 0 rlineto
       arrowhead dup neg exch  rmoveto
       arrowhead dup neg       rlineto
       arrowhead neg dup       rlineto
       stroke
} def

END

print tile(
	   green_book(),
	   red_book(),
	   blue_book(),
	  ) or die $! if 1;
