eval '(exit $?0)' && eval 'exec perl -S $0 ${1+"$@"}' && eval 'exec perl -S $0 $argv:q'
  if 0;
use strict;
# ==============================================================================
# psftopst
# Version 1.0 (Mercredi 19 octobre 2011)                      Jean-Michel Sarlat
# Ce script fait partie du projet pst-anamorphosis         (Gilg, Luque, Sarlat)
# http://melusine.eu.org/syracuse/G/pst-anamorphosis                    Checkout
# http://melusine.eu.org/syracuse/G/git/?p=pst-anamorphosis.git              git
# ==============================================================================

our $windows_pstoedit = 'chemin vers pstoedit.exe';

our $on_windows = $^O =~ /^MSWin/;
our $GS = $on_windows ? "gswin32c" : "gs";
our $PS = $on_windows ? $windows_pstoedit : "pstoedit";


# ===  Acquisition des options de la ligne de commande -------------------------
$::opt_dimmax        =  4;                # Dimension maximale : 4 cm par défaut
$::opt_ps            =  0;                # Transformation initiale par pstoedit
use Getopt::Long;
GetOptions(
    "dimmax=s",
    "ps"
);

our $debug  = 1;

our $GSBBOX = "$GS -sDEVICE=bbox -dBATCH -dNOPAUSE -dNOSAFER -P -c save pop -f";

our $cm = 28.3464567;

our $Fichier = $ARGV[0];
-f $Fichier or die "Fichier <$Fichier> introuvable !\n";

our ($Nom, $Dir, $Ext) = &FichierNRE($Fichier);

# === Transformation éventuelle par pstoedit -----------------------------------
if ($::opt_ps) {
  use File::Copy;
  my $f = "$Nom-original.$Ext";
  copy($Fichier, $f);
  my @a = ($PS, "-f", "ps", $f, $Fichier);
  $debug and print STDERR "Processing by pstoedit...\n";
  system(@a) == 0 or die "Running pstoedit failed\nCommand :".join(" ",@a)."\n";
  $debug and print STDERR "Ok!\n";
}
# ==============================================================================

our $ps                = &FichierListe($Fichier);
our $table             = [];
our @Bbox              = ();

our $cmyk              = {};
our $centrex           = 0;
our $centrey           = 0;

our $facteur           = 1;
our $DimMax            = $::opt_dimmax;

our $PageSizeX         = 0;
our $PageSizeY         = 0;

our @currentpoint      = ();
our @lastpoint         = ();
our $dmax              = 0;

# ==============================================================================
# === Analyse
# ==============================================================================
$$table[0] = {
  fichier  => $Fichier,
  source   => &FichierScalaire($Fichier),
  createur => "psftopst"
};
&LecturePostScript($table, $ps);
$$table[0]->{bbox} = \@Bbox;
# ==============================================================================
# === Production
# ==============================================================================
our $pst               = &EcritureFichierPST($table, $Nom);
open PST, ">$Nom.pst" and print PST $pst and close PST;
# ==============================================================================

sub EcritureFichierPST {
  my ($r, $n) = @_;
  my $c       = $$r[0]->{cmyk};
  my $nc      = 1;
  my $out     = "%\@PATRON:pstricks\n";
  $out       .= "\\makeatletter\n\\def\\psfs\@asolid{\\pst\@fill{\\pst\@usecolor\\psfillcolor eofill}}\n\\makeatother\n";
  # Définition des couleurs dans le fichier pstricks
  # Elles sont reprises dans la table représentant le fichier ps
  $out .= "%\@COULEURS:\n";
  foreach (@$c) {
    my $roman = &Roman($nc);
    $$cmyk{$_} = "Couleur$roman";
    s/\s/\,/g;
    $out .= "\\definecolor{Couleur$roman}{cmyk}{$_}\n";
    $nc++;
  }
  # Acquisition du centre de l'image
  my $b = $$r[0]->{bbox};
  $out    .= "%\@BOUNDINGBOX: " . join(" ", @$b) . "\n";
  $centrex = ($$b[2] + $$b[0]) / 2;
  $centrey = ($$b[3] + $$b[1]) / 2;
  $out    .= "%\@TRANSLATION: -($centrex,$centrey)\n";
  my $l    = ($$b[2] - $$b[0]);
  my $h    = ($$b[3] - $$b[1]);
  my $max  = $l; $max = $h if $h > $l;
  $facteur = $DimMax / $max;
  $out    .= "%\@FACTEUR: $facteur\n";
  my $abox = &xy_couple_modifie($b);
  $out    .= "%\@PSPICTURE:\n";
  $out    .= "% \\begin{pspicture}$abox\n";
  if ($PageSizeX) {
    my $clipframe = &xy_couple_modifie([0, 0, $PageSizeX, $PageSizeY]);
    $out  .= "%\@CLIPPING: $PageSizeX $PageSizeY\n";
    $out  .= "% \\begin{psclip}{\\psframe[linestyle=none]$clipframe}\n";
  }
  $out    .= "%\@PICTURE:\n";
  # Éléments de construction
  for (my $i = 1; $i < scalar @$r; $i++) {
    if ($$r[$i]->{path}) {
      $out .= "%% Path : $i\n";
      my $couleur   = $$cmyk{$$r[$i]->{setcmykcolor}};
      my $epaisseur = $$r[$i]->{setlinewidth}; $epaisseur = sprintf("linewidth=%0.5fpt", $epaisseur * $facteur * $cm);
      my $t         = $$r[$i]->{type};
      $t eq "fill"   and $out .= "\\pscustom[fillstyle=solid,fillcolor=$couleur,linestyle=none]{\n";
      $t eq "eofill" and $out .= "\\pscustom[fillstyle=asolid,fillcolor=$couleur,linestyle=none]{\n";
      $t eq "clip"   and $out .= "\\psclip{\\psframe[fillstyle=none,linestyle=none]$abox}\%\n\\pscustom{\n";
      $t eq "stroke" and $out .= "\\pscustom[$epaisseur,linecolor=$couleur]{\n";
      my $p = $$r[$i]->{path};
      my $n = $$r[$i]->{closepath};
      foreach (@$p) {
        my %e = %$_;
        $e{t} eq "moveto"    and $out .= "\\moveto".&xy_couple_modifie($e{p});
        $e{t} eq "lineto"    and $out .= "\\psline".&xy_couple_modifie($e{p});
        $e{t} eq "curveto"   and $out .= "\\psbezier".&xy_couple_modifie($e{p});
        $e{t} eq "closepath" and $out .= "\\closepath";
        $out .= "\n";
        @lastpoint = @currentpoint;
      }
      $out .= "}\n";
      $$r[$i]->{type} eq "clip" and $out .= "\\endpsclip\n";
    }
  }
  $out .= "%\@---\n";
  $out .= "% \\end{psclip}\n" if $PageSizeX;
  $out .= "% \\end{pspicture}\n";
}


sub LecturePostScript {
  my ($t, $p) = @_;
  my $pathnumber = 0;
  my $natpath    = "";
  my $path       = [];
  my $fpath      = 0;
  my $niveau     = 0;
  my $nclosepath = 0;   # Nombre de closepath rencontrés
  foreach (@$p) {
    /^\%\s*(\d+)\s+pathnumber/ and $pathnumber = $1 and $$t[$pathnumber] = {};
    /^\s*gsave/    and $niveau++;
    /^\s*grestore/ and $niveau--;
    s/setPageSize\s*$// and &setPageSize($_);
    /^\%\%BoundingBox\: ([\d\.-]+) ([\d\.-]+) ([\d\.-]+) ([\d\.-]+)/ and &setBbox($1,$2,$3,$4);
    if ($pathnumber) {
      /^\%\s*filledpath/   and $natpath = "filledpath" and next;
      /^\%\s*eofilledpath/ and $natpath = "eofilledpath" and next;
      /^\%\s*strokedpath/  and $natpath = "strokedpath" and next;
      /^\%\s*clippath/     and $natpath = "clippath" and next;
      /setlinewidth$/      and $$t[$pathnumber]->{setlinewidth} = &setlinewidth($_) and next;
      /setcmykcolor$/      and $$t[$pathnumber]->{setcmykcolor} = &setcmykcolor($_) and next;
      /^newpath/ and $fpath = 1 and $path = [] and next;
      if ($fpath) {
        s/moveto\s*$//  and push(@$path, {t => "moveto", p  => &xy($_)});
        s/lineto\s*$//  and push(@$path, {t => "lineto", p  => &xy($_)});
        s/curveto\s*$// and push(@$path, {t => "curveto", p => &xy($_)});
        /closepath/     and push(@$path, {t => "closepath", p => 1}) and $nclosepath++;
        if (/(stroke)/ or /(eofill)/ or /(fill)/ or /(clip)/) {
          $fpath = 0;
          $$t[$pathnumber]->{path}      = $path;
          $$t[$pathnumber]->{type}      = $1;
          $$t[$pathnumber]->{niveau}    = $niveau;
          $$t[$pathnumber]->{closepath} = $nclosepath;
          $pathnumber = 0;
          $nclosepath = 0;
        }
      }
    }
  }
  $$t[0]->{cmyk} = [];
  foreach (keys %$cmyk) {
    push @{$$t[0]->{cmyk}}, $_;
  }
}

sub setPageSize {
  my $s = shift;
  $s =~ s/^\s*|\s*$//g;
  ($PageSizeX, $PageSizeY) = split /\s+/, $s;
}

sub setlinewidth {
  my $s = shift;
  $s =~ s/^\s*|\s+setlinewidth$//g;
  return $s;
}

sub setcmykcolor {
  my $s = shift;
  $s =~ s/^\s*|\s+setcmykcolor$//g;
  $$cmyk{$s} = 1;
  return $s;
}

sub xy {
  my $s = shift;
  $s =~ s/^\s*|\s*$//g;
  my @xy = split /\s+/, $s;
  return \@xy;
}

sub xy_couple_modifie {
  my $xy = shift;
  my @l  = @$xy; @currentpoint = ($l[-2],$l[-1]);
  my $s  = "";
  while (my ($x, $y) = splice(@l, 0, 2)) {
    $s .= sprintf("(%0.8f,%0.8f)", ($x - $centrex) * $facteur, ($y - $centrey) * $facteur);
  }
  return $s;
}

# === Contenu d'un fichier et éléments du nom ----------------------------------
# ------------------------------------------------------------------------------
# Contenu sous forme d'une liste de lignes
sub FichierListe {
  my $f = shift;
  open(FICH, $f) or die "Le fichier $f est introuvable !\n";
  my @l = <FICH>;
  close FICH;
  chomp @l;
  return \@l;
}
# Contenu en un seul élément
sub FichierScalaire {
  my $f = shift;
  local $/;
  open(FICH, $f) or die "Le fichier $f est introuvable !\n";
  my $c = <FICH>;
  close FICH;
  return $c;
}
# Nom, Repertoire et Extension d'un fichier
sub FichierNRE {
  my $f = shift;
  use File::Basename;
  my ($n, $r, $e) = fileparse($f,qw{\..*});
  $e =~ s/^\.//;
  return ($n, $r, $e);
}
# === Acquisition de la BoundingBox --------------------------------------------
sub setBbox {
  @Bbox = @_;
}

# === Écriture d'un nombre en chiffres romains ---------------------------------
# Code emprunté au module Roman.pm ; http://search.cpan.org/dist/Roman
# AUTEURS:
#   OZAWA Sakuro <ozawa at aisoft.co.jp> 1995-1997
#   Alexandr Ciornii, C<< <alexchorny at gmail.com> >> 2007
# ------------------------------------------------------------------------------
sub Roman {
  my $arg = shift;
  0 < $arg and $arg < 4000 or return undef;
  my %roman_digit = qw(1 IV 10 XL 100 CD 1000 MMMMMM);
  my @figure = reverse sort keys %roman_digit;
  $roman_digit{$_} = [split(//, $roman_digit{$_}, 2)] foreach @figure;
  my($x, $roman);
  foreach (@figure) {
    my($digit, $i, $v) = (int($arg / $_), @{$roman_digit{$_}});
    if (1 <= $digit and $digit <= 3) {
      $roman .= $i x $digit;
    } elsif ($digit == 4) {
      $roman .= "$i$v";
    } elsif ($digit == 5) {
      $roman .= $v;
    } elsif (6 <= $digit and $digit <= 8) {
      $roman .= $v . $i x ($digit - 5);
    } elsif ($digit == 9) {
      $roman .= "$i$x";
    }
    $arg -= $digit * $_;
    $x = $i;
  }
  return $roman;
}
# === Wanda --------------------------------------------------------------------
sub WandaExecutePlugin {
  my ($cnf, $elm, $args) = @_;
}
sub WandaAnalyseLignes {
  my $cnf = shift;
  my $l = shift;
  my $c = {};
  my $e = "CORPS";
  my @p = ();
  # Traitement
  for(my $i=0; $i < scalar @$l; $i++) {
    if ($$l[$i] =~ /^%@([\da-zA-Z_]+)\s*:\s*(.+?)\s*$/) {
      # Affectation simple : la valeur suit le nom dans la ligne -----
      $$c{$1} = $2;
    } elsif ($$l[$i] =~ /^%@([\da-zA-Z_]+)\s*:\s*$/) {
      # Affectation bloc : la valeur est constituée du bloc à suivre -
      push @p, $e; $e = $1;
    } elsif ($$l[$i] =~ /^%@\-\-\-/) {
      # On ferme l'élément en cours... -------------------------------
      $e = pop @p;
    } elsif ($$l[$i] =~ /^%@\@lib:\s*(.+?)\s+$/) {
      # On ajoute le contenu d'un fichier de la librairie ------------
      if (-f "$$cnf{DIR}/lib/$1") {
        $$c{$e} .= qx{cat "$$cnf{DIR}/lib/$1"} if $e;
      }
    } elsif ($$l[$i] =~ /^%@\@inc:\s*(.+?)\s+$/) {
      # On ajoute le contenu d'un fichier local ----------------------
      if (-f $1) {
        $$c{$e} .= qx{cat $1} if $e;
      }
    } elsif ($$l[$i] =~ /^%@\@exec:\s*(.+?)\s+$/) {
      # On éxécute un plugin -----------------------------------------
      $$c{$e} .= &WandaExecutePlugin($cnf, $c, $1);
    } else {
      # La ligne est enregistrée dans l'éventuel élément en cours ----
      $$c{$e} .= $$l[$i] if $e;
    }
  }
  return $c;
}
sub WandaAnalyseContenu {
  my ($cnf, $fichier) = @_;
  open(SRC, $fichier); my @LIGNES = <SRC>; close(SRC);
  return &WandaAnalyseLignes($cnf, \@LIGNES);
}