#!/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;
-my $pumpkin = ["255/185/15", "0 0 0"];
-my $green = ["0/238/118", "1 1 1"];
-my $red = ["1 0 0", "0 0 0"];
-my $blue = ["0 .4 1 ", "1 1 1"];
-my $yellow = ["1 1 0", "0 0 0"];
-my $moth = [" 0 0 0", "1 1 1"];
-my $purple = ["145/44/238", "0 0 0"];
-my $lotus = [("0/245/255",) x 2];
-my $white = ["1 1 1", "0 0 0"];
-
-my $anychip = ['0.8', '0'];
-
-our $page_pre = <<END;
-72 25.4 div dup scale
-%210 0 translate
-%90 rotate
-7 10 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;
-}
+BEGIN { unshift @INC, '.'; }
+use Quacks;
sub veepsspot ($) {
my ($chip) = @_;
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;
$o;
}
-sub green_book () {
+sub book_green () {
my $o = general_book($green, [qw(5 9 15)]);
$o .= <<END;
$o;
}
-sub red_book () {
+sub book_red () {
my $o = general_book($red, [qw(4 9 16)]);
$o .= <<END;
$o;
}
-sub blue_book () {
- my $o = general_book($blue, [qw(4 10 18)]);
+sub book_blue () {
+ my $o = general_book($blue, [qw(4 9 17)]);
$o .= <<END;
/Times-Bold findfont 15 scalefont setfont $black
$o .= $exchline->(1, 2, <<END);
${\ $exchip->($moth,1) } ${\ $exslash->() }
${\ $exchip->($purple,1) } ${\ $exslash->() }
- ${\ anychip(2) }
+ ${\ $exchip->($lotus,0) } ${\ $exslash->() }
+ ${\ $exchip->($anychip,2) }
END
$o .= $exchline->(0, 4, <<END);
$o;
}
-sub lotus_book () {
+sub book_lotus () {
my $o = general_book($lotus, [8, 0]);
$o .= <<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)
+in the pot (but max.4)
END
$o;
}
-sub purple_book () {
+sub book_purple () {
my $o = general_book($purple, [10, 1]);
my $input = <<END;
$o;
}
-sub tile {
- my @tiles;
- my $index_i = 1;
- foreach my $d (@_) {
- foreach my $dd (ref $d ? @$d : $d) {
- push @tiles, [ $dd, $index_i ];
- }
- $index_i++;
- }
-
- my $pos = 0;
- my $o = '';
- my $showpage = sub {
- $o .= <<END;
-showpage
-$page_pre
-END
- };
-
- while (my $di = pop @tiles) {
- my ($d, $index) = @$di;
-
- 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;
-
- /Courier-Bold findfont 6 scalefont setfont
- -0.98 0.94 dc moveto
- ($index) show
-
-grestore
-END
- $pos++;
- }
- $showpage->();
- $o;
-}
-
-sub yellow_book () {
- my $o = general_book($yellow, [qw(7 12 19)]);
+sub book_yellow () {
+ my $o = general_book($yellow, [qw(5 11 19)]);
$o .= <<END;
gsave
- 0.50 0.62 dc translate
- 0.65 dup scale
+ 0.52 0.32 dc translate
+ 0.80 dup scale
-26 0 translate
- gsave 26 0 translate ${\ chip($anychip,0) } grestore
+ gsave 26 0 translate ${\ chip($yellow,0) } grestore
gsave 46 0 translate ${\ chip($pumpkin,0) } grestore
- gsave -30 rotate bag_image grestore
- 8 14 translate
- -120 rotate
+ 34 14 translate
+ -22.5 rotate
+ 1 -1 scale
${\ arrow_any("
gsave
arrowlen 0 translate
-85 rotate
- putback_len neg 0
- putback_len
- 240 0 arc
+ -40 0
+ 40
+ 300 0 arc
stroke
grestore
") }
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.
-
-
+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;
END
}
-sub black_book_pair () {
+sub book_black_pair () {
my $o = general_book($moth, [10, 1]);
$o .= num_players(2);
$o;
}
-sub black_book_more () {
+sub book_black_more () {
my $o = general_book($moth, [10, 1]);
$o .= num_players(3,'+');
$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
-};
-
-print <<END or die $!;
-%!
-
-$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
+ps_start('7 30 translate');
sub def_image ($$) {
my ($ncomps, $name) = @_;
my $sz = $w/17.0;
my $hsz = $sz/2;
- print <<END, '{<' or die $!;
+ $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++) {
- printf "%02x", shift @d or die $!;
+ $ps_framing .= sprintf "%02x", shift @d;
}
- print <<END or die $!;
+ $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(
- red_book(),
- green_book(),
- purple_book(),
- blue_book(),
- lotus_book(),
- yellow_book(),
- [black_book_pair(), black_book_more()],
- ) or die $! if 1;
+print tile(@ARGV) or die $! if 1;
~ianmdlvl / quacks.git / blobdiff