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