pumpkin-books.ps.pl

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4
   5 our $black = '0 0 0 1 setcmykcolor';
   6
   7 my $pumpkin = ["0 .50 0 1.00 0", "0 0 0 1"];
   8 my $green = ["1 0 1 0", "0 0 0 0"];
   9 my $red = ["0 1 1 0", "0 0 0 1"];
  10 my $blue = ["0.6 0.6 0 0", "0 0 0 0"];
  11 my $yellow = ["0 0 1 0", "0 0 0 1"];
  12 my $moth = ["0 0 0 1", "0 0 0 0"];
  13 my $purple = ["0 1 0 0", "0 0 0 1"];
  14
  15 sub chip ($$) {
  16   my ($cary, $pips) = @_; # put in a gsave translate
  17   my $o = <<END;
  18   newpath
  19   0 0 chip 0.5 mul 0 360 arc
  20   gsave 1 setlinewidth $black stroke grestore
  21   $cary->[0] setcmykcolor fill
  22   $cary->[1] setcmykcolor
  23 END
  24   my $spot = sub {
  25     my ($x,$y) = @_;
  26     $o .= <<END;
  27     newpath
  28     spot 0.5 sqrt mul 1.1 mul dup
  29     $x mul exch $y mul
  30     spot 0.5 mul
  31     0 360 arc fill
  32 END
  33   };
  34
  35   $spot->( 0, 0) if $pips & 1;
  36   $spot->(-1,-1) if $pips & 6;
  37   $spot->(+1,+1) if $pips & 6;
  38   $spot->(-1,+1) if $pips & 4;
  39   $spot->(+1,-1) if $pips & 4;
  40
  41   $o;
  42 }
  43
  44 sub ruby () { # put in gsave translate
  45   <<END;
  46   newpath
  47     rubysz neg  0 moveto
  48     0  rubysz neg lineto
  49     rubysz      0 lineto
  50     0      rubysz lineto
  51     closepath
  52     0 1 0.5 0 setcmykcolor gsave fill grestore
  53     $black 1 setlinewidth stroke
  54 END
  55 }
  56
  57 sub exposition ($) {
  58   my ($text) = @_;
  59   my $fontsz = 6;
  60   my $o = <<END;
  61     /Times-Roman findfont $fontsz scalefont setfont $black
  62 END
  63   chomp $text;
  64   my @lines = split /\n/, $text;
  65   foreach my $y (0..$#lines) {
  66     my $l = $lines[$y];
  67     $l =~ s/[()\\]/\\$&/g;
  68     my $yd = $fontsz * (0.5*@lines - $y);
  69     $o .= <<END;
  70     0 0.70 dc moveto
  71     0 $yd rmoveto
  72     ($l)  dup stringwidth pop -0.5 mul 0 rmoveto
  73     show
  74 END
  75   }
  76   $o;
  77 }
  78
  79
  80 sub general_book ($$) { # put in a gsave
  81   my ($this, $costs) = @_;
  82   my $o = <<END;
  83 tw  0  translate
  84
  85 3 setlinewidth
  86 0 0 0 0.2 setcmykcolor
  87 newpath
  88 0 0 dc moveto
  89 0 1 dc lineto stroke
  90
  91 $black
  92 1 setlinewidth
  93
  94 newpath
  95 -1 0  dc moveto
  96 +1 0  dc lineto
  97 +1 1  dc lineto
  98 -1 1  dc lineto
  99 closepath stroke
 100
 101 newpath
 102 0 0 dc         moveto
 103 0 thirdlineh dc rlineto
 104 -1 thirdlineh dc lineto stroke
 105
 106 /thirddivline {               % xprop
 107   newpath
 108   dup -3 div  0               dc moveto
 109       -3 div  thirdlineh      dc lineto stroke
 110                               %
 111 } def
 112
 113 1 thirddivline
 114 2 thirddivline
 115
 116 END
 117
 118   foreach my $costi (0..2) {
 119     my $cost = $costs->[$costi];
 120     my $pips = qw(1 2 4)[$costi];
 121     $o .= <<END
 122   costfont setfont
 123   -2.5 $costi add 3 div
 124 gsave
 125   dup costcirch dc translate
 126   ${\ chip($this,$pips) }
 127 grestore
 128   costtexth exch costtextdx add exch dc moveto
 129   $black
 130   ($cost)
 131   dup stringwidth pop  -0.5 mul  costtextsz neg  rmoveto
 132   show
 133 END
 134   }
 135
 136   $o;
 137 }
 138
 139 sub green_book () {
 140   my $o = general_book($green, [qw(5 9 15)]);
 141
 142   $o .= <<END;
 143 gsave 0.25 0.15 dc translate ${\ chip($pumpkin,0) } grestore
 144 gsave 0.25 0.40 dc translate ${\ chip($green,0) } grestore
 145
 146 /Times-Bold findfont
 147 dup
 148   6 scalefont setfont
 149   0.40 0.17 dc moveto (last) show
 150 %
 151   8 scalefont setfont
 152   0.40 0.09 dc moveto (3) show
 153 /Times-Roman findfont
 154   38 scalefont setfont
 155   0.45 0.14 dc moveto (}) show
 156
 157 gsave
 158   0.85 0.275 dc translate
 159   ${\ ruby() }
 160 grestore
 161 END
 162
 163   $o .= exposition(<<END);
 164 For each pumpkin in the last 3 chips,
 165 receive 1 ruby.
 166 But, not more rubies than the number
 167 of green chips in your pot.
 168 END
 169
 170   $o;
 171 }
 172
 173 sub red_book () {
 174   my $o = general_book($red, [qw(4 9 16)]);
 175
 176   $o .= <<END;
 177 gsave 0.35 0.30 dc translate ${\ chip($pumpkin,0) } grestore
 178
 179 /Times-Bold findfont
 180   15 scalefont setfont
 181   0.50 0.24 dc moveto (+1) show
 182
 183 END
 184
 185   $o .= exposition(<<END);
 186 The next 1/2/4 pumpkins you place are
 187 each moved one extra space.
 188 (After applying any other special effects;
 189 one extra space no matter how many reds)
 190 END
 191
 192   $o;
 193 }
 194
 195 sub blue_book () {
 196   my $o = general_book($blue, [qw(4 9 16)]);
 197
 198   $o .= <<END;
 199 /Times-Bold findfont 15 scalefont setfont $black
 200 END
 201
 202   my $exchip = sub {
 203     my ($that, $pips) = @_;
 204     <<END;
 205   gsave ${\ chip($that, $pips) } grestore
 206 END
 207   };
 208   my $exslash = sub {
 209     <<END;
 210     8 -5 moveto (/) show
 211     20 0 translate
 212 END
 213   };
 214
 215   my $exchline = sub {
 216     my ($y, $pips, $content) = @_;
 217     <<END;
 218 gsave
 219   0.16 0.15 0.16 $y mul add dc translate
 220   0.60 dup scale
 221   gsave ${\ chip($blue,$pips) } grestore
 222   8 -3 moveto (:) show
 223   3 0 translate
 224   0.8 dup scale
 225   21 0 translate
 226 $content
 227 grestore
 228 END
 229   };
 230
 231   $o .= $exchline->(2, 1, <<END);
 232   ${\ $exchip->($green,1) }  ${\ $exslash->() }
 233   ${\ $exchip->($red,  1) }  ${\ $exslash->() }
 234   ${\ $exchip->($blue, 1) }  ${\ $exslash->() }
 235   ${\ $exchip->($yellow, 1) }
 236 END
 237
 238   $o .= $exchline->(1, 2, <<END);
 239   ${\ $exchip->($moth,1) }  ${\ $exslash->() }
 240   ${\ $exchip->($purple,1) }  ${\ $exslash->() }
 241 END
 242
 243   $o .= $exchline->(0, 4, <<END);
 244 END
 245
 246   $o .= exposition(<<END);
 247 If the previous chip placed was a pumpkin,
 248 you may exchange it as follows:
 249
 250 END
 251
 252   $o;
 253 }
 254
 255 sub tile {
 256   my $pos = 0;
 257   my $o = '';
 258   my $showpage = sub {
 259     $o .= <<END;
 260 showpage
 261 END
 262   };
 263   while (my $d = shift @_) {
 264     if ($pos >= 5) {
 265       $pos -= 5;
 266       $showpage->();
 267     }
 268     $o .= <<END;
 269 gsave
 270 END
 271     if ($pos < 3) {
 272       $o .= <<END
 273         0   th 10 add  $pos mul  translate
 274 END
 275     } else {
 276       $o .= <<END
 277 tw 2 mul 7 add
 278    dup    th add  0 translate
 279    90 rotate
 280    $pos 3 sub mul  0 translate
 281 END
 282     }
 283     $o .= "\n".$d."\n";
 284     $o .= <<END;
 285 grestore
 286 END
 287     $pos++;
 288   }
 289   $showpage->();
 290   $o;
 291 }
 292
 293 print <<END or die $!;
 294 %!
 295
 296 72 25.4 div dup scale
 297 %210 0 translate
 298 %90 rotate
 299 7 10 translate
 300
 301 /tw 57.5 def
 302 /th 73 def
 303 /bdiag 5 def
 304 /thirdlineh 0.45 def
 305 /costcirch 0.3 def
 306 /chip 15 def
 307 /spot 3.5 def
 308 /arrowlen 6 def
 309 /arrowhead 3 def
 310
 311 /costtexth 0.215 def
 312 /costtextsz 12 def
 313 /costtextdx -0.03 def
 314 /costfont /Heletica-BoldOblique findfont costtextsz scalefont def
 315
 316 /rubysz 4 def
 317
 318 % diagonal conversion
 319 /dc {                    % xprop yprop
 320     dup th mul           % xprop yprop y
 321     3 1 roll             % y xprop yprop
 322     bdiag mul neg        % y xprop x-margin-at-this-height
 323     tw add               % y xprop x-width-at-this-height
 324     exch mul             % y x-width-at-this-height xprop
 325     exch                 % x y
 326 } def
 327
 328 /arrow {
 329   $black 1 setlinewidth
 330     newpath
 331        0 0 moveto  arrowlen 0 rlineto
 332        arrowhead dup neg exch  rmoveto
 333        arrowhead dup neg       rlineto
 334        arrowhead neg dup       rlineto
 335        stroke
 336 } def
 337
 338 END
 339
 340 print tile(
 341            green_book(),
 342            red_book(),
 343            blue_book(),
 344           ) or die $! if 1;