#!/usr/bin/perl -w
# file KLEIDER/web/src/addstory/imgselect.pl
# Wählt Bilddateien abhängig von der Beschreibung pseudozufällig aus.
# 2013-05-10 Herbert Schiemann <h.schiemann@herbaer.de>
# GPL Version 2 oder neuer

# 2012-01-31 "image"-Element mit Wert 0 für verworfene Bilder ausgeben
# 2012-08-25 Herbaer::Readargs
# 2013-05-09 is:section/@role = 'private'
# 2013-05-10 --exclcat

package HB_SelectImages;
use utf8;
use Cwd;
use Fcntl;                    # O_RDONLY
use File::Spec::Functions qw(catfile catpath rel2abs abs2rel splitpath);
use POSIX qw(strftime);       # Zur Ausgabe der Zeit
use XML::SAX::ParserFactory ;

=pod

Ein SAX-Handler, der alle jpg-Elemente aus einer XML-Datei filtert
und die erforderlichen Bilddateien erzeugt.

Parameter:
$reprobs:
   Referenz auf eine Liste von Tupeln:
   Die erste Komponente ist ein regulärer Ausdruck,
   der Bilder anhand der Beschreibung vor-auswählt.
   Die zweite Komponente ist eine Wahrscheinlichkeit,
   mit der ein vor-ausgewähltes Bild tatsächlich ausgewählt wird.
   Die (optionale) dritte Komponente zählt die vorausgewählten Bilder,
   Die (optionale) vierte Komponente zählt die ausgewählten Bilder,
$args: 
   Hash-Referenz mit weiteren Argumenten
=cut
sub new {
   my ($class, $reprobs, $args) = @_;
   $class = ref($class) || $class;
   my $self = {};
   $self -> {"exclrestr"} = $args -> {"[cnt]exclrestr"}; # "eingeschränkte" Bilder ausnehmen
   $self -> {"exclcat"}   = $args -> {"[cnt]exclcat"};   # "eingeschränkte" Abschnitte
   $self -> {"catalog"}   = 0;
   $self -> {"reprobs"}   = $reprobs;
   $self -> {"verbose"}   = $args -> {"[cnt]verbose"};
   $self -> {"mode"}      = $args -> {"mode"} || "first"; # Auswahl-Modus: first, any, all
   $self -> {"selected"}  = {};  # Hash mit den ausgewählten Bildern als Schlüssel
   $self -> {"numfiles"}  = 0;   # Anzahl der "geparsten" Dateien
   $self -> {"parser"}    = XML::SAX::ParserFactory -> parser (Handler => $self);
   return bless ($self, $class);
} # new

=pod
Wählt Bilder aus

Paramter:
$fnin:
   Dateipfad der "Bildgeschichte"
Ergebnis:
   Hash der ausgewählten Bilder
=cut
sub select {
   my ($self, $fnin) = @_;
   -d $fnin and $fnin = catfile ($fnin, "story.xml");
   my $fhin;   # Dateihandle (Eingabe)
   my $verbose = $self -> {"verbose"};
   sysopen ($fhin, $fnin, O_RDONLY) or do {
      print "Kann Datei \"$fnin\" nicht lesen: $!\n" if $verbose;
      return undef;
   };
   $verbose && print "Datei $fnin\n";
   $self -> {"catalog"} = 0;
   $self -> {"lastalt"} = "";
   eval ( '$self -> {"parser"} -> parse_file ($fhin); 1;' ) or do {
      $self -> {"parser"} = XML::SAX::ParserFactory -> parser (Handler => $self);
      close ($fhin);
      print "Kann Datei \"$fnin\" nicht lesen: $!\n" if $verbose;
      return undef;
   };
   close ($fhin);
   ++ $self -> {"numfiles"};
   my $srcfiles = $self -> {"srcfiles"};
   if (!$srcfiles) {
      $srcfiles = [];
      $self -> {"srcfiles"} = $srcfiles;
   }
   push (@$srcfiles, $fnin);
   $self -> {"selected"};
} # select

=pod
Relativer Pfad bezüglich einer Datei oder eines Verzeichnisses

Parameter
$path: absoluter Pfad oder relativer Pfad bezüglich des aktuellen Verzeichnisses
$base: Bezugs-Datei oder Verzeichnis
=cut
sub relpath {
   my ($path, $base) = @_;
   my $basedir;   # Bezugs-Verzeichnis
   my $vol;       # "Volume" für Systeme, die es kennen
   return $path if (!$path);
   if ($base) {
      $basedir = rel2abs ($base);
      if (! -d $basedir) {
         ($vol, $basedir) = splitpath ($basedir);
         $basedir = catpath ($vol, $basedir, "");
      }
   }
   else {
      $basedir = cwd ();
   }
   abs2rel ($path, $basedir);
} # relpath

=pod
Schreibt die Ausgabe als XML

Parameter:
$fnout: Dateipfad der Ausgabedatei
$args:  HASHREF weiterer Argumente
=cut
sub  write_xml {
   my ($self, $fnout, $args) = @_;
   my $verbose = $self -> {"verbose"};
   my $fh;      # Dateihandle
   my ($k, $v); # Schlüssel/Wert-Paar
   my $xslt    = $args -> {"xslt"};

   open ($fh, ">:encoding(utf-8)", $fnout) or do {
      print "Kann Datei \"$fnout\" nicht schreiben: $!\n" if $verbose;
      return;
   };
   print "Erstelle Datei \"$fnout\"\n" if $verbose;
   print $fh "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n";
   print $fh "<?xml-stylesheet href=\"$xslt\" type=\"application/xml\"?>\n"
       if $xslt && $xslt ne "none"
   ;
   print $fh "<imgselect xmlns = \"http://herbaer.de/xmlns/20100205/imgselect\">\n";
   print $fh "<meta>\n";
   if ($k = $self -> {"srcfiles"}) {
      for $v (@$k) {
         $v = relpath ($v, $fnout);
         print $fh "<srcfile>$v</srcfile>\n";
      }
   }
   print $fh "<filename>$fnout</filename>\n";
   print $fh "<time>", strftime ("%Y-%m-%dT%H:%M:%S", localtime()), "</time>\n";
   print $fh "</meta>\n";
   my $val = $self -> {"selected"};
   if (ref ($val) eq "HASH") {
      print $fh "<images>\n";
      while ( ($k, $v) = each (%$val) ) {
         print $fh "<image src=\"$k\">$v</image>\n";
      }
      print $fh "</images>\n";
   }
   $val = $self -> {"reprobs"};
   if (ref ($val) eq "ARRAY") {
      print $fh "<selections>\n";
      for $k (@$val) {
         print $fh "<selection>\n";
         print $fh "<regex><![CDATA[" . ($k -> [0]) . "]]></regex>\n";
         print $fh "<probability>" . ($k -> [1]) . "</probability>\n";
         print $fh "<matches>" . ($k -> [2]) . "</matches>\n" if defined ($k -> [2]);
         print $fh "<selected>" . ($k -> [3]) . "</selected>\n" if defined ($k -> [3]);
         print $fh "</selection>\n";
      }
      print $fh "</selections>\n";
   }
   for $k ("numfiles", "mode") {
      $v = $self -> {$k};
      print $fh "<$k>$v</$k>\n" if defined ($v);
   }
   print $fh "</imgselect>\n";
} # write_xml

# SAX-Handler-Methoden
sub start_element {
   my ($self, $el) = @_;
   my $attr = $el -> {'Attributes'};
   my $ln   = $el -> {'LocalName'};
   if ($self -> {"exclcat"} && $ln eq "section") {
      my $role = $attr -> {'{}role'} -> {'Value'} || "";
      ++ $self -> {"catalog"} if 
        $self -> {"catalog"} || $role eq "cat" || $role eq "private";
   }
   return if $self -> {"catalog"};   # Katalogbilder werden ausgenommen
   return if $ln ne 'jpg';
   return if $self -> {"exclrestr"} && $attr -> {'{}restr'};

   $attr -> {'{}src'} -> {'Value'} =~ /^([a-z0-9_]*)$/;
   my $img = $1;                       # Kennung des Bildes
   $attr -> {'{}alt'} -> {'Value'} =~ /^(.*)$/;
   my $alt = $1;                       # Beschreibung des Bildes
   my $tp;                             # ein "Test"-Tupel
   my $re;                             # regulärer Ausdruck
   my $mode = $self -> {"mode"};       # Auswahl-Modus
   my $sel = 0;                        # Bild ausgewählt?
   
   for $tp (@{$self -> {"reprobs"}}) {
      $re = $tp -> [0];
      if ($re eq '[multiple]') {
         next if $alt ne $self -> {"lastalt"};
      }
      elsif ($alt !~ $re) {
         next;
      }
      ++ $tp -> [2];
      if (rand() <= $tp -> [1]) {
         $sel = 1;
         ++ $tp -> [3];
         last if $mode eq "any";
      }
      else {
         $sel = 0;
         last if $mode eq "all";
      }
      last if $mode eq "first";
   }
   $self -> {"selected"} -> {$img} += $sel;
   $self -> {"lastalt"} = $alt;
} # start_element

sub end_element {
   my ($self, $el) = @_;
   if ($self -> {"catalog"} && $el -> {'LocalName'} eq "section") {
      --$self -> {"catalog"};
   }
} # end_element

1;

package main;

use Herbaer::Readargs;     # read_args ()
use File::Spec::Functions; # catfile

binmode (STDIN,  ":encoding(utf-8)");
binmode (STDOUT, ":encoding(utf-8)");
binmode (STDERR, ":encoding(utf-8)");

sub version {
   print <<'VERSION' ;
KLEIDER/web/src/addstory/imgselect.pl
2013-05-10 Herbert Schiemann <h.schiemann@herbaer.de>
VERSION
}

# Hash der Kommandozeilen-Argumente
my $args = {
   "[cnt]verbose"   => 1,
   "in"             => "story.xml",   # Eingabedatei
   "out"            => undef,         # Ausgabedatei
   "[cnt]exclrestr" => 1,             # "eingeschränkte" Bilder ausnehmen
   "[cnt]exclcat"   => 1,             # "eingeschränkte" Abschnitte ausnehmen
   "multiple"       => 0.08,          # prob. wiederholte Auswahl des gleichen Titels
   "slippy"         => 0.1,           # Wahrscheinlichkeit zur Auswahl "Beine im Slip"
   "left"           => 0.6,           # Wahrscheinlichkeit zur Auswahl "von links"
   "right"          => 0.6,           # Wahrscheinlichkeit zur Auswahl "von rechts"
   "behind"         => 0.7,           # Wahrscheinlichkeit zur Auswahl "von hinten"
   "legs"           => 0.9,           # Wahrscheinlichkeit zur Auswahl "Beine"
   "total"          => "-",           # Wahrscheinlichkeit zur Auswahl "total"
   "catchall"       => 1.0,           # generelle Auswahl-Wahrscheinlichkeit
   "text"           => [],            # weitere Auswahlkriterien
   "prob"           => [],            # Wahrscheinlichkeiten zu den weiteren Kriterien
   "mode"           => "first",       # Auswahlmodus
   "xslt"           => "imgselect_ht.xslt"  # XSLT der Ausgabe
};

$args -> {"[sr]version"} = sub { version (); exit 0; };

$args -> {"[sr]help"} = sub {
   version ();
   print_message_with_values (<<"HELP", $args);
$0 --help     zeigt diese Hilfe an
$0 --version  zeigt die Programm-Version an

$0 [option]...

--[no_]verbose     Umfang der Ausgabe \${[cnt]verbose}
--in INFILE        Pfad der Eingabedatei
                   Wenn INFILE ein Verzeichnis ist, wird INFILE/story.xml genommen
                   \${in}
--out OUTFILE      Pfad der Ausgabedatei, Default:
                   INFILE, wobei .xml am Ende durch .selection.xml ersetzt wird
--[no_]exclrestr   Bilder mit Einschränkung (restr-Attribut) ausnehmen \${[cnt]exclrestr}
--[no_]exclcat     Katalog-Abschnitte und "private" Abschnitte ausnehmen \${[cnt]exclcat}
--multiple PROB    Wahrscheinlichkeit wiederholter Auswahl desselben Titels \${multiple}
--slippy   PROB    Wahrscheinlichkeit zum Muster "Beine im Slip" \${slippy}
--left     PROB    Wahrscheinlichkeit zum Muster "von links" \${left}
--right    PROB    Wahrscheinlichkeit zum Muster "von rechts" \${right}
--behind   PROB    Wahrscheinlichkeit zum Muster "von hinten" \${behind}
--legs     PROB    Wahrscheinlichkeit zum Muster "Beine" \${legs}
--total    PROB    Wahrscheinlichkeit zum Muster "total" \${total}
--catchall PROB    Wahrscheinlichkeit zum universellen Muster ".*" \${catchall}
--text     TEXT..  weitere Auswahlkriterien
                   \${text}
--prob     PROB..  Wahrscheinlichkeiten zu weiteren Kriterien
                   \${prob}
--mode [all|any|first] Auswahlmodus \${mode}
--xslt     XSLT  XSLT-Stylesheet der Ausgabe oder none \${xslt}
HELP
   exit 0;
}; # version

# Baut den Auswahl-Hash
sub build_reprobs {
   my $args = shift;
   my $reprobs = [];
   my $rp;
   my $pair; # Schlüssel/Regex - Paar
   my $i;    # Array-Index: zusätzliche Auswahl
   my $txt;  # Text einer zusätzlichen Auswahl
   my $re;   # Regulärer Ausdruck zu $txt
   my $prob; # Wahrscheinlichkeit

   for $pair (@{[
      ["multiple", '[multiple]'      ],
      [
       "slippy",
       '\bBeine\s+(?!.*?(?:[Kk]leid|[Rr]ock)\b).*?(?:Badeanzug|Body|Slip|Tanga)\b'
      ],
      ["left",     '\bvon\s+links\b' ],
      ["right",    '\bvon\s+rechts\b'],
      ["behind",   '\bvon\s+hinten\b'],
      ["legs",     '\bBeine\b'       ],
      ["total",    '\btotal\b'       ],
   ]}) {
      $prob = $args -> {$pair -> [0]};
      if ($prob ne "-") {
         $re = $pair -> [1];
         $rp = [];
         $rp -> [0] = ( $re =~ /^\[\w+\]$/ ? $re : qr/$re/ ) ;
         $rp -> [1] = $prob + 0.0 ;
         push (@$reprobs, $rp);
      }
   }
   $prob = $args -> {"prob"};
   $i = 0;
   for $txt (@{$args -> {"text"}}) {
      if (defined $prob -> [$i] && $prob -> [$i] ne "-") {
         $re = quotemeta($txt);
         $rp = [];
         $rp -> [0] = qr/$re/o ;
         $rp -> [1] = $prob -> [$i] + 0.0;
         push (@$reprobs, $rp);
      }
      ++$i;
   }
   if ($args -> {"catchall"} ne "-") {
      $rp = [];
      $rp -> [0] = qr/./o ;
      $rp -> [1] = $args -> {"catchall"} + 0.0 ;
      push (@$reprobs, $rp);
   }
   $reprobs;
} # build_reprobs

read_args ($args);

if ( $args -> {"mode"} !~ /^(?:first|any|all)$/ ) {
   print "ungültiger Auswahlmodus --mode " . $args -> {"mode"}
      if $args -> {"[cnt]verbose"}
   ;
   exit (1);
}

if (!defined ($args -> {"out"})) {
   my $t;
   $t = $args -> {"in"};
   -d $t and $t = catfile ($t, "story.xml");
   $t =~ s/\.xml$//;
   $t =~ s/\.+$//;
   $args -> {"out"} = $t . ".selection.xml" ;
}

my $selimg = new HB_SelectImages (build_reprobs ($args), $args);
$selimg -> select ($args -> {"in"});
$selimg -> write_xml ($args -> {"out"}, $args);
# end of file KLEIDER/web/src/addstory/imgselect.pl