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