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
9 use Exporter qw(import);
13 $pumpkin $green $red $blue $yellow $moth $purple $lotus $white
14 $anychip $black colour
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"];
36 if ($c =~ m{^(\d+)/(\d+)/(\d+)$}) {
37 return (join ' ', map { $_ / 255.0 } ($1,$2,$3)).' setrgbcolor';
38 } elsif ($c =~ m/[^ 0-9.]/) {
40 } elsif ($c =~ m/^\s*\S+\s*$/) {
42 } elsif ($c =~ m/./) {
43 return "$c setrgbcolor";
49 our $anychip = ['0.8', '0'];
50 our $black = colour('0');
56 sub arrow_any ($) { <<END;
61 arrowhead dup neg exch rmoveto
62 arrowhead dup neg rlineto
63 arrowhead neg dup rlineto
98 /costfont /Heletica-BoldOblique findfont costtextsz scalefont def
102 % diagonal conversion
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
113 ${\ arrow_any("0 0 moveto arrowlen 0 rlineto") }