#!/usr/bin/perl -w
# Books of Pumpkins, etc.  Extensions to Quacks of Quedlinburg
#  SPDX-License-Identifier: GPL-3.0-or-later OR CC-BY-SA-4.0
# Copyright 2020-2022 Ian Jackson

use strict;

package Quacks;
use Exporter qw(import);

our @EXPORT = qw(

 $pumpkin $green $red $blue $yellow $moth $purple $lotus $white
 $anychip $black colour

 $ps_framing

 $page_pre ps_start

 arrow_any chip ruby

	       );

our $pumpkin = ["255/185/15", "0 0 0"];
our $green   = ["0/238/118", "1 1 1"];
our $red     = ["1   0  0", "0 0 0"];
our $blue    = ["0  .4 1 ", "1 1 1"];
our $yellow  = ["1  1   0", "0 0 0"];
our $moth    = [" 0  0  0", "1 1 1"];
our $purple  = ["145/44/238", "0 0 0"];
our $lotus   = [("0/245/255",) x 2];
our $white   = ["1  1   1", "0 0 0"];

sub colour ($) {
  my ($c) = @_;
  if ($c =~ m{^(\d+)/(\d+)/(\d+)$}) {
    return (join ' ', map { $_ / 255.0 } ($1,$2,$3)).' setrgbcolor';
  } elsif ($c =~ m/[^ 0-9.]/) {
    return $c;
  } elsif ($c =~ m/^\s*\S+\s*$/) {
    return "$c setgray";
  } elsif ($c =~ m/./) {
    return "$c setrgbcolor";
  } else {
    return '';
  }
}

our $anychip = ['0.8', '0'];
our $black = colour('0');

our $page_pre;

our $ps_framing = '';

sub arrow_any ($) { <<END;
  $black 1 setlinewidth
    newpath
       $_[0]
       arrowlen 0 moveto
       arrowhead dup neg exch  rmoveto
       arrowhead dup neg       rlineto
       arrowhead neg dup       rlineto
       stroke
END
};

sub chip ($$) {
  my ($cary, $pips) = @_; # put in a gsave translate
  my $o = <<END;
  newpath
  0 0 chip 0.5 mul 0 360 arc
  gsave 1 setlinewidth $black stroke grestore
  ${\ colour($cary->[0]) } fill
END
  if ($pips) {
    $o .= <<END;
  ${\ colour($cary->[1]) }
END
  }
  my $spot = sub {
    my ($x,$y) = @_;
    $o .= <<END;
    newpath
    spot 0.5 sqrt mul 1.1 mul dup
    $x mul exch $y mul
    spot 0.5 mul
    0 360 arc fill
END
  };

  $spot->( 0, 0) if $pips & 1;
  $spot->(-1,-1) if $pips & 6;
  $spot->(+1,+1) if $pips & 6;
  $spot->(-1,+1) if $pips & 4;
  $spot->(+1,-1) if $pips & 4;

  $o;
}

sub ruby () { # put in gsave translate
  <<END;
  newpath
    rubysz neg  0 moveto
    0  rubysz neg lineto
    rubysz      0 lineto
    0      rubysz lineto
    closepath
    ${\ colour('1 .2 .2') } gsave fill grestore
    $black 1 setlinewidth stroke
END
}

sub ps_start (;$) {
  my ($adj) = @_;
  $adj //= '';

  $page_pre = <<END;
72 25.4 div dup scale
%210 0 translate
%90 rotate
$adj
END

  $ps_framing .= <<END;
%!

$page_pre

/tw 57.5 def
/th 73 def
/bdiag 5 def
/thirdlineh 0.45 def
/costcirch 0.3 def
/chip 15 def
/spot 3.5 def
/arrowlen 6 def
/arrowhead 3 def
/putback_len 10 def

/costtexth 0.215 def
/costtextsz 12 def
/costtextdx -0.03 def
/costfont /Heletica-BoldOblique findfont costtextsz scalefont def

/rubysz 4 def

% diagonal conversion
/dc {                    % xprop yprop
    dup th mul           % xprop yprop y
    3 1 roll             % y xprop yprop
    bdiag mul neg        % y xprop x-margin-at-this-height
    tw add               % y xprop x-width-at-this-height
    exch mul             % y x-width-at-this-height xprop
    exch                 % x y
} def

/arrow {
  ${\ arrow_any("0 0 moveto  arrowlen 0 rlineto") }
} def

END
}

1;
