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