Quacks.pm

   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 package Quacks;
   9 use Exporter qw(import);
  10
  11 our @EXPORT = qw(
  12
  13  $pumpkin $green $red $blue $yellow $moth $purple $lotus $white
  14  $anychip $black colour
  15
  16  $ps_framing
  17
  18  $page_pre ps_start
  19
  20  arrow_any chip ruby
  21
  22                );
  23
  24 our $pumpkin = ["255/185/15", "0 0 0"];
  25 our $green   = ["0/238/118", "1 1 1"];
  26 our $red     = ["1   0  0", "0 0 0"];
  27 our $blue    = ["0  .4 1 ", "1 1 1"];
  28 our $yellow  = ["1  1   0", "0 0 0"];
  29 our $moth    = [" 0  0  0", "1 1 1"];
  30 our $purple  = ["145/44/238", "0 0 0"];
  31 our $lotus   = [("0/245/255",) x 2];
  32 our $white   = ["1  1   1", "0 0 0"];
  33
  34 sub colour ($) {
  35   my ($c) = @_;
  36   if ($c =~ m{^(\d+)/(\d+)/(\d+)$}) {
  37     return (join ' ', map { $_ / 255.0 } ($1,$2,$3)).' setrgbcolor';
  38   } elsif ($c =~ m/[^ 0-9.]/) {
  39     return $c;
  40   } elsif ($c =~ m/^\s*\S+\s*$/) {
  41     return "$c setgray";
  42   } elsif ($c =~ m/./) {
  43     return "$c setrgbcolor";
  44   } else {
  45     return '';
  46   }
  47 }
  48
  49 our $anychip = ['0.8', '0'];
  50 our $black = colour('0');
  51
  52 our $page_pre;
  53
  54 our $ps_framing = '';
  55
  56 sub arrow_any ($) { <<END;
  57   $black 1 setlinewidth
  58     newpath
  59        $_[0]
  60        arrowlen 0 moveto
  61        arrowhead dup neg exch  rmoveto
  62        arrowhead dup neg       rlineto
  63        arrowhead neg dup       rlineto
  64        stroke
  65 END
  66 };
  67
  68 sub chip ($$) {
  69   my ($cary, $pips) = @_; # put in a gsave translate
  70   my $o = <<END;
  71   newpath
  72   0 0 chip 0.5 mul 0 360 arc
  73   gsave 1 setlinewidth $black stroke grestore
  74   ${\ colour($cary->[0]) } fill
  75 END
  76   if ($pips) {
  77     $o .= <<END;
  78   ${\ colour($cary->[1]) }
  79 END
  80   }
  81   my $spot = sub {
  82     my ($x,$y) = @_;
  83     $o .= <<END;
  84     newpath
  85     spot 0.5 sqrt mul 1.1 mul dup
  86     $x mul exch $y mul
  87     spot 0.5 mul
  88     0 360 arc fill
  89 END
  90   };
  91
  92   $spot->( 0, 0) if $pips & 1;
  93   $spot->(-1,-1) if $pips & 6;
  94   $spot->(+1,+1) if $pips & 6;
  95   $spot->(-1,+1) if $pips & 4;
  96   $spot->(+1,-1) if $pips & 4;
  97
  98   $o;
  99 }
 100
 101 sub ruby () { # put in gsave translate
 102   <<END;
 103   newpath
 104     rubysz neg  0 moveto
 105     0  rubysz neg lineto
 106     rubysz      0 lineto
 107     0      rubysz lineto
 108     closepath
 109     ${\ colour('1 .2 .2') } gsave fill grestore
 110     $black 1 setlinewidth stroke
 111 END
 112 }
 113
 114 sub ps_start (;$) {
 115   my ($adj) = @_;
 116   $adj //= '';
 117
 118   $page_pre = <<END;
 119 72 25.4 div dup scale
 120 %210 0 translate
 121 %90 rotate
 122 $adj
 123 END
 124
 125   $ps_framing .= <<END;
 126 %!
 127
 128 $page_pre
 129
 130 /tw 57.5 def
 131 /th 73 def
 132 /bdiag 5 def
 133 /thirdlineh 0.45 def
 134 /costcirch 0.3 def
 135 /chip 15 def
 136 /spot 3.5 def
 137 /arrowlen 6 def
 138 /arrowhead 3 def
 139 /putback_len 10 def
 140
 141 /costtexth 0.215 def
 142 /costtextsz 12 def
 143 /costtextdx -0.03 def
 144 /costfont /Heletica-BoldOblique findfont costtextsz scalefont def
 145
 146 /rubysz 4 def
 147
 148 % diagonal conversion
 149 /dc {                    % xprop yprop
 150     dup th mul           % xprop yprop y
 151     3 1 roll             % y xprop yprop
 152     bdiag mul neg        % y xprop x-margin-at-this-height
 153     tw add               % y xprop x-width-at-this-height
 154     exch mul             % y x-width-at-this-height xprop
 155     exch                 % x y
 156 } def
 157
 158 /arrow {
 159   ${\ arrow_any("0 0 moveto  arrowlen 0 rlineto") }
 160 } def
 161
 162 END
 163 }
 164
 165 1;