pumpkin-books.ps.pl

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