#!/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;
-our $black = '0 0 0 1 setcmykcolor';
+BEGIN { unshift @INC, '.'; }
+use Quacks;
-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"];
-
-sub chip ($$) {
- my ($cary, $pips) = @_; # put in a gsave translate
- my $o = <<END;
+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
- 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
+ -1 -1 moveto 6 0 rlineto 0 7 rlineto -6 0 rlineto
+ closepath 0.5 setlinewidth stroke
+grestore
+ $chip
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 ruby () { # put in gsave translate
+sub anychip ($) {
+ my ($pips) = @_;
+ my $fsz = 10;
<<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
+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
}
my $o = <<END;
/Times-Roman findfont $fontsz scalefont setfont $black
END
- $text =~ s/\s+$//;
+ $text =~ s/\n$//;
my @lines = split /\n/, $text;
foreach my $y (0..$#lines) {
my $l = $lines[$y];
$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) = @_;
tw 0 translate
3 setlinewidth
-0 0 0 0.2 setcmykcolor
+0.9 setgray
newpath
0 0 dc moveto
0 1 dc lineto stroke
%
} def
+END
+
+ $o .= <<END if @$costs == 3;
1 thirddivline
2 thirddivline
-
END
foreach my $costi (0..2) {
- my $cost = $costs->[$costi];
- my $pips = qw(1 2 4)[$costi];
+ 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
$o;
}
-sub green_book () {
+sub book_green () {
my $o = general_book($green, [qw(5 9 15)]);
$o .= <<END;
-gsave 0.2 0.15 dc translate ${\ chip($pumpkin,0) } grestore
-gsave 0.2 0.40 dc translate ${\ chip($green,0) } grestore
+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.35 0.17 dc moveto (last) show
+ 0.40 0.17 dc moveto (last) show
%
8 scalefont setfont
- 0.35 0.09 dc moveto (3) show
+ 0.40 0.09 dc moveto (3) show
/Times-Roman findfont
38 scalefont setfont
0.45 0.14 dc moveto (}) show
$o;
}
-sub red_book () {
+sub book_red () {
my $o = general_book($red, [qw(4 9 16)]);
$o .= <<END;
$o;
}
+sub book_blue () {
+ my $o = general_book($blue, [qw(4 9 17)]);
+
+ $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->() }
+ ${\ $exchip->($lotus,0) } ${\ $exslash->() }
+ ${\ $exchip->($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
+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(5 11 19)]);
+
+ $o .= <<END;
+gsave
+ 0.52 0.32 dc translate
+ 0.80 dup scale
+ -26 0 translate
+ gsave 26 0 translate ${\ chip($yellow,0) } grestore
+ gsave 46 0 translate ${\ chip($pumpkin,0) } grestore
+ 34 14 translate
+ -22.5 rotate
+ 1 -1 scale
+ ${\ arrow_any("
+ gsave
+ arrowlen 0 translate
+ -85 rotate
+ -40 0
+ 40
+ 300 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
+ };
+
+ $o .= exposition(<<END);
+Move up to 1/2/4 pumpkins
+already in your pot, to after the yellow.
+(always immediately after, only one space,
+regardless of other rules)
+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;
+}
+ps_start('7 30 translate');
+
+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 = shift @_) {
+
+ while (my $d = pop @tiles) {
if ($pos >= 5) {
$pos -= 5;
$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
-
-/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
+def_image(1, "bag");
+def_image(1, "pot");
+def_image(3, "droplet");
-END
+print $ps_framing or die $!;
+
+print "gsave\n" or die $!;
+
+print tile(@ARGV) or die $! if 1;
-print tile(
- green_book(),
- red_book(),
- ) or die $! if 1;
~ianmdlvl / quacks.git / blobdiff