pumpkin-books.ps.pl

   1 #!/usr/bin/perl -w
   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
   5
   6 use strict;
   7
   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"];
  17
  18 my $anychip = ['0.8', '0'];
  19
  20 our $page_pre = <<END;
  21 72 25.4 div dup scale
  22 %210 0 translate
  23 %90 rotate
  24 7 30 translate
  25 END
  26
  27 sub colour ($) {
  28   my ($c) = @_;
  29   if ($c =~ m{^(\d+)/(\d+)/(\d+)$}) {
  30     return (join ' ', map { $_ / 255.0 } ($1,$2,$3)).' setrgbcolor';
  31   } elsif ($c =~ m/[^ 0-9.]/) {
  32     return $c;
  33   } elsif ($c =~ m/^\s*\S+\s*$/) {
  34     return "$c setgray";
  35   } elsif ($c =~ m/./) {
  36     return "$c setrgbcolor";
  37   } else {
  38     return '';
  39   }
  40 }
  41
  42 our $black = colour('0');
  43
  44 sub chip ($$) {
  45   my ($cary, $pips) = @_; # put in a gsave translate
  46   my $o = <<END;
  47   newpath
  48   0 0 chip 0.5 mul 0 360 arc
  49   gsave 1 setlinewidth $black stroke grestore
  50   ${\ colour($cary->[0]) } fill
  51 END
  52   if ($pips) {
  53     $o .= <<END;
  54   ${\ colour($cary->[1]) }
  55 END
  56   }
  57   my $spot = sub {
  58     my ($x,$y) = @_;
  59     $o .= <<END;
  60     newpath
  61     spot 0.5 sqrt mul 1.1 mul dup
  62     $x mul exch $y mul
  63     spot 0.5 mul
  64     0 360 arc fill
  65 END
  66   };
  67
  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;
  73
  74   $o;
  75 }
  76
  77 sub veepsspot ($) {
  78   my ($chip) = @_;
  79   <<END;
  80 gsave
  81   0 chip -0.5 mul translate
  82   $black
  83   newpath 0 0 chip 0.5 mul 0 360 arc stroke
  84   /Times-Bold findfont 7 scalefont setfont
  85   -1 -5 translate
  86   0 0 moveto (?) show
  87   newpath
  88    -1 -1 moveto 6 0 rlineto 0 7 rlineto -6 0 rlineto
  89     closepath 0.5 setlinewidth stroke
  90 grestore
  91   $chip
  92 END
  93 }
  94
  95 sub anychip ($) {
  96   my ($pips) = @_;
  97   my $fsz = 10;
  98   <<END;
  99 gsave
 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
 103   pop pop
 104   20 0 translate
 105   ${\ chip($anychip, $pips) }
 106 grestore
 107 END
 108 }
 109
 110 sub ruby () { # put in gsave translate
 111   <<END;
 112   newpath
 113     rubysz neg  0 moveto
 114     0  rubysz neg lineto
 115     rubysz      0 lineto
 116     0      rubysz lineto
 117     closepath
 118     ${\ colour('1 .2 .2') } gsave fill grestore
 119     $black 1 setlinewidth stroke
 120 END
 121 }
 122
 123 sub exposition ($) {
 124   my ($text) = @_;
 125   my $fontsz = 6;
 126   my $o = <<END;
 127     /Times-Roman findfont $fontsz scalefont setfont $black
 128 END
 129   $text =~ s/\n$//;
 130   my @lines = split /\n/, $text;
 131   foreach my $y (0..$#lines) {
 132     my $l = $lines[$y];
 133     $l =~ s/[()\\]/\\$&/g;
 134     my $yd = $fontsz * (0.5*@lines - $y);
 135     $o .= <<END;
 136     0 0.70 dc moveto
 137     0 $yd rmoveto
 138     ($l)  dup stringwidth pop -0.5 mul 0 rmoveto
 139     show
 140 END
 141   }
 142   $o;
 143 }
 144
 145 sub num_players ($;$) {
 146   my ($n, $plus) = @_;
 147   my $o = '';
 148
 149   $o .= <<END;
 150   gsave
 151     -0.94 0.50 dc translate
 152     0.3 dup scale
 153 END
 154
 155   $o .= <<END x $n;
 156     pot_image 18 0 translate
 157 END
 158
 159   $o .= <<END if defined $plus;
 160     -9 -5 moveto
 161     /Helvetica-Bold findfont 25 scalefont setfont
 162     ($plus) show
 163 END
 164
 165   $o .= <<END;
 166   grestore
 167 END
 168   return $o;
 169 }
 170
 171 sub general_book ($$) { # put in a gsave
 172   my ($this, $costs) = @_;
 173   my $o = <<END;
 174 tw  0  translate
 175
 176 3 setlinewidth
 177 0.9 setgray
 178 newpath
 179 0 0 dc moveto
 180 0 1 dc lineto stroke
 181
 182 $black
 183 1 setlinewidth
 184
 185 newpath
 186 -1 0  dc moveto
 187 +1 0  dc lineto
 188 +1 1  dc lineto
 189 -1 1  dc lineto
 190 closepath stroke
 191
 192 newpath
 193 0 0 dc         moveto
 194 0 thirdlineh dc rlineto
 195 -1 thirdlineh dc lineto stroke
 196
 197 /thirddivline {               % xprop
 198   newpath
 199   dup -3 div  0               dc moveto
 200       -3 div  thirdlineh      dc lineto stroke
 201                               %
 202 } def
 203
 204 END
 205
 206   $o .= <<END if @$costs == 3;
 207 1 thirddivline
 208 2 thirddivline
 209 END
 210
 211   foreach my $costi (0..2) {
 212     my ($cost, $pips);
 213     if (@$costs == 3) {
 214       $cost = $costs->[$costi];
 215       $pips = qw(1 2 4)[$costi];
 216     } else {
 217       next unless $costi == 1;
 218       $cost = $costs->[0];
 219       $pips = $costs->[1];
 220     }
 221     $o .= <<END
 222   costfont setfont
 223   -2.5 $costi add 3 div
 224 gsave
 225   dup costcirch dc translate
 226   ${\ chip($this,$pips) }
 227 grestore
 228   costtexth exch costtextdx add exch dc moveto
 229   $black
 230   ($cost)
 231   dup stringwidth pop  -0.5 mul  costtextsz neg  rmoveto
 232   show
 233 END
 234   }
 235
 236   $o;
 237 }
 238
 239 sub book_green () {
 240   my $o = general_book($green, [qw(5 9 15)]);
 241
 242   $o .= <<END;
 243 gsave 0.25 0.15 dc translate ${\ chip($pumpkin,0) } grestore
 244 gsave 0.25 0.40 dc translate ${\ chip($green,0) } grestore
 245
 246 /Times-Bold findfont
 247 dup
 248   6 scalefont setfont
 249   0.40 0.17 dc moveto (last) show
 250 %
 251   8 scalefont setfont
 252   0.40 0.09 dc moveto (3) show
 253 /Times-Roman findfont
 254   38 scalefont setfont
 255   0.45 0.14 dc moveto (}) show
 256
 257 gsave
 258   0.85 0.275 dc translate
 259   ${\ ruby() }
 260 grestore
 261 END
 262
 263   $o .= exposition(<<END);
 264 For each pumpkin in the last 3 chips,
 265 receive 1 ruby.
 266 But, not more rubies than the number
 267 of green chips in your pot.
 268 END
 269
 270   $o;
 271 }
 272
 273 sub book_red () {
 274   my $o = general_book($red, [qw(4 9 16)]);
 275
 276   $o .= <<END;
 277 gsave 0.35 0.30 dc translate ${\ chip($pumpkin,0) } grestore
 278
 279 /Times-Bold findfont
 280   15 scalefont setfont
 281   0.50 0.24 dc moveto (+1) show
 282
 283 END
 284
 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)
 290 END
 291
 292   $o;
 293 }
 294
 295 sub book_blue () {
 296   my $o = general_book($blue, [qw(4 10 18)]);
 297
 298   $o .= <<END;
 299 /Times-Bold findfont 15 scalefont setfont $black
 300
 301 gsave
 302   0.50 0.65 dc translate
 303   0.65 dup scale
 304   gsave -10 0 translate ${\ chip($pumpkin,0) } grestore
 305   arrow
 306 grestore
 307 END
 308
 309   my $exchip = sub {
 310     my ($that, $pips) = @_;
 311     <<END;
 312   gsave ${\ chip($that, $pips) } grestore
 313 END
 314   };
 315   my $exslash = sub {
 316     <<END;
 317     8 -5 moveto (/) show
 318     20 0 translate
 319 END
 320   };
 321
 322   my $exchline = sub {
 323     my ($y, $pips, $content) = @_;
 324     <<END;
 325 gsave
 326   0.16 0.15 0.16 $y mul add dc translate
 327   0.60 dup scale
 328   gsave ${\ chip($blue,$pips) } grestore
 329   8 -3 moveto (:) show
 330   3 0 translate
 331   0.8 dup scale
 332   21 0 translate
 333 $content
 334 grestore
 335 END
 336   };
 337
 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) }
 343 END
 344
 345   $o .= $exchline->(1, 2, <<END);
 346   ${\ $exchip->($moth,1) }  ${\ $exslash->() }
 347   ${\ $exchip->($purple,1) }  ${\ $exslash->() }
 348   ${\ anychip(2) }
 349 END
 350
 351   $o .= $exchline->(0, 4, <<END);
 352   ${\ anychip(4) }
 353 END
 354
 355   $o .= exposition(<<END);
 356 If the previous chip placed was a pumpkin,
 357 you may exchange it as follows:
 358
 359
 360 END
 361
 362   $o;
 363 }
 364
 365 sub book_lotus () {
 366   my $o = general_book($lotus, [8, 0]);
 367
 368   $o .= <<END;
 369 /Times-Bold findfont 15 scalefont setfont $black
 370
 371 gsave
 372   0.36 0.38 dc translate
 373   0.80 dup scale
 374   gsave ${\ chip($lotus,0) } grestore
 375
 376   9 -4 moveto (=) show
 377 grestore
 378 gsave
 379   0.20 0.15 dc translate
 380   0.80 dup scale
 381   gsave ${\ chip($pumpkin,0) } grestore
 382   chip 0.5 mul 0 translate
 383   gsave ${\ chip($pumpkin,0) } grestore
 384
 385   10 -4.5 moveto (... +1) show
 386
 387 grestore
 388 END
 389 <<END;
 390 gsave
 391   0.16 0.20  dc translate
 392   0.60 dup scale
 393
 394   gsave ${\ veepsspot(chip($pumpkin, 0)) } grestore
 395   gsave 0 20 translate ${\ chip($purple, 1) } grestore
 396   27 0 translate
 397 grestore
 398 END
 399
 400
 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)
 405 END
 406
 407   $o;
 408 }
 409
 410 sub book_purple () {
 411   my $o = general_book($purple, [10, 1]);
 412
 413   my $input = <<END;
 414   gsave ${\ veepsspot(chip($pumpkin, 0)) } grestore
 415   gsave 0 20 translate ${\ chip($purple, 1) } grestore
 416 END
 417
 418   $o .= <<END;
 419 /Times-Bold findfont 15 scalefont setfont $black
 420 gsave
 421   0.16 0.20  dc translate
 422   0.60 dup scale
 423
 424 $input
 425   8 -12 moveto (...) show
 426   27 0 translate
 427 $input
 428 grestore
 429
 430 gsave
 431 /Times-Roman findfont
 432   32 scalefont setfont
 433   0.48 0.14 dc moveto (}) show
 434 grestore
 435
 436 gsave
 437    0.83 0.25 dc translate
 438    0.85 dup scale
 439    ${\ chip($anychip, 0) }
 440 grestore
 441
 442 gsave
 443   0.72 0.22 dc translate
 444   0.50 dup scale
 445    $black 0 0 moveto (?+?) show
 446 grestore
 447 END
 448
 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.
 454 END
 455
 456   $o;
 457 }
 458
 459 sub book_yellow () {
 460   my $o = general_book($yellow, [qw(7 12 19)]);
 461
 462   $o .= <<END;
 463 gsave
 464   0.50 0.62 dc translate
 465   0.65 dup scale
 466   -26 0 translate
 467   gsave 26 0 translate ${\ chip($anychip,0) } grestore
 468   gsave 46 0 translate ${\ chip($pumpkin,0) } grestore
 469   gsave -30 rotate bag_image grestore
 470   8 14 translate
 471   -120 rotate
 472   ${\ arrow_any("
 473     gsave
 474      arrowlen 0 translate
 475   -85 rotate
 476     putback_len neg 0
 477       putback_len
 478       240 0 arc
 479     stroke
 480     grestore
 481   ") }
 482 grestore
 483 END
 484
 485   my $exchip = sub {
 486     my ($that, $pips) = @_;
 487     <<END;
 488   gsave ${\ chip($that, $pips) } grestore
 489 END
 490   };
 491   my $exslash = sub {
 492     <<END;
 493     8 -5 moveto (/) show
 494     20 0 translate
 495 END
 496   };
 497
 498   my $exchline = sub {
 499     my ($y, $pips, $content) = @_;
 500     <<END;
 501 gsave
 502   0.20 0.12 0.16 $y mul add dc translate
 503   0.60 dup scale
 504   gsave ${\ chip($yellow,$pips) } grestore
 505   8 -3 moveto (:) show
 506   3 0 translate
 507   0.8 dup scale
 508   24 0 translate
 509 $content
 510 grestore
 511 END
 512   };
 513
 514   $o .= $exchline->(2, 1, <<END);
 515   ${\ $exchip->($white,1) }  ${\ $exslash->() }
 516   ${\ $exchip->($anychip,1) }  ${\ $exslash->() }
 517   ${\ $exchip->($lotus,0) }
 518 END
 519
 520   $o .= $exchline->(1, 2, <<END);
 521   ${\ $exchip->($white,2) }  ${\ $exslash->() }
 522   ${\ $exchip->($anychip,2) }
 523 END
 524
 525   $o .= $exchline->(0, 4, <<END);
 526   ${\ $exchip->($white,3) }  ${\ $exslash->() }
 527   ${\ $exchip->($anychip,4) }
 528 END
 529
 530   $o .= exposition(<<END);
 531 Put a chip, no bigger than the yellow,
 532 whose next placed chip is a pumpkin,
 533 back in your bag.
 534
 535
 536 END
 537
 538   $o;
 539 }
 540
 541 sub black_common ($) {
 542   my ($second) = @_;
 543   my $font = <<END;
 544 /Helvetica-Bold findfont 5.5 scalefont setfont
 545 END
 546   <<END;
 547     gsave
 548       .45 .27 dc translate
 549       droplet_image
 550       3.5 -1 translate .7 dup scale
 551       arrow
 552     grestore
 553     gsave
 554       .40 .08 dc translate
 555       $font
 556       ($second)
 557         dup stringwidth .5 mul exch .5 mul exch translate
 558         dup stringwidth -1 mul exch -1 mul exch moveto show
 559       .7 dup scale 7 3 translate
 560       ${\ ruby() }
 561     grestore
 562     gsave
 563       .15 .37 dc translate
 564
 565       8.2 3.5 moveto
 566       $font
 567       (closest) show
 568
 569       .7 dup scale
 570       gsave
 571         17 0 translate
 572         180 rotate
 573         arrow
 574       grestore
 575       gsave
 576         35 0 translate
 577         arrow
 578         newpath 0 0 moveto -18 0 rlineto stroke
 579       grestore
 580
 581       ${\ chip($pumpkin,0) }
 582
 583       51 0 translate
 584       ${\ chip($moth,   1) }
 585     grestore
 586 END
 587 }
 588
 589 sub book_black_pair () {
 590   my $o = general_book($moth, [10, 1]);
 591
 592   $o .= num_players(2);
 593   $o .= black_common('equal:');
 594
 595   $o .= exposition(<<END);
 596 The player with the shortest distance
 597 between a black chip and a pumpkin
 598 gets to move their droplet.
 599
 600 If tied, both players get a ruby.
 601 END
 602
 603   $o;
 604 }
 605
 606 sub book_black_more () {
 607   my $o = general_book($moth, [10, 1]);
 608
 609   $o .= num_players(3,'+');
 610   $o .= black_common('2nd:');
 611
 612   $o .= exposition(<<END);
 613
 614 The player(s) with the shortest distance
 615 between a black chip and a pumpkin
 616 get to move their droplet.
 617 If only one player won a droplet, the
 618 player(s) with the next-shortest distance
 619 get a ruby.
 620 END
 621
 622   $o;
 623 }
 624
 625 sub arrow_any ($) { <<END;
 626   $black 1 setlinewidth
 627     newpath
 628        $_[0]
 629        arrowlen 0 moveto
 630        arrowhead dup neg exch  rmoveto
 631        arrowhead dup neg       rlineto
 632        arrowhead neg dup       rlineto
 633        stroke
 634 END
 635 };
 636
 637
 638 our $ps_framing = <<END;
 639 %!
 640
 641 $page_pre
 642
 643 /tw 57.5 def
 644 /th 73 def
 645 /bdiag 5 def
 646 /thirdlineh 0.45 def
 647 /costcirch 0.3 def
 648 /chip 15 def
 649 /spot 3.5 def
 650 /arrowlen 6 def
 651 /arrowhead 3 def
 652 /putback_len 10 def
 653
 654 /costtexth 0.215 def
 655 /costtextsz 12 def
 656 /costtextdx -0.03 def
 657 /costfont /Heletica-BoldOblique findfont costtextsz scalefont def
 658
 659 /rubysz 4 def
 660
 661 % diagonal conversion
 662 /dc {                    % xprop yprop
 663     dup th mul           % xprop yprop y
 664     3 1 roll             % y xprop yprop
 665     bdiag mul neg        % y xprop x-margin-at-this-height
 666     tw add               % y xprop x-width-at-this-height
 667     exch mul             % y x-width-at-this-height xprop
 668     exch                 % x y
 669 } def
 670
 671 /arrow {
 672   ${\ arrow_any("0 0 moveto  arrowlen 0 rlineto") }
 673 } def
 674
 675 END
 676
 677 sub def_image ($$) {
 678   my ($ncomps, $name) = @_;
 679
 680   my $ext = $ncomps == 1 ? 'pgm' : $ncomps == 3 ? 'ppm' : die;
 681   my $oper = $ncomps == 1 ? 'image' :
 682              $ncomps == 3 ? 'false 3 colorimage' : die;
 683   my $magic = $ncomps == 1 ? 'P2' : $ncomps == 3 ? 'P3' : die;
 684
 685   open B, "$name.$ext" or die $!;
 686   <B> eq "$magic\n" or die "$name.$ext expected $magic";
 687   local $/ = undef;
 688   my @d = split ' ', <B>;
 689   close B;
 690
 691   my $w = shift @d;
 692   my $h = shift @d;
 693   my $maxval = shift @d;
 694   die unless $maxval eq 255;
 695
 696   my $sz = $w/17.0;
 697   my $hsz = $sz/2;
 698
 699   $ps_framing .= <<END . '{<';
 700 /${name}_image {
 701   $w $h 8
 702   [ -$sz 0 0  -$sz  $w 2 div  $h 2 div  ]
 703 END
 704   for (my $i=0; $i< $w*$h*$ncomps; $i++) {
 705     $ps_framing .= sprintf "%02x", shift @d;
 706   }
 707   $ps_framing .= <<END;
 708 >} $oper
 709 } def
 710 END
 711 }
 712
 713 sub tile {
 714   my @tiles;
 715   my $index = 1;
 716
 717   foreach my $spec (@_) {
 718     my @datas;
 719     foreach my $stem (split m{/}, $spec) {
 720       my $func = $stem;
 721       $func =~ y/-/_/;
 722       $func = ${*::}{"book_$func"} // die "$func ?";
 723       my $data = $func->();
 724       $data .= <<END;
 725     /Courier-Bold findfont 6 scalefont setfont
 726     -0.98 0.94 dc moveto
 727     ($index) show
 728 END
 729       open F, ">book-$stem.ps" or die $!;
 730       print F $ps_framing, $data, "\nshowpage\n" or die $!;
 731       close F or die $!;
 732       push @datas, $data;
 733     }
 734     foreach my $dd (@datas) {
 735       push @tiles, $dd;
 736     }
 737     $index++;
 738   }
 739
 740   my $pos = 0;
 741   my $o = '';
 742   my $showpage = sub {
 743     $o .= <<END;
 744 showpage
 745 $page_pre
 746 END
 747   };
 748
 749   while (my $d = pop @tiles) {
 750     if ($pos >= 5) {
 751       $pos -= 5;
 752       $showpage->();
 753     }
 754     $o .= <<END;
 755 gsave
 756 END
 757     if ($pos < 3) {
 758       $o .= <<END
 759         0   th 10 add  $pos mul  translate
 760 END
 761     } else {
 762       $o .= <<END
 763 tw 2 mul 7 add
 764    dup    th add  0 translate
 765    90 rotate
 766    $pos 3 sub mul  0 translate
 767 END
 768     }
 769     $o .= "\n".$d."\n";
 770     $o .= <<END;
 771 grestore
 772 END
 773     $pos++;
 774   }
 775   $showpage->();
 776   $o;
 777 }
 778
 779 def_image(1, "bag");
 780 def_image(1, "pot");
 781 def_image(3, "droplet");
 782
 783 print $ps_framing or die $!;
 784
 785 print "gsave\n" or die $!;
 786
 787 print tile(@ARGV) or die $! if 1;
 788