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_head
  19
  20  arrow_any
  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 our $anychip = ['0.8', '0'];
  35 our $black = colour('0');
  36
  37 sub colour ($) {
  38   my ($c) = @_;
  39   if ($c =~ m{^(\d+)/(\d+)/(\d+)$}) {
  40     return (join ' ', map { $_ / 255.0 } ($1,$2,$3)).' setrgbcolor';
  41   } elsif ($c =~ m/[^ 0-9.]/) {
  42     return $c;
  43   } elsif ($c =~ m/^\s*\S+\s*$/) {
  44     return "$c setgray";
  45   } elsif ($c =~ m/./) {
  46     return "$c setrgbcolor";
  47   } else {
  48     return '';
  49   }
  50 }
  51
  52 our $page_pre = <<END;
  53 72 25.4 div dup scale
  54 %210 0 translate
  55 %90 rotate
  56 7 30 translate
  57 END
  58
  59 our $ps_framing = '';
  60
  61 sub arrow_any ($) { <<END;
  62   $black 1 setlinewidth
  63     newpath
  64        $_[0]
  65        arrowlen 0 moveto
  66        arrowhead dup neg exch  rmoveto
  67        arrowhead dup neg       rlineto
  68        arrowhead neg dup       rlineto
  69        stroke
  70 END
  71 };
  72
  73 sub ps_head () {
  74   $ps_framing .= <<END;
  75 %!
  76
  77 $page_pre
  78
  79 /tw 57.5 def
  80 /th 73 def
  81 /bdiag 5 def
  82 /thirdlineh 0.45 def
  83 /costcirch 0.3 def
  84 /chip 15 def
  85 /spot 3.5 def
  86 /arrowlen 6 def
  87 /arrowhead 3 def
  88 /putback_len 10 def
  89
  90 /costtexth 0.215 def
  91 /costtextsz 12 def
  92 /costtextdx -0.03 def
  93 /costfont /Heletica-BoldOblique findfont costtextsz scalefont def
  94
  95 /rubysz 4 def
  96
  97 % diagonal conversion
  98 /dc {                    % xprop yprop
  99     dup th mul           % xprop yprop y
 100     3 1 roll             % y xprop yprop
 101     bdiag mul neg        % y xprop x-margin-at-this-height
 102     tw add               % y xprop x-width-at-this-height
 103     exch mul             % y x-width-at-this-height xprop
 104     exch                 % x y
 105 } def
 106
 107 /arrow {
 108   ${\ arrow_any("0 0 moveto  arrowlen 0 rlineto") }
 109 } def
 110
 111 END
 112 }
 113
 114 1;