[quacks.git] / pumpkin-books.ps.pl

#!/usr/bin/perl -w
# Books of Pumpkins, etc.  Extensions to Quacks of Quedlinburg
#  SPDX-License-Identifier: GPL-3.0-or-later OR CC-BY-SA-4.0
# Copyright 2020-2021 Ian Jackson

use strict;

BEGIN { unshift @INC, '.'; }
use Quacks;

my $anychip = ['0.8', '0'];

our $page_pre = <<END;
72 25.4 div dup scale
%210 0 translate
%90 rotate
7 30 translate
END

sub colour ($) {
  my ($c) = @_;
  if ($c =~ m{^(\d+)/(\d+)/(\d+)$}) {
    return (join ' ', map { $_ / 255.0 } ($1,$2,$3)).' setrgbcolor';
  } elsif ($c =~ m/[^ 0-9.]/) {
    return $c;
  } elsif ($c =~ m/^\s*\S+\s*$/) {
    return "$c setgray";
  } elsif ($c =~ m/./) {
    return "$c setrgbcolor";
  } else {
    return '';
  }
}

our $black = colour('0');

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
  ${\ colour($cary->[0]) } fill
END
  if ($pips) {
    $o .= <<END;
  ${\ colour($cary->[1]) }
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 veepsspot ($) {
  my ($chip) = @_;
  <<END;
gsave
  0 chip -0.5 mul translate
  $black
  newpath 0 0 chip 0.5 mul 0 360 arc stroke
  /Times-Bold findfont 7 scalefont setfont
  -1 -5 translate
  0 0 moveto (?) show
  newpath
   -1 -1 moveto 6 0 rlineto 0 7 rlineto -6 0 rlineto
    closepath 0.5 setlinewidth stroke
grestore
  $chip
END
}

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($anychip, $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
    ${\ colour('1 .2 .2') } 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 num_players ($;$) {
  my ($n, $plus) = @_;
  my $o = '';

  $o .= <<END;
  gsave
    -0.94 0.50 dc translate
    0.3 dup scale
END

  $o .= <<END x $n;
    pot_image 18 0 translate
END

  $o .= <<END if defined $plus;
    -9 -5 moveto
    /Helvetica-Bold findfont 25 scalefont setfont
    ($plus) show
END

  $o .= <<END;
  grestore
END
  return $o;
}

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

3 setlinewidth
0.9 setgray
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

END

  $o .= <<END if @$costs == 3;
1 thirddivline
2 thirddivline
END

  foreach my $costi (0..2) {
    my ($cost, $pips);
    if (@$costs == 3) {
      $cost = $costs->[$costi];
      $pips = qw(1 2 4)[$costi];
    } else {
      next unless $costi == 1;
      $cost = $costs->[0];
      $pips = $costs->[1];
    }
    $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 book_green () {
  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 book_red () {
  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 book_blue () {
  my $o = general_book($blue, [qw(4 10 18)]);

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

gsave
  0.50 0.65 dc translate
  0.65 dup scale
  gsave -10 0 translate ${\ chip($pumpkin,0) } grestore
  arrow
grestore
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
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 book_lotus () {
  my $o = general_book($lotus, [8, 0]);

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

gsave
  0.36 0.38 dc translate
  0.80 dup scale
  gsave ${\ chip($lotus,0) } grestore

  9 -4 moveto (=) show
grestore
gsave
  0.20 0.15 dc translate
  0.80 dup scale
  gsave ${\ chip($pumpkin,0) } grestore
  chip 0.5 mul 0 translate
  gsave ${\ chip($pumpkin,0) } grestore

  10 -4.5 moveto (... +1) show

grestore
END
<<END;
gsave
  0.16 0.20  dc translate
  0.60 dup scale

  gsave ${\ veepsspot(chip($pumpkin, 0)) } grestore
  gsave 0 20 translate ${\ chip($purple, 1) } grestore
  27 0 translate
grestore
END


  $o .= exposition(<<END);
The value of this chip is
1 higher than the number of pumpkins
previously placed in the pot (but max.4)
END

  $o;
}

sub book_purple () {
  my $o = general_book($purple, [10, 1]);

  my $input = <<END;
  gsave ${\ veepsspot(chip($pumpkin, 0)) } grestore
  gsave 0 20 translate ${\ chip($purple, 1) } grestore
END

  $o .= <<END;
/Times-Bold findfont 15 scalefont setfont $black
gsave
  0.16 0.20  dc translate
  0.60 dup scale

$input
  8 -12 moveto (...) show
  27 0 translate
$input
grestore

gsave
/Times-Roman findfont
  32 scalefont setfont
  0.48 0.14 dc moveto (}) show
grestore

gsave
   0.83 0.25 dc translate
   0.85 dup scale
   ${\ chip($anychip, 0) }
grestore

gsave
  0.72 0.22 dc translate
  0.50 dup scale
   $black 0 0 moveto (?+?) show
grestore
END

  $o .= exposition(<<END);
For each pumpkin in the pot (but
 not more than the number of purple chips),
add up the VPs of the covered spaces.
Buy 1/2 chips of up to that total value.
END

  $o;
}

sub book_yellow () {
  my $o = general_book($yellow, [qw(7 12 19)]);

  $o .= <<END;
gsave
  0.50 0.62 dc translate
  0.65 dup scale
  -26 0 translate
  gsave 26 0 translate ${\ chip($anychip,0) } grestore
  gsave 46 0 translate ${\ chip($pumpkin,0) } grestore
  gsave -30 rotate bag_image grestore
  8 14 translate
  -120 rotate
  ${\ arrow_any("
    gsave
     arrowlen 0 translate
  -85 rotate
    putback_len neg 0
      putback_len
      240 0 arc
    stroke
    grestore
  ") }
grestore
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.20 0.12 0.16 $y mul add dc translate
  0.60 dup scale
  gsave ${\ chip($yellow,$pips) } grestore
  8 -3 moveto (:) show
  3 0 translate
  0.8 dup scale
  24 0 translate
$content
grestore
END
  };

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

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

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

  $o .= exposition(<<END);
Put a chip, no bigger than the yellow,
whose next placed chip is a pumpkin,
back in your bag.                

 
END

  $o;
}

sub black_common ($) {
  my ($second) = @_;
  my $font = <<END;
/Helvetica-Bold findfont 5.5 scalefont setfont
END
  <<END;
    gsave
      .45 .27 dc translate
      droplet_image
      3.5 -1 translate .7 dup scale
      arrow
    grestore
    gsave
      .40 .08 dc translate
      $font
      ($second) 
        dup stringwidth .5 mul exch .5 mul exch translate
        dup stringwidth -1 mul exch -1 mul exch moveto show
      .7 dup scale 7 3 translate
      ${\ ruby() }
    grestore
    gsave
      .15 .37 dc translate

      8.2 3.5 moveto
      $font
      (closest) show

      .7 dup scale
      gsave
        17 0 translate
        180 rotate
        arrow
      grestore
      gsave
        35 0 translate
        arrow
        newpath 0 0 moveto -18 0 rlineto stroke
      grestore

      ${\ chip($pumpkin,0) }

      51 0 translate
      ${\ chip($moth,   1) }
    grestore
END
}

sub book_black_pair () {
  my $o = general_book($moth, [10, 1]);

  $o .= num_players(2);
  $o .= black_common('equal:');

  $o .= exposition(<<END);
The player with the shortest distance
between a black chip and a pumpkin
gets to move their droplet.

If tied, both players get a ruby.
END

  $o;
}

sub book_black_more () {
  my $o = general_book($moth, [10, 1]);

  $o .= num_players(3,'+');
  $o .= black_common('2nd:');

  $o .= exposition(<<END);

The player(s) with the shortest distance
between a black chip and a pumpkin
get to move their droplet.
If only one player won a droplet, the
player(s) with the next-shortest distance
get a ruby.
END

  $o;
}

sub arrow_any ($) { <<END;
  $black 1 setlinewidth
    newpath
       $_[0]
       arrowlen 0 moveto
       arrowhead dup neg exch  rmoveto
       arrowhead dup neg       rlineto
       arrowhead neg dup       rlineto
       stroke
END
};


our $ps_framing = <<END;
%!

$page_pre

/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
/putback_len 10 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 {
  ${\ arrow_any("0 0 moveto  arrowlen 0 rlineto") }
} def

END

sub def_image ($$) {
  my ($ncomps, $name) = @_;

  my $ext = $ncomps == 1 ? 'pgm' : $ncomps == 3 ? 'ppm' : die;
  my $oper = $ncomps == 1 ? 'image' :
             $ncomps == 3 ? 'false 3 colorimage' : die;
  my $magic = $ncomps == 1 ? 'P2' : $ncomps == 3 ? 'P3' : die;

  open B, "$name.$ext" or die $!;
  <B> eq "$magic\n" or die "$name.$ext expected $magic";
  local $/ = undef;
  my @d = split ' ', <B>;
  close B;

  my $w = shift @d;
  my $h = shift @d;
  my $maxval = shift @d;
  die unless $maxval eq 255;

  my $sz = $w/17.0;
  my $hsz = $sz/2;

  $ps_framing .= <<END . '{<';
/${name}_image {
  $w $h 8 
  [ -$sz 0 0  -$sz  $w 2 div  $h 2 div  ]
END
  for (my $i=0; $i< $w*$h*$ncomps; $i++) {
    $ps_framing .= sprintf "%02x", shift @d;
  }
  $ps_framing .= <<END;
>} $oper
} def
END
}

sub tile {
  my @tiles;
  my $index = 1;

  foreach my $spec (@_) {
    my @datas;
    foreach my $stem (split m{/}, $spec) {
      my $func = $stem;
      $func =~ y/-/_/;
      $func = ${*::}{"book_$func"} // die "$func ?";
      my $data = $func->();
      $data .= <<END;
    /Courier-Bold findfont 6 scalefont setfont
    -0.98 0.94 dc moveto
    ($index) show
END
      open F, ">book-$stem.ps" or die $!;
      print F $ps_framing, $data, "\nshowpage\n" or die $!;
      close F or die $!;
      push @datas, $data;
    }
    foreach my $dd (@datas) {
      push @tiles, $dd;
    }
    $index++;
  }

  my $pos = 0;
  my $o = '';
  my $showpage = sub {
    $o .= <<END;
showpage
$page_pre
END
  };

  while (my $d = pop @tiles) {
    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;
}

def_image(1, "bag");
def_image(1, "pot");
def_image(3, "droplet");

print $ps_framing or die $!;

print "gsave\n" or die $!;

print tile(@ARGV) or die $! if 1;