#!/usr/bin/perl -w

#  Paket zum Parsen und Verwalten eines XML-Dokumentes
use XML::DOM;

my $parser = new XML::DOM::Parser;

my $Path = "/home/hannes/texte/vereine/elug/xml";

print LOG "Parsing play ...";
my $doc = $parser->parsefile ("$Path/cymbelin.xml");
print LOG " parsed.\n";

#  Öffne Datei zu diagnostischen Nachrichten
open LOG, ">$Path/charsheet.log" or die "operation failed: $!\n";

#  Einziges Kommandozeilenargument: Name der Person
my $Character = shift @ARGV;
$Character = lc($Character);

print LOG "Doc has name ", $doc->getNodeName, ".\n";

my @doc_children = $doc->getChildNodes;

#  Wähle Ecke mit Namen "PLAY": Von ihr stammt alles ab
foreach $play(@doc_children) {
    print LOG "Node has name ", $play->getNodeName, ".\n";
    my @play_children = $play->getChildNodes;
    foreach $play_child(@play_children) {
	print LOG "Node has name ", $play_child->getNodeName, ".\n";
	#  Es müssen zunächst nur aus Akten Ecken entfernt werden,
	#  also wähle nur Akte aus. Weitere Kandidaten folgen unten
	if ($play_child->getNodeName eq "ACT") {
	    print LOG "Entering act ...\n";
	    my @act_children = $play_child->getChildNodes;
	    foreach $act_child(@act_children) {
		#  In den Akten können im Prolog, im Epilog
		#  und in Szenen Personen auftreten
		if ($act_child->getNodeName eq "PROLOGUE"
		    or $act_child->getNodeName eq "EPILOGUE"
		    or $act_child->getNodeName eq "SCENE") {
		    print LOG "Entering  scene, prologue, or epilogue ...\n";
		    print LOG ref($act_child), "\n";
		    traverse_scene($act_child);
		}
	    }
	    #  Außerhalb der Akte gibt es bei Shakespeare ggf. einen
	    #  Prolog, Epilog oder eine Einführung
	    if ((lc($play_child->getNodeName) eq "prologue") 
		or (lc($play_child->getNodeName) eq "epilogue") 
		or (lc($play_child->getNodeName) eq "induct")) {
		print LOG "Entering  induct, prologue, or epilogue ...\n";
		print LOG ref($play_child), "\n";
		traverse_scene($play_child);
	    }
	}
    }
}

#  Ziehe benachbarte Ecken mit Textinhalt zu einer zusammen:
$doc->normalize;

#  Ab auf die Standardausgabe
print $doc->toString;

close LOG;

sub traverse_scene {
    my $scene = shift;
    my @scene_children = $scene->getChildNodes;
    #  Wird auf 1 gesetzt, wenn
    #  irgendein Kindelement behalten wird
    my $anykeep = 0;
    foreach $scene_child(@scene_children) {
	#  $keep wird nachher abgefragt, ob Löschen
	#  in Frage kommt.
	#  $keep == 0:  kann gelöscht werden
	#  $keep == 1:  falls <SPEECH>: kann bis auf
	#               die letzten zwei Zeilen
	#               gelöscht werden
	#  $keep == 2:  kann nicht gelöscht werden
	my $keep = 0;
	#  immer den Titel einer Szene behalten
	if (lc($scene_child->getNodeName) eq "title") {
	    $keep = 2;
	}
	elsif (lc($scene_child->getNodeName) eq "stagedir") {
	    #  enthält aktuelle Regieanweisung den Namen?
	    $keep = 2*scan_stagedir($scene_child);
	}
	elsif (lc($scene_child->getNodeName) eq "speech") {
	    #  enthält aktueller Sprechpart den Namen?
	    $keep = 2*scan_speech($scene_child);
	}
	#  Interessant sind alle <SPEECH>es, deren
	#  <SPEAKER> der Figurenname ist, alle
	#  vorangehenden Elemente, alle <STAGEDIRS>,
	#  in denen der Figurenname vorkommt. Alle
	#  anderen <SPEECH>es und <STAGEDIRS> können
	#  gelöscht werden. 
	my $sibling = $scene_child->getNextSibling;
	#  Leere und unwichtige z.B. Text-Elemente überspringen
	while ($sibling && 
	       (lc($sibling->getNodeName) ne "stagedir" &&
		lc($sibling->getNodeName) ne "speech")) {
	    $sibling = $sibling->getNextSibling;
	}
	if ($sibling) {
	    print LOG "Next sibling has name ", $sibling->getNodeName, " and class ", ref($sibling), "\n";
	    if (lc($sibling->getNodeName) eq "stagedir") {
		#  enthält folgende Regieanweisung den Namen?
		$keep = max($keep, scan_stagedir($sibling));
	    }
	    if (lc($sibling->getNodeName) eq "speech") {
		#  enthält folgender Sprechpart den Namen?
		$keep = max($keep, scan_speech($sibling));
	    }
	}
	#  Jetzt wird $keep ausgewertet
	print LOG "keep has status ", $keep, "\n";
	if ($keep==0)
	{
	    $scene->removeChild($scene_child);
	    print LOG "Cleared child node of scene.\n";
	}
	elsif ($keep==2)
	{
	    $anykeep=1;
	}
	elsif ($keep==1)
	{
	    $anykeep=1;
	    print LOG "This sibling has name ", $scene_child->getNodeName, " and class ", ref($scene_child), "\n";
	    if (lc($scene_child->getNodeName) eq "speech") {
		my @speech_children = $scene_child->getChildNodes;
		#   alle bis auf die letzten zwei Zeilen
		my $dummy = pop @speech_children;
		$dummy = pop @speech_children;
		foreach $speech_child(@speech_children) {
		    print LOG "  ", ref($speech_child), " ", $speech_child->getNodeName, "\n";
		    unless (lc($speech_child->getNodeName) eq "speaker") {
			$scene_child->removeChild($speech_child);
		    }
		}
		print LOG "Cleared all but the last two entries of speech.\n";
	    }
	}
    }
    return $anykeep;
}

sub scan_speech {
    print LOG "Scanning speech for speaker ...\n";
    my $speech = shift;
    print LOG "This node has name ", $speech->getNodeName, " and class ", ref($speech), "\n";
    my $keep = 0;
    my @speech_children = $speech->getChildNodes;
    foreach $speech_child(@speech_children) {
	print LOG "  This node has name ", $speech_child->getNodeName, " and class ", ref($speech_child), "\n";
	if (lc($speech_child->getNodeName) eq "speaker") {
	    my $name =   $speech_child->getFirstChild->toString;
	    print LOG $name, " speaks\n";
	    if (lc($name) eq $Character) {
		$keep = 1;
	    }
	}
    }
    return $keep;
}

sub scan_stagedir {
    print LOG "Scanning stagedir for character name string ...\n";
    my $stagedir = shift;
    print LOG ref($stagedir), " ", $stagedir->getNodeName, "\n";
    my $keep = 0;
    my $stagedir_string = $stagedir->toString;
    if (lc($stagedir_string) =~ /$Character/) {
	print LOG $stagedir_string, "\n";
	$keep=1;
    }
    return $keep;
}

sub max {
    my $max = shift;
    foreach $element(@_) {
	$max = $max > $element ? $max : $element;
    }
    return $max;
}