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 sub places ($) {
  63   my ($repi) = @_;
  64   my $data = <<END;
  65         -1 -1
  66         -1  0   34 14
  67         -H  V   34 14 *
  68          0  0   34 15
  69          0 -1   35 15
  70          0 -2   35 16
  71          H -2-V 35 16 *
  72          1 -2   36 16
  73          1 -1   37 16
  74          1  0
  75 END
  76   my $line;
  77   my $line_word = 'moveto';
  78
  79   my $o = '';
  80
  81   $o .= <<END;
  82     gsave
  83     /Helvetica-Bold findfont 8 scalefont setfont
  84 END
  85   foreach (split /\n/, $data) {
  86     s{\#.*}{};
  87     next unless m/\S/;
  88     s{^\s*}{};
  89     s{H}{ 0.5 }ge;
  90     s{V}{ $vhalf / $spacing }ge;
  91     s{\*}{1}eg;
  92     my ($x,$y,$money,$veeps,$ruby) = map { eval $_ } split /\s+/;
  93     $ruby ||= 0;
  94     $x *= $colspacing;
  95     $y *= $spacing;
  96
  97     $line .= " $x $y $line_word";
  98     $line_word = 'lineto';
  99     next unless defined $money;
 100
 101     $money += 4 * $repi;
 102     $veeps += 2 * $repi;
 103
 104     $o .= <<END;
 105 % place $x $y $money $veeps $ruby
 106 gsave
 107   $x_pl_zero $y_pl_zero translate
 108   $x $y translate
 109   gsave ${\ chip($anychip, 0) } grestore
 110   -5 0 moveto ($money) show
 111 grestore
 112 END
 113   }
 114   $o .= <<END;
 115     grestore
 116 END
 117
 118   ("newpath $line stroke", $o)
 119 }
 120
 121 sub repis () {
 122   for my $repi (0..$nrepis-1) {
 123     o(<<END);
 124 gsave
 125   $repi $colspacing 2 mul mul  0 translate
 126 END
 127
 128     o( (places($repi))[1] );
 129     o(<<END);
 130 grestore
 131 END
 132   }
 133 }
 134
 135 sub set () {
 136   o(<<END);
 137     cut_line
 138     gsave
 139       $paper_x $x_cut sub  0 translate
 140       cut_line
 141     grestore
 142 END
 143   o some_cut_line <<END;
 144                                  newpath
 145     0                    $y_top  moveto
 146     $paper_x $x_cut sub  $y_top  lineto
 147                                  stroke
 148 END
 149
 150   repis();
 151 }
 152
 153 set();
 154
 155 print $ps_framing or die $!;