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
  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 ps_start (;$) {
  69   my ($adj) = @_;
  70   $adj //= '';
  71
  72   $page_pre = <<END;
  73 72 25.4 div dup scale
  74 %210 0 translate
  75 %90 rotate
  76 $adj
  77 END
  78
  79   $ps_framing .= <<END;
  80 %!
  81
  82 $page_pre
  83
  84 /tw 57.5 def
  85 /th 73 def
  86 /bdiag 5 def
  87 /thirdlineh 0.45 def
  88 /costcirch 0.3 def
  89 /chip 15 def
  90 /spot 3.5 def
  91 /arrowlen 6 def
  92 /arrowhead 3 def
  93 /putback_len 10 def
  94
  95 /costtexth 0.215 def
  96 /costtextsz 12 def
  97 /costtextdx -0.03 def
  98 /costfont /Heletica-BoldOblique findfont costtextsz scalefont def
  99
 100 /rubysz 4 def
 101
 102 % diagonal conversion
 103 /dc {                    % xprop yprop
 104     dup th mul           % xprop yprop y
 105     3 1 roll             % y xprop yprop
 106     bdiag mul neg        % y xprop x-margin-at-this-height
 107     tw add               % y xprop x-width-at-this-height
 108     exch mul             % y x-width-at-this-height xprop
 109     exch                 % x y
 110 } def
 111
 112 /arrow {
 113   ${\ arrow_any("0 0 moveto  arrowlen 0 rlineto") }
 114 } def
 115
 116 END
 117 }
 118
 119 1;