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.5 setgray
  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 o <<END;
  63     /Helvetica-Bold findfont 6.5 scalefont setfont
  64 END
  65
  66 sub veepsq ($) {
  67   my ($veeps) = @_;
  68
  69   my $sqx = 4.1;
  70   my $sqy = 3.2;
  71
  72   <<END;
  73   gsave
  74     -1.5 -3.0 translate
  75
  76     gsave
  77       newpath  -$sqx -$sqy moveto
  78                -$sqx  $sqy lineto
  79                 $sqx  $sqy lineto
  80                 $sqx -$sqy lineto closepath
  81
  82        gsave 1 setgray fill grestore
  83        0.5 setlinewidth
  84        stroke
  85     grestore
  86
  87     0 0 moveto
  88     ($veeps) dup  stringwidth pop -0.5 mul -2.5 rmoveto  show
  89   grestore
  90 END
  91 }
  92
  93 sub places ($) {
  94   my ($repi) = @_;
  95   my $data = <<END;
  96     -1-L*H -1
  97         -1  0   34 14
  98         -H  V   34 14 1
  99          0  0   34 15
 100          0 -1   35 15
 101          0 -2   35 16
 102          H -2-V 35 16 1
 103          1 -2   36 16
 104          1 -1   37 16
 105      1+R*H  0
 106 END
 107   my $line;
 108   my $line_word = 'moveto';
 109
 110   my $o = '';
 111
 112   $o .= <<END;
 113     gsave
 114 END
 115   foreach (split /\n/, $data) {
 116     s{\#.*}{};
 117     next unless m/\S/;
 118     s{^\s*}{};
 119     s{L}{ ($repi == 0         ? 1 : 0) }ge;
 120     s{R}{ ($repi == $nrepis-1 ? 1 : 0) }ge;
 121     s{H}{ 0.5 }ge;
 122     s{V}{ $vhalf / $spacing }ge;
 123     my ($x,$y,$money,$veeps,$ruby) = map { eval $_ } split /\s+/;
 124     $ruby ||= 0;
 125     $x *= $colspacing;
 126     $y *= $spacing;
 127     $x += $x_pl_zero;
 128     $y += $y_pl_zero;
 129
 130     $line .= " $x $y $line_word";
 131     $line_word = 'lineto';
 132     next unless defined $money;
 133
 134     $money += 4 * $repi;
 135     $veeps += 2 * $repi;
 136
 137     $o .= <<END;
 138 % place $x $y $money $veeps $ruby
 139 gsave
 140   $x $y translate
 141   gsave ${\ chip($anychip, 0) } grestore
 142   -4 1 moveto ($money) show
 143
 144   ${\ veepsq($veeps) }
 145 END
 146
 147     $o .= <<END if $ruby;
 148  gsave
 149    6 -1 translate
 150    0.8 dup scale
 151    ${ \ruby() }
 152  grestore
 153 END
 154
 155     $o .= <<END;
 156 grestore
 157 END
 158   }
 159   $o .= <<END;
 160     grestore
 161 END
 162
 163   (" newpath $line stroke ", $o)
 164 }
 165
 166 sub repis () {
 167   for my $places_i (qw(0 1)) {
 168     for my $repi (0..$nrepis-1) {
 169       o(<<END);
 170 % repi $places_i $repi
 171 gsave
 172   $repi $colspacing 2 mul mul  0 translate
 173 END
 174
 175       o( (places($repi))[$places_i] );
 176       o(<<END);
 177 grestore
 178 END
 179     }
 180   }
 181 }
 182
 183 sub set () {
 184   o(<<END);
 185     cut_line
 186     gsave
 187       $paper_x $x_cut sub  0 translate
 188       cut_line
 189     grestore
 190 END
 191   o some_cut_line <<END;
 192                                  newpath
 193     0                    $y_top  moveto
 194     $paper_x $x_cut sub  $y_top  lineto
 195                                  stroke
 196 END
 197
 198   repis();
 199
 200   o <<END;
 201     gsave
 202       $paper_x $x_cut sub  $y_top 7 sub translate
 203
 204       gsave
 205         arrowlen 2 add neg  0 translate
 206         ${\ arrow_any("arrowlen 0 moveto  -30 0 rlineto") }
 207       grestore
 208
 209       -40 0 translate
 210       /Helvetica-Bold findfont 6.5 scalefont setfont
 211
 212      0 0 moveto
 213      (+8) show
 214     grestore
 215 END
 216 }
 217
 218 set();
 219 o <<END;
 220 gsave 0 $y_top translate
 221 END
 222 set();
 223 o <<END;
 224 grestore
 225 END
 226
 227 print $ps_framing or die $!;