overflow-tube.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-2022 Ian Jackson
   5
   6 use strict;
   7
   8 BEGIN { unshift @INC, '.'; }
   9 use Quacks;
  10
  11 sub o {
  12   local $_;
  13   for (@_) { $ps_framing .= $_ }
  14 }
  15
  16 ps_start(<<END);
  17 %90 rotate
  18 %0 -210 translate
  19 END
  20
  21 my $x_cut = 27;
  22 my $y_cutd = 10;
  23
  24 my $nrepis = 4;
  25
  26 my $paper_x = 210;
  27
  28 my $spacing = 23;
  29 my $colspacing = 23;
  30 my $vhalf = sqrt( $spacing ** 2 - ($colspacing*0.5) ** 2 );
  31
  32 my $y_cut = 2.75 * $spacing;
  33
  34 my $x_pl_zero = $paper_x*0.5 - 3*$colspacing;
  35 my $y_pl_zero = $y_cut + $spacing - $y_cutd* 0.5 * $x_cut/$colspacing;
  36
  37 my $y_top = $y_pl_zero + $y_cutd + $spacing*1.25;
  38
  39 our $veep_bg = " 0.95 0.90 0.67 setrgbcolor ";
  40
  41 sub some_cut_line($) {
  42   <<END;
  43 gsave
  44   0.25 setlinewidth
  45   $_[0]
  46 grestore
  47 END
  48 }
  49
  50
  51 o <<GS, some_cut_line(<<GR), <<END;
  52 /cut_line {
  53 GS
  54                               newpath
  55   $x_cut 0                    moveto
  56   $x_cut $y_cut               lineto
  57   0      $y_cut $y_cutd add   lineto
  58   0      $y_top               lineto
  59                               stroke
  60 GR
  61 } def
  62 END
  63
  64 my $veep_font = "/Helvetica-Bold findfont 6.5 scalefont setfont";
  65 my $money_font = "/Helvetica-BoldOblique findfont 6.5 scalefont setfont";
  66
  67 o <<END;
  68 $money_font
  69 END
  70
  71 sub veepsq ($) {
  72   my ($veeps) = @_;
  73
  74   my $sqx = 4.1;
  75   my $sqy = 3.2;
  76
  77   <<END;
  78   gsave
  79     -1.5 -3.0 translate
  80
  81     gsave
  82       newpath  -$sqx -$sqy moveto
  83                -$sqx  $sqy lineto
  84                 $sqx  $sqy lineto
  85                 $sqx -$sqy lineto closepath
  86
  87        gsave
  88              $veep_bg
  89              fill
  90        grestore
  91        0.19 0.35 0.25 setrgbcolor
  92        0.5 setlinewidth
  93        stroke
  94     grestore
  95
  96     $veep_font
  97     0 0 moveto
  98     ($veeps) dup  stringwidth pop -0.5 mul -2.5 rmoveto  show
  99   grestore
 100 END
 101 }
 102
 103 sub places ($) {
 104   my ($repi) = @_;
 105   my $data = <<END;
 106     -1-L*H -1
 107         -1  0   34 14
 108         -H  V   34 14 1
 109          0  0   34 15
 110          0 -1   35 15
 111          0 -2   35 16
 112          H -2-V 35 16 1
 113          1 -2   36 16
 114          1 -1   37 16
 115      1+R*H  0
 116 END
 117   my $line;
 118   my $line_word = 'moveto';
 119
 120   my $o = '';
 121
 122   $o .= <<END;
 123     gsave
 124 END
 125   foreach (split /\n/, $data) {
 126     s{\#.*}{};
 127     next unless m/\S/;
 128     s{^\s*}{};
 129     s{L}{ ($repi == 0         ? 1 : 0) }ge;
 130     s{R}{ ($repi == $nrepis-1 ? 1 : 0) }ge;
 131     s{H}{ 0.5 }ge;
 132     s{V}{ $vhalf / $spacing }ge;
 133     my ($x,$y,$money,$veeps,$ruby) = map { eval $_ } split /\s+/;
 134     $ruby ||= 0;
 135     $x *= $colspacing;
 136     $y *= $spacing;
 137     $x += $x_pl_zero;
 138     $y += $y_pl_zero;
 139
 140     $line .= " $x $y $line_word";
 141     $line_word = 'lineto';
 142     next unless defined $money;
 143
 144     $money += 4 * $repi;
 145     $veeps += 2 * $repi;
 146
 147     $o .= <<END;
 148 % place $x $y $money $veeps $ruby
 149 gsave
 150   $x $y translate
 151   gsave
 152     newpath
 153     0 0 chip 0.5 mul 0 360 arc
 154     gsave 0.5 setlinewidth $black stroke grestore
 155     0.80 0.89 0.63 setrgbcolor fill
 156   grestore
 157
 158   -4.7 1 moveto ($money) show
 159
 160   ${\ veepsq($veeps) }
 161 END
 162
 163     $o .= <<END if $ruby;
 164  gsave
 165    6 -1 translate
 166    0.8 dup scale
 167    ${ \ruby() }
 168  grestore
 169 END
 170
 171     $o .= <<END;
 172 grestore
 173 END
 174   }
 175   $o .= <<END;
 176     grestore
 177 END
 178
 179   $line = <<END;
 180   newpath
 181     0.66 0.85 0.75 setrgbcolor
 182     4 setlinewidth
 183   $line
 184   stroke
 185 END
 186
 187   ($line, $o)
 188 }
 189
 190 sub repis () {
 191   for my $places_i (qw(0 1)) {
 192     for my $repi (0..$nrepis-1) {
 193       o(<<END);
 194 % repi $places_i $repi
 195 gsave
 196   $repi $colspacing 2 mul mul  0 translate
 197 END
 198
 199       o( (places($repi))[$places_i] );
 200       o(<<END);
 201 grestore
 202 END
 203     }
 204   }
 205 }
 206
 207 sub set () {
 208   o(<<END);
 209     cut_line
 210     gsave
 211       $paper_x $x_cut sub  0 translate
 212       cut_line
 213     grestore
 214 END
 215   o some_cut_line <<END;
 216                                  newpath
 217     0                    $y_top  moveto
 218     $paper_x $x_cut sub  $y_top  lineto
 219                                  stroke
 220 END
 221
 222   repis();
 223
 224   o <<END;
 225     gsave
 226       /Times-Roman findfont 4.0 scalefont setfont
 227       4 97 moveto  (cover) show
 228       6 93.5 moveto  (up) show
 229       4 89 moveto
 230       /Helvetica-Bold-Italic findfont 3.5 scalefont setfont (35) show
 231       1 0 rmoveto
 232       /Helvetica-Bold findfont 3.5 scalefont setfont (15) show
 233     grestore
 234
 235     gsave
 236       $paper_x $x_cut sub  $y_top 7 sub translate
 237
 238       gsave
 239         arrowlen 2 add neg  0 translate
 240         ${\ arrow_any("arrowlen 0 moveto  -30 0 rlineto") }
 241       grestore
 242
 243       -40 0 translate
 244       /Helvetica-Bold findfont 6.5 scalefont setfont
 245
 246      -4.5 0 moveto
 247      $money_font
 248      (+16) show
 249
 250      4 -2 translate
 251      ${\ veepsq('+8') }
 252
 253      4 4.5 moveto
 254      /Times-Roman findfont 4.5 scalefont setfont
 255      (per next page) show
 256
 257     grestore
 258 END
 259 }
 260
 261 set();
 262 o <<END;
 263 gsave 0 $y_top translate
 264 END
 265 set();
 266 o <<END;
 267 grestore
 268 END
 269
 270 print $ps_framing or die $!;