2 # Books of Pumpkins, etc. Extensions to Quacks of Quedlinburg
3 # SPDX-License-Identifier: GPL-3.0-or-later OR CC-BY-SA-4.0
4 # Copyright 2020-2021 Ian Jackson
8 my $pumpkin = ["255/185/15", "0 0 0"];
9 my $green = ["0/238/118", "1 1 1"];
10 my $red = ["1 0 0", "0 0 0"];
11 my $blue = ["0 .4 1 ", "1 1 1"];
12 my $yellow = ["1 1 0", "0 0 0"];
13 my $moth = [" 0 0 0", "1 1 1"];
14 my $purple = ["145/44/238", "0 0 0"];
15 my $lotus = [("0/245/255",) x 2];
16 my $white = ["1 1 1", "0 0 0"];
18 my $anychip = ['0.8', '0'];
20 our $page_pre = <<END;
29 if ($c =~ m{^(\d+)/(\d+)/(\d+)$}) {
30 return (join ' ', map { $_ / 255.0 } ($1,$2,$3)).' setrgbcolor';
31 } elsif ($c =~ m/[^ 0-9.]/) {
33 } elsif ($c =~ m/^\s*\S+\s*$/) {
35 } elsif ($c =~ m/./) {
36 return "$c setrgbcolor";
42 our $black = colour('0');
45 my ($cary, $pips) = @_; # put in a gsave translate
48 0 0 chip 0.5 mul 0 360 arc
49 gsave 1 setlinewidth $black stroke grestore
50 ${\ colour($cary->[0]) } fill
54 ${\ colour($cary->[1]) }
61 spot 0.5 sqrt mul 1.1 mul dup
68 $spot->( 0, 0) if $pips & 1;
69 $spot->(-1,-1) if $pips & 6;
70 $spot->(+1,+1) if $pips & 6;
71 $spot->(-1,+1) if $pips & 4;
72 $spot->(+1,-1) if $pips & 4;
81 0 chip -0.5 mul translate
83 newpath 0 0 chip 0.5 mul 0 360 arc stroke
84 /Times-Bold findfont 7 scalefont setfont
88 -1 -1 moveto 6 0 rlineto 0 7 rlineto -6 0 rlineto
89 closepath 0.5 setlinewidth stroke
100 chip -0.5 mul $fsz -0.30 mul moveto
101 /Helvetica-Bold findfont $fsz scalefont setfont
102 (Any) dup stringwidth 3 2 roll show
105 ${\ chip($anychip, $pips) }
110 sub ruby () { # put in gsave translate
118 ${\ colour('1 .2 .2') } gsave fill grestore
119 $black 1 setlinewidth stroke
127 /Times-Roman findfont $fontsz scalefont setfont $black
130 my @lines = split /\n/, $text;
131 foreach my $y (0..$#lines) {
133 $l =~ s/[()\\]/\\$&/g;
134 my $yd = $fontsz * (0.5*@lines - $y);
138 ($l) dup stringwidth pop -0.5 mul 0 rmoveto
145 sub num_players ($;$) {
151 -0.94 0.50 dc translate
156 pot_image 18 0 translate
159 $o .= <<END if defined $plus;
161 /Helvetica-Bold findfont 25 scalefont setfont
171 sub general_book ($$) { # put in a gsave
172 my ($this, $costs) = @_;
194 0 thirdlineh dc rlineto
195 -1 thirdlineh dc lineto stroke
197 /thirddivline { % xprop
199 dup -3 div 0 dc moveto
200 -3 div thirdlineh dc lineto stroke
206 $o .= <<END if @$costs == 3;
211 foreach my $costi (0..2) {
214 $cost = $costs->[$costi];
215 $pips = qw(1 2 4)[$costi];
217 next unless $costi == 1;
223 -2.5 $costi add 3 div
225 dup costcirch dc translate
226 ${\ chip($this,$pips) }
228 costtexth exch costtextdx add exch dc moveto
231 dup stringwidth pop -0.5 mul costtextsz neg rmoveto
240 my $o = general_book($green, [qw(5 9 15)]);
243 gsave 0.25 0.15 dc translate ${\ chip($pumpkin,0) } grestore
244 gsave 0.25 0.40 dc translate ${\ chip($green,0) } grestore
249 0.40 0.17 dc moveto (last) show
252 0.40 0.09 dc moveto (3) show
253 /Times-Roman findfont
255 0.45 0.14 dc moveto (}) show
258 0.85 0.275 dc translate
263 $o .= exposition(<<END);
264 For each pumpkin in the last 3 chips,
266 But, not more rubies than the number
267 of green chips in your pot.
274 my $o = general_book($red, [qw(4 9 16)]);
277 gsave 0.35 0.30 dc translate ${\ chip($pumpkin,0) } grestore
281 0.50 0.24 dc moveto (+1) show
285 $o .= exposition(<<END);
286 The next 1/2/4 pumpkins you place are
287 each moved one extra space.
288 (After applying any other special effects;
289 one extra space no matter how many reds)
296 my $o = general_book($blue, [qw(4 10 18)]);
299 /Times-Bold findfont 15 scalefont setfont $black
302 0.50 0.65 dc translate
304 gsave -10 0 translate ${\ chip($pumpkin,0) } grestore
310 my ($that, $pips) = @_;
312 gsave ${\ chip($that, $pips) } grestore
323 my ($y, $pips, $content) = @_;
326 0.16 0.15 0.16 $y mul add dc translate
328 gsave ${\ chip($blue,$pips) } grestore
338 $o .= $exchline->(2, 1, <<END);
339 ${\ $exchip->($green,1) } ${\ $exslash->() }
340 ${\ $exchip->($red, 1) } ${\ $exslash->() }
341 ${\ $exchip->($blue, 1) } ${\ $exslash->() }
342 ${\ $exchip->($yellow, 1) }
345 $o .= $exchline->(1, 2, <<END);
346 ${\ $exchip->($moth,1) } ${\ $exslash->() }
347 ${\ $exchip->($purple,1) } ${\ $exslash->() }
351 $o .= $exchline->(0, 4, <<END);
355 $o .= exposition(<<END);
356 If the previous chip placed was a pumpkin,
357 you may exchange it as follows:
366 my $o = general_book($lotus, [8, 0]);
369 /Times-Bold findfont 15 scalefont setfont $black
372 0.36 0.38 dc translate
374 gsave ${\ chip($lotus,0) } grestore
379 0.20 0.15 dc translate
381 gsave ${\ chip($pumpkin,0) } grestore
382 chip 0.5 mul 0 translate
383 gsave ${\ chip($pumpkin,0) } grestore
385 10 -4.5 moveto (... +1) show
391 0.16 0.20 dc translate
394 gsave ${\ veepsspot(chip($pumpkin, 0)) } grestore
395 gsave 0 20 translate ${\ chip($purple, 1) } grestore
401 $o .= exposition(<<END);
402 The value of this chip is
403 1 higher than the number of pumpkins
404 previously placed in the pot (but max.4)
411 my $o = general_book($purple, [10, 1]);
414 gsave ${\ veepsspot(chip($pumpkin, 0)) } grestore
415 gsave 0 20 translate ${\ chip($purple, 1) } grestore
419 /Times-Bold findfont 15 scalefont setfont $black
421 0.16 0.20 dc translate
425 8 -12 moveto (...) show
431 /Times-Roman findfont
433 0.48 0.14 dc moveto (}) show
437 0.83 0.25 dc translate
439 ${\ chip($anychip, 0) }
443 0.72 0.22 dc translate
445 $black 0 0 moveto (?+?) show
449 $o .= exposition(<<END);
450 For each pumpkin in the pot (but
451 not more than the number of purple chips),
452 add up the VPs of the covered spaces.
453 Buy 1/2 chips of up to that total value.
463 foreach my $dd (ref $d ? @$d : $d) {
464 push @tiles, [ $dd, $index_i ];
478 while (my $di = pop @tiles) {
479 my ($d, $index) = @$di;
490 0 th 10 add $pos mul translate
495 dup th add 0 translate
497 $pos 3 sub mul 0 translate
503 /Courier-Bold findfont 6 scalefont setfont
516 my $o = general_book($yellow, [qw(7 12 19)]);
520 0.50 0.62 dc translate
523 gsave 26 0 translate ${\ chip($anychip,0) } grestore
524 gsave 46 0 translate ${\ chip($pumpkin,0) } grestore
525 gsave -30 rotate bag_image grestore
542 my ($that, $pips) = @_;
544 gsave ${\ chip($that, $pips) } grestore
555 my ($y, $pips, $content) = @_;
558 0.20 0.12 0.16 $y mul add dc translate
560 gsave ${\ chip($yellow,$pips) } grestore
570 $o .= $exchline->(2, 1, <<END);
571 ${\ $exchip->($white,1) } ${\ $exslash->() }
572 ${\ $exchip->($anychip,1) } ${\ $exslash->() }
573 ${\ $exchip->($lotus,0) }
576 $o .= $exchline->(1, 2, <<END);
577 ${\ $exchip->($white,2) } ${\ $exslash->() }
578 ${\ $exchip->($anychip,2) }
581 $o .= $exchline->(0, 4, <<END);
582 ${\ $exchip->($white,3) } ${\ $exslash->() }
583 ${\ $exchip->($anychip,4) }
586 $o .= exposition(<<END);
587 Put a chip, no bigger than the yellow,
588 whose next placed chip is a pumpkin,
597 sub black_common ($) {
600 /Helvetica-Bold findfont 5.5 scalefont setfont
606 3.5 -1 translate .7 dup scale
613 dup stringwidth .5 mul exch .5 mul exch translate
614 dup stringwidth -1 mul exch -1 mul exch moveto show
615 .7 dup scale 7 3 translate
634 newpath 0 0 moveto -18 0 rlineto stroke
637 ${\ chip($pumpkin,0) }
645 sub black_book_pair () {
646 my $o = general_book($moth, [10, 1]);
648 $o .= num_players(2);
649 $o .= black_common('equal:');
651 $o .= exposition(<<END);
652 The player with the shortest distance
653 between a black chip and a pumpkin
654 gets to move their droplet.
656 If tied, both players get a ruby.
662 sub black_book_more () {
663 my $o = general_book($moth, [10, 1]);
665 $o .= num_players(3,'+');
666 $o .= black_common('2nd:');
668 $o .= exposition(<<END);
670 The player(s) with the shortest distance
671 between a black chip and a pumpkin
672 get to move their droplet.
673 If only one player won a droplet, the
674 player(s) with the next-shortest distance
681 sub arrow_any ($) { <<END;
682 $black 1 setlinewidth
686 arrowhead dup neg exch rmoveto
687 arrowhead dup neg rlineto
688 arrowhead neg dup rlineto
693 print <<END or die $!;
711 /costtextdx -0.03 def
712 /costfont /Heletica-BoldOblique findfont costtextsz scalefont def
716 % diagonal conversion
718 dup th mul % xprop yprop y
719 3 1 roll % y xprop yprop
720 bdiag mul neg % y xprop x-margin-at-this-height
721 tw add % y xprop x-width-at-this-height
722 exch mul % y x-width-at-this-height xprop
727 ${\ arrow_any("0 0 moveto arrowlen 0 rlineto") }
733 my ($ncomps, $name) = @_;
735 my $ext = $ncomps == 1 ? 'pgm' : $ncomps == 3 ? 'ppm' : die;
736 my $oper = $ncomps == 1 ? 'image' :
737 $ncomps == 3 ? 'false 3 colorimage' : die;
738 my $magic = $ncomps == 1 ? 'P2' : $ncomps == 3 ? 'P3' : die;
740 open B, "$name.$ext" or die $!;
741 <B> eq "$magic\n" or die "$name.$ext expected $magic";
743 my @d = split ' ', <B>;
748 my $maxval = shift @d;
749 die unless $maxval eq 255;
754 print <<END, '{<' or die $!;
757 [ -$sz 0 0 -$sz $w 2 div $h 2 div ]
759 for (my $i=0; $i< $w*$h*$ncomps; $i++) {
760 printf "%02x", shift @d or die $!;
762 print <<END or die $!;
770 def_image(3, "droplet");
772 print "gsave\n" or die $!;
781 [black_book_pair(), black_book_more()],