#!/usr/bin/perl

# VCD Meta Version 0.20

# Copyright (C) 2002 by Kevin Atkinson under the GNU General Public
# License (GPL) version 2.0. You should have received a copy of the GPL
# along with this program if you did not you can find it at the GNU web
# site http://www.gnu.org/.

use FindBin qw($RealBin);

my $DTD="$RealBin/videocd-meta.dtd";
my $XML_CHECK="xmllint --dtdvalid file://$DTD --noout --nowarning";

# Uncomment this to use the provided fonts
my $FONT_DIR="$RealBin";
my $NORMAL_FONT = "Helvetica-bold-r-normal.pfb";
my $CONDNS_FONT = "Helvetica-bold-r-condensed.pfb";

# Uncomment this and set FONT_DIR appropriately to use Nicer TT fonts
#my $FONT_DIR="/mnt/windows/windows/fonts/";
#my $NORMAL_FONT = "arialbd.ttf";
#my $CONDNS_FONT = "arialnb.ttf";

use POSIX 'ceil';

use XML::Twig;
use IO::Handle;

# Comment this line out if you don't have the Image Magick perl module
# installed and wish to create the VCD menus yourself.  
use Image::Magick;

#
# You should not need to change anything beyond this point
#

my $VERSION = '0.20';

use strict;
use warnings;

sub readGroup ( $ $ );
sub readPage ( $ \$ $ );
sub readVideo ( $ $ );

sub readFilesystem ();

sub prepGroup ( $ \$ $ );
sub prepPage ( $ $ $ $ );
sub prepMenu ( $ );
sub prepVideo ( $ \$ $ $ );
sub hashNode ( $ );

sub unescape ( $ );

sub defaultParms ();

sub jobs ();

sub fixNum ( $ ) {$_[0] eq '0' ? '+0' : $_[0]}

sub newElt ( @ ) {XML::Twig::Elt->new(@_)}
sub newEmptyElt ( @ ) {XML::Twig::Elt->new(@_, '#EMPTY')}
sub insert ( $ @ ) {my $r = shift; foreach (@_) {$_->paste('last_child', $r)}}
sub insertElt ( $ @ ) {my $r = shift; newElt(@_)->paste('last_child', $r)}
sub insertEmptyElt ( $ @ ) {my $r = shift; 
			    newElt(@_, '#EMPTY')->paste('last_child', $r)}
sub attsUnescaped ( $ );
sub attsUnescapedTitle ( $ );

sub hasValue ( $ ) {defined $_[0] && $_[0] ne ''}

sub reduce ( & @ ) 
{
  my $f = shift;
  $a = shift @_;
  foreach (@_) {$b = $_; $a = &$f};
  return $a;
}
sub sum ( @ ) {reduce {$a + $b} 0, @_}
sub max ( @ ) {reduce {$a < $b ? $b : $a} @_}
sub oneof ( $ @ ) {my $toFind = shift; scalar grep {$toFind eq $_} @_}

sub depth ( $ );
sub itemNum ( $ );

sub createMenu ( $ $ $ $ );

sub addFile ( % );

sub ensureDirs ( $ );


###################################################################
#
# Main Program
#

#
# Initial preparations
#

if (defined $ARGV[0] && $ARGV[0] =~ /^-+/) {
  print
      "VCD Meta version $VERSION\n",
      "Usage: vcdmeta [xmlfile]\n";
  exit 1;
}

my $file = $ARGV[0];
$file = 'videocd-meta.xml' unless defined $file;

print "Processing \"$file\".\n";

my $xmlErrors = qx"$XML_CHECK $file 2>&1";

if (not defined $xmlErrors) {
  print STDERR 
      "WARNING: Unable to verify \"$file\" is valid.  If vcdmeta dies\n",
      "         unexpectedly make sure your file is valid before submitting\n",
      "         a bug report.\n";
} elsif ($xmlErrors !~ /^\s*$/s) {
  print STDERR "ERROR: File \"$file\" is invalid:\n\n";
  print STDERR $xmlErrors;
  exit 1;
}

#
# Read in XML and convert to internal structure
#

my $twig = XML::Twig->new();
XML::Twig->set_pretty_print('indented');
$twig->parsefile($file);
my $root = $twig->root;

my %filesystem;
my @selections;
my %selections;
my @videos;
my @stills;
my @work;
my %videocd;
my %menuParms = defaultParms;

my $nice_mpeg_file_names = (defined $root->att('nice-mpeg-file-names') 
			    && $root->att('nice-mpeg-file-names') eq 'true');
my $create_mpeg_link_files = (defined $root->att('create-mpeg-link-files') 
			      && $root->att('create-mpeg-link-files') eq 'true');

foreach my $n ($root->children('page')) 
{
  $n->set_att('wait', '-1') unless defined $n->att('wait');
  $n->set_att('loop', '0')  unless defined $n->att('loop');
}

%videocd = %{hashNode $root};

$videocd{'volume-id'} = $videocd{'album-id'} unless defined $videocd{'volume-id'};


readFilesystem;

my $group = readGroup($root, {'auto-split' => 'true',
			      'menu-wait' => 'auto',
			      'menu-loop' => '1',
			      'menu-video-wait' => '0'});

$root = undef;

#
# Menu/Group Preperation
#

{my $c = 1; prepGroup(undef, $c, $group)}

{
  my $prev = 'xp1';
  foreach my $s (@selections) 
  {
    $selections{$s->{id}} = $s;
    next if $s->{type} eq 'group';
    $s->{prev} = $prev;
    $selections{$prev}{next} = $s->{id};
    $s->{parent} = $prev if $s->{type} eq 'menu' && $s->{num} > 1;
    $prev = $s->{id};
  }
  $selections[-1]->{next} = 'xp1';
}{
  my $nextVideo = 'xp1';
  foreach my $s (reverse @selections)
  {
    next if $s->{type} eq 'group';
    $s->{nextVideo} = $nextVideo;
    $nextVideo = $s->{id} if $s->{src} ne $selections{$s->{prev}}{src};
  }
}

#
# Auxiliary File Creation
#

&contents;
#&index;

if ($nice_mpeg_file_names) {
  &autorun;
  &mpegIndex('mpeg');
}

if ($create_mpeg_link_files) {
  &makeLinks;
  &mpegIndex('mpeglink');
}

#
# Write final VideoCD XML
#

my $xml = newElt('videocd', 
		 {xmlns => "http://www.gnu.org/software/vcdimager/1.0/",
		  class => "vcd", version=> "2.0"});

insert $xml, (&options,
	      &info,
 	      &pvd,
	      &filesystem,
	      &segmentItems,
	      &sequenceItems,
	      &pbc);

my $XML = new IO::Handle;
open $XML, ">videocd.xml" 
    or die "Unable to open \"videocd.xml\" for writing\n";

print "Writing \"videocd.xml\".\n";

print $XML '<?xml version="1.0"?>',"\n";
print $XML '<!DOCTYPE videocd PUBLIC "-//GNU//DTD VideoCD//EN" "http://www.gnu.org/software/vcdimager/videocd.dtd">', "\n";
$xml->print($XML);
print $XML "\n";
close $XML;

#
# 
#

while (@work) {
  my $job = shift @work;
  jobs->{$job->{action}}($job);
}

###################################################################
#
# read* - these functions convert the Twig XML object into
#  a partly process internal format
#

sub readFolder ( $ ; $ );
sub readFile ( $ $ );

sub readFilesystem ()
{
  my $el = $root->first_child('filesystem');
  %filesystem = %{readFolder($el)} if defined $el;
}

sub readFolder ( $ ; $ )
{
  my ($node, $parent) = @_;
  my $folder = makeFolder $node->att('name');
  push @{$parent->{folders}}, $folder if defined $parent;
  for (my $el = $node->first_child; defined $el; $el = $el->next_sibling)
  {
    if ($el->gi eq 'folder') { readFolder($el, $folder) } 
    else                     { readFile($el, $folder) }
  }
  return $folder;
}

sub readFile ( $ $ )
{
  my ($node, $parent) = @_;
  my $file = addFile(%{attsUnescaped $node}, folder => $parent);
  return $file;
}

#
#
#

sub readGroup ( $ $ );
sub readPage ( $ \$ $ );
sub readVideo ( $ $ );

sub combinePages ();

sub readGroup ( $ $ )
{
  my ($node, $options) = @_;
  my $group = attsUnescapedTitle $node;
  $group->{tag} = 'group';
  $group->{type} = 'group';
  $group->{options} = {%$options,
		       %{attsUnescaped $node->first_child('options')}};
  if ($group->{title} =~ /^(.+)(\s*)(,,|;;|::)(\s*)(.+)$/) 
  {
    $group->{'menu-title'} = $1.$2.(substr $3, 0, 1).$4.$5;
    $group->{title} = $1;
    $group->{'menu-extra'} = '' unless defined $group->{'menu-extra'};
    $group->{extra} = $5 unless defined $group->{extra};
  }
  my $cg = 1;
  $group->{pages} = [map {readPage $group, $cg, $_} $node->children('page')];
  $group->{content} = reduce {combinePages} ([], @{$group->{pages}}); 
  return $group;
}

sub combinePages ()
{
  $b = $b->{content};
  if (defined $$a[-1] && defined $$a[-1]{src} && defined $$b[0]{src} 
      && $$a[-1]{src} eq $$b[0]{src}) 
  {
    return [@$a[0..$#$a-1], 
	    {%{$$a[-1]}, content=>[@{$$a[-1]{content}},@{$$b[0]{content}}]},
	    @$b[1..$#$b]];
  } else {
    return [@$a, @$b];
  }
}

sub readPage ( $ \$ $ )
{
  my ($group, $cg, $node) = @_;
  my $page = {%$group, %{attsUnescapedTitle $node}};
  $page->{tag} = 'page';
  $page->{type} = 'menu';
  my @content;
  foreach my $n ($node->children)
  {
    $n->set_att('fname', sprintf 'part%02d', $$cg)
	unless defined $n->att('fname');
    if ($n->gi eq 'group') {
      push @content, readGroup($n, $group->{options});
    } else { # name eq 'video'
      push @content, readVideo($group, $n);
    }
    $$cg++;
  }
  $page->{content} = \@content;
  return $page;
}

sub readVideo ( $ $ )
{
  my ($group, $node) = @_;
  my $video = attsUnescaped $node;
  $video->{tag} = 'video';

  $video->{fname} = $group->{fname} . '/' . $video->{fname}
      if defined $group->{fname};
  $video->{fname} =~ s/.mpg$//i;
  
  my @parts = map {{%$video, %{attsUnescapedTitle $_}}} $node->children;
  unshift @parts, {%$video, time => 0} if !@parts || $parts[0]{time} != 0;
  foreach my $d (@parts)
  {
    $d->{tag}  = 'entry';
    $d->{type} = 'video';
    $d->{idType} = 'video';
    $d->{wait} = '+0';
    $d->{loop} = '1';
    $d->{time} = $1*60 + $2 if $d->{time} =~ /(\d+):([\d.]+)/;
  }
  $video->{parts} = \@parts;

  return $video;
}

###################################################################
#
# Menu and Video Preperation functions
#

sub totalHeight ( @ );
sub availHeight ( $ ; $ );
sub splitPage ( $ $ @ );
sub numItems ( @ );

sub prepGroup ( $ \$ $ )
{
  my ($pid, $num, $group) = @_;
  my $id = defined $pid ? "$pid-$$num" : 'x';
  $group->{id} = $id;
  #$group->{num} = @selections + 0;
  my @pages = @{$group->{pages}};
  push @selections, $group;
  # the two pass approch is needed because all pages for a group need
  # to come beofre the selections
  if (@pages == 1 && ((defined($pages[0]{'auto-split'})
		       && $pages[0]{'auto-split'} eq 'true')
		      || (!defined($pages[0]{'auto-split'})
			  && $group->{options}{'auto-split'} eq 'true')))
  {
    my $origPage = $pages[0];
    my @items = @{$origPage->{content}};
    my $numItems = numItems @items;
    my $totalHeight = totalHeight @items;
    my $numPages = 
	$totalHeight < availHeight($origPage, 'single') && $numItems < 8 
	? 1
	: ceil(max(($totalHeight - $menuParms{height})
		   / availHeight($origPage),
		   ($numItems - 1) / 8));
    my $idealPageHeight = $totalHeight / $numPages;

    @pages = map {{%$origPage, content => $_}} splitPage $origPage, $idealPageHeight, @items;
  }
  push @selections, @pages;
  $group->{numPages} = @pages + 0;
  my $c = 1;
  foreach my $p (@pages)
  {
    prepPage $pid, $c, $group, $p;
    $c++;
  }
  $group->{pages} = \@pages;
  $$num++;
  return ($group->{pages}[0]{id});
}


sub prepPage ( $ $ $ $ )
{
  my ($pid, $num, $group, $page) = @_;
  my $numPages = $group->{numPages};
  $page->{id} = "$$group{id}p$num";
  $page->{page} = $page;
  $page->{num} = $num;
  $page->{parent} = $pid;
  $page->{group} = $group;
  $page->{pageInfo} = "Page $num/$numPages" if  $numPages > 1;
  
  if ($numPages > 1 && $num < $numPages) {
    print STDERR "Warning: More than 8 items" if numItems($page) > 8;
    $page->{useNext} = 1;
  } else {
    print STDERR "Warning: More than 9 items" if numItems($page) > 9;
  }
  
  prepMenu $page;

  my @items;
  $page->{menuItems} = \@items;
  my $c = 1;
  foreach my $d (@{$page->{content}})
  {
    if ($d->{tag} eq 'group') {
      push @items, prepGroup($page->{id}, $c, $d);
    } else { # name eq 'video'
      push @items, prepVideo($page->{id}, $c, $d, $page);
    }
  }
}

sub prepMenu ( $ )
{
  my ($page) = @_;
  my $options = $page->{options};
  my $src = $page->{src};
  $src = '' unless defined $src;
  if ($src eq '') {
    $src = "$page->{id}.m1p";
    push @work, {action => 'generate', 
		 id => $page->{id}};
  } elsif ($src !~ /\.(m\dp|mpg|mpeg)$/i) {
    my $base = $src;
    $base =~ s/\..+$// or die;
    $src = $base.".m1p";
    push @work, {action => 'convert',
		 src => $page->{src},
		 base => $base};
  }
  if ($src =~ /\.m\dp$/i) { # still 
    $page->{idType} = 'still';
    $page->{wait} = fixNum(exists $page->{wait} 
			    ? $page->{wait}
			    : $options->{'menu-wait'});
    $page->{loop} = '1';
    push @stills, {src => $src, id => $page->{id}};
  } else { # video
    $page->{idType} = 'video';
    $page->{loop} = fixNum(exists $page->{loop} 
			    ? $page->{loop}
			    : $options->{'menu-loop'});
    $page->{wait} = fixNum(exists $page->{wait} 
			    ? $page->{wait}
			    : $options->{'menu-video-wait'});
    push @videos, {src => $src, parts => [{id => $page->{id}, time => 0}]};
  }
  $page->{src} = $src;
}

sub prepVideo ( $ \$ $ $ )
{
  my ($pid, $num, $video, $page) = @_;
  my $group = $page->{group};
  foreach my $d (@{$video->{parts}})
  {
    $d->{id} = "$pid-$$num";
    $d->{parent} = $pid;
    #$d->{num} = @selections + 0;
    $d->{page} = $page;
    push @selections, $d;
    $$num++;
  }
  push @videos, $video;
  return map {$_->{id}} @{$video->{parts}};
}

#
# Split Page and related utility functions
#

sub selHeight ( $ );
sub firstPartHeight ( $ );
sub calcPageVariance ( @ );
sub splitItem ( $ );

sub splitPage ( $ $ @ )
{
  my $origPage = shift;
  my $idealPageHeight = shift;
  return () unless @_;
  my $pageHeight = 0;
  my @thisPageItems;
  while (@_ && $pageHeight + selHeight $_[0] <= $idealPageHeight)
  {
    $pageHeight += selHeight $_[0];
    push @thisPageItems, (shift @_);
  }
  my $lastItem = shift @_;
  return ([@thisPageItems]) unless defined $lastItem;
  my $maxHeight = @_ ? availHeight($origPage) : availHeight($origPage, 'last');
  my $maxItems  = @_ ? 8 : 9;
  my @tryList = ([[$lastItem], []],
		 [[], [$lastItem]],
		 splitItem $lastItem);
  # figure out the best split in the try list;
  my $var = 9999;
  my @pages;
  foreach (@tryList) {
    next if # remove ones with this page empty to avoid infinite recursion
	$pageHeight == 0 && !@{$_->[0]}; 
    my $h = $pageHeight + selHeight $_->[0][0];
    my $n = numItems(@thisPageItems, $_->[0][0]);
    next if # remove splits that can't possible fit
	$h > $maxHeight || $n > $maxItems;
    next unless # trim splits that are not near the border line
	$h + firstPartHeight($_->[1][0]) > $idealPageHeight
	|| $n == $maxItems; # needed or else no splits may be excepted
    #print ">>>>\n";
    my @p0 = ([@thisPageItems, @{$_->[0]}],
	      splitPage($origPage, $idealPageHeight, @{$_->[1]}, @_));
    #print "<<<<\n";
    my $v0 = calcPageVariance @p0;
    if ($v0 + 30 < $var) {
      $var = $v0;
      @pages = @p0;
    }
    #print ">($v0)\n";
  }
  #print "($var)\n";
  die unless $var < 9999;
  
  return @pages;
}

sub splitItem ( $ ) {
  my ($item) = @_;
  my $last = $#{$item->{parts}};
  return 
      map {[[{%$item, parts=>[@{$item->{parts}}[0 .. $_-1]]}],
	    [{%$item, parts=>[@{$item->{parts}}[$_ .. $last]]}]]} reverse(1 .. $last-1);
}

sub selHeight ( $ )
{
  my ($sel) = (@_);
  return 0 unless defined $sel;
  my $lst = $sel->{tag} eq 'group' ? [$sel] : $sel->{parts};
  return sum map {defined $_->{extra} 
		  ? $menuParms{heightWithExtra} 
		  : $menuParms{height}} @$lst;
}

sub firstPartHeight ( $ )
{
  my ($sel) = (@_);
  return 0 unless defined $sel;
  local $_ = $sel->{tag} eq 'group' ? $sel : $sel->{parts}[0];
  return (defined $_->{extra} 
	  ? $menuParms{heightWithExtra} 
	  : $menuParms{height});
}

sub numItems ( @ )
{
  my $sel = $_[0];
  if (!defined $sel) {
    return 0;
  } elsif (@_ > 1) {
    return sum map {numItems $_} @_
  } elsif (ref $sel eq 'ARRAY') {
    return sum map {numItems $_} @$sel;
  } elsif ($sel->{tag} eq 'group') {
    return 1;
  } elsif ($sel->{tag} eq 'video') {
    return scalar @{$sel->{parts}};
  } elsif ($sel->{tag} eq 'page') {
    return sum map {numItems $_} $sel->{pages}
  } else {
    die;
  }
}

sub totalHeight ( @ )
{
  return sum (map {selHeight $_} @_);
}

sub availHeight ( $ ; $ )
{
  my ($page, $what) = @_;
  $what = 'normal' unless defined $what;
  die "badparm" unless oneof $what, ('normal', 'last', 'single');
  my $h = $menuParms{end} - $menuParms{start};
  $h -= $menuParms{title}{height}    if defined $page->{title};
  $h -= $menuParms{extra}{height}    if defined $page->{height};
  $h -= $menuParms{pageInfo}{height} unless $what eq 'single';
  $h -= $menuParms{height}           if $what eq 'normal';
  return $h;
}

sub calcPageVariance ( @ )
{
  return 0 if @_ < 2;
  my @pgs = ((map {totalHeight(@$_) + $menuParms{height}} @_[0 .. $#_-1]),
	     (totalHeight @{$_[$#_]}));
  my $total  = sum @pgs;
  my $total2 = sum (map {$_**2} @pgs);
  return sqrt( ($total2 - $total**2/@pgs) / (@pgs - 1) );
}

###################################################################
#
# Mpeg Link creation functions
#

sub entryFName ( $ $ $ );

sub makeLinks ()
{
  print "Creating Mpeg Links\n";
  my $c = 1;
  foreach my $v (@videos) 
  {
    my @parts = @{$v->{parts}};
    my $pc = 1;
    foreach my $p (@parts)
    {
      $p->{fname} = entryFName($p->{fname}, $pc, scalar @parts)
	  if (@parts > 1 && $p->{fname} eq $v->{fname});
      my $lname = "mpeglink/$p->{fname}";
      $lname =~ s/(.mpg)?$/.mpl/i;
      my $OUT = new IO::Handle;
      ensureDirs($lname);
      open $OUT, ">$lname";
      binmode $OUT;
      print $OUT "$c\r\n";
      print $OUT "$p->{time}\r\n";
      close $OUT;
      addFile(src=>$lname);
      $pc++;
    }
    $c++;
  }
}

sub entryFName ( $ $ $ )
{
  my ($path, $c, $s) = @_;
  my ($dir,$name) = $path =~ m~^([^/]*)/?([^/.]+)~ or die;
  my $digits = $s < 10 ? 1 : 2;
  $digits = 2 if length($name) <= 6;
  $name = substr $name, 0, (8-$digits);
  $name .= sprintf("%0${digits}d",$c);
  return "$dir/$name";
}

###################################################################
#
# Index greation functions
#

sub createVcdFile ( $ )
{
  my ($name) = (@_);
  my $OUT = new IO::Handle;
  addFile( src => $name );
  ensureDirs($name);
  open $OUT, ">$name" 
      or die "Unable to open \"$name\" for writing\n";
  binmode $OUT, ":crlf";
  print "Writing \"$name\".\n";
  return $OUT;
}

sub contents ()
{
  my $OUT = createVcdFile( '0vcdindx.txt' );
  my $prevSrc = '';
  my $trackNum = 0;
  foreach my $s (@selections) 
  {
    next if $s->{type} eq 'menu';
    my $ind = "    "x(depth $s);
    if ($s->{type} eq 'video') {
      $trackNum++ if $s->{src} ne $prevSrc;
      printf $OUT "$ind%2d. $s->{title}", $trackNum;
      printf $OUT  " [@ %d:%02d]", int($s->{time}/ 60) , $s->{time} % 60
	  if $s->{time} != 0;
      print $OUT "\n";
      $prevSrc = $s->{src};
    } else {
      print $OUT "$ind *  $s->{title}\n";
    }
    print $OUT "$ind    $s->{extra}\n" if defined $s->{extra};
    print $OUT "\n";
  }
  close $OUT;
}

sub autorun ()
{
  my $OUT = createVcdFile( 'autorun.inf' );
  print $OUT "[AutoRun]\n";
  print $OUT "label=$group->{title}\n" if defined $group->{title};
  print $OUT "shellexecute=mpeg\\index.htm\n";
  print $OUT "\n";
  close $OUT;
}

sub index ()
{
  my $OUT = createVcdFile( 'index.htm' );
  print $OUT "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">\n";
  print $OUT "<html><head>\n";
  print $OUT "<title>$group->{title} VCD</title>\n";
  print $OUT "</head><body>\n";
  print $OUT "<h1>$group->{title} VCD</h1>\n";
  print $OUT "<h2>$group->{extra}</h2>\n" if defined $group->{extra};
  print $OUT "<p>\n";
  print $OUT "<ul>\n";
  if ($nice_mpeg_file_names) {
    print $OUT "<li><a href=\"mpeg/index.htm\">MPEG Index</a>\n";
  }
  print $OUT "<li><a href=\"0vcdindx.txt\">Text Index</a>\n";
  print $OUT "<li><a href=\"mpeglink/index.htm\">MPEG Link Index</a>\n"
      if $create_mpeg_link_files;
  print $OUT "</ul>\n";
  print $OUT "</body></html>\n";
  close $OUT;
}

sub mpegIndexGroup ( $ $ $ );
sub mpegIndexVideo ( $ $ $ );

sub mpegIndex ( $ )
{
  my ($mode) = @_;
  my $OUT = createVcdFile( "$mode/index.htm" );
  print $OUT "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">\n";
  print $OUT "<html><head>\n";
  print $OUT "<title>$group->{title} VCD Index</title>\n";
  print $OUT "</head><body>\n";
  print $OUT "<b>$group->{title}</b>\n";
  print $OUT " - <i>$group->{extra}</i>\n" if defined $group->{extra};
  print $OUT "<br>\n";
  print $OUT "VCD Index\n";
  mpegIndexGroup ($OUT, $group, $mode);
  print $OUT "</body></html>\n";
  close $OUT;
}

sub possibleLink ( $ $ $ );

sub mpegIndexGroup ( $ $ $ )
{
  my ($OUT, $group, $mode) = @_;

  print $OUT "<ul>\n";
  foreach my $d (@{$group->{content}}) {
    if ($d->{tag} eq 'video') {
      mpegIndexVideo($OUT, $d, $mode);
    } elsif ($d->{tag} eq 'group' && @{$d->{content}} == 1) {
      mpegIndexVideo($OUT, {%{$d->{content}->[0]}, 
			    title => $d->{title}, extra => $d->{extra}},
		     $mode);
    } elsif ($d->{tag} eq 'group') {
      print $OUT "<li><b>$d->{title}</b>\n";
      print $OUT " - <i>$d->{extra}</i>\n" if defined $d->{extra};
      mpegIndexGroup($OUT, $d, $mode);
    }
  }
  print $OUT "</ul>\n";
}

sub mpegIndexVideo ( $ $ $ )
{
  my ($OUT, $d, $mode) = @_;
  my $numParts = @{$d->{parts}};
  print $OUT "<li><b>";
  print $OUT possibleLink($d, $mode, $mode eq 'mpeg' || $numParts == 1);
  print $OUT "</b>\n";
  print $OUT " - <i>$d->{extra}</i>\n" if defined $d->{extra};
  if ($numParts > 1) {
    print $OUT "<ul>";
    foreach my $p (@{$d->{parts}}) {
      printf $OUT ('<li><tt>%02d:%02d</tt> - ', 
		   int($p->{time}/ 60), $p->{time} % 60);
      print $OUT possibleLink($p, $mode, $mode eq 'mpeglink');
      print $OUT "\n";
    }
    print $OUT "</ul>";
  }
}

sub possibleLink ( $ $ $ )
{
  my ($d, $mode, $link) = (@_);
  if ($link) {
    my $ext = $mode eq 'mpeg' ? '.mpg' : '.mpl';
    return "<a href=\"$d->{fname}$ext\">$d->{title}</a>";
  } else {
    return "$d->{title}";
  }
}

###################################################################
#
# Final XML Creation Functions
#

sub options ()
{
  my @options;
  if ($nice_mpeg_file_names) {
    push @options, newEmptyElt('option', {name => 'nice mpeg file names',
					  value => 'true'});
  }
  return @options
}

sub info ()
{
  my $elt = newElt('info');
  insertElt $elt, 'album-id', $videocd{'album-id'};
  insertElt $elt, 'volume-count', '1';
  insertElt $elt, 'volume-number', '1';
  insertElt $elt, 'restriction', '+0';
  return $elt;
}

sub pvd ()
{
  my $elt = newElt('pvd');
  insertElt $elt, 'volume-id', exists $videocd{'volume-id'} ? $videocd{'volume-id'} : $videocd{'album-id'};
  insertElt $elt, 'publisher-id', $videocd{'publisher-id'} if defined $videocd{'publisher-id'};
  
  return $elt;
}

sub writeFolder ( $ ; $);
sub writeFile ( $ );

sub filesystem()
{
  my $elt = newElt 'filesystem' ;
  return writeFolder \%filesystem, $elt;
}

sub writeFolder ( $ ; $ )
{
  my ($folder, $elt) = @_;
  if (!defined $elt) 
  {
    $elt = newElt 'folder';
    insertElt $elt, 'name', $folder->{name};
  }
  foreach (@{$folder->{folders}}) 
  {
    (writeFolder $_)->paste('last_child', $elt);
  }
  foreach (@{$folder->{files}}) 
  {
    (writeFile $_)->paste('last_child', $elt);
  }
  return $elt;
}

sub writeFile ( $ )
{
  my ($file) = @_;
  my $elt = newElt 'file', {src => $file->{src}};

  $elt->set_att('format', $file->{format}) if defined $file->{format};

  insertElt $elt, 'name',  $file->{name};

  return $elt;
}

sub segmentItems ()
{
  my $elt = newElt('segment-items');
  foreach my $v (@stills) 
  {
    insertEmptyElt $elt, 'segment-item', {src => $v->{src}, 
					  id => "v$v->{id}"};
  }
  return $elt;
}

sub sequenceItems ()
{
  my $elt = newElt('sequence-items');
  foreach my $v (@videos) 
  {
    my $first = shift @{$v->{parts}};
    my $seq = newEmptyElt('sequence-item', {src => $v->{src},
					    id => "v$first->{id}"});
    $seq->set_att('fname', "$v->{fname}.mpg") 
	if $nice_mpeg_file_names && defined $v->{fname};

    foreach my $p (@{$v->{parts}})
    {
      insertElt $seq, 'entry', {id => "v$p->{id}"}, fixNum($p->{time});
    }
    insert $elt, $seq;
    unshift @{$v->{parts}}, $first;
  }
  return $elt;
}

sub pbc ()
{
  my $elt = newElt('pbc');
  foreach my $s (@selections) 
  {
    next if $s->{type} eq 'group';
    my $sel = newElt('selection', {id => $s->{id}});
    insertElt $sel, 'bsn', '1';
    insertEmptyElt $sel, 'prev', {ref => $s->{prev} } if defined $s->{prev};
    insertEmptyElt $sel, 'next', {ref => $s->{next} };
    insertEmptyElt $sel, 'return', {ref => $s->{parent}} if defined $s->{parent};
    insertEmptyElt $sel, 'default', {ref => $s->{nextVideo} };
    insertEmptyElt ($sel, 'timeout', {ref => $s->{nextVideo} }) 
	unless $s->{wait} eq '-1' || $s->{loop} == 0;
    my $wait = $s->{wait};
    my @c = @{$s->{page}{menuItems}};
    $wait = ceil(1.5 * @c + 3) if $s->{wait} eq 'auto';
    insertElt $sel, 'wait', $wait unless $s->{loop} == 0;
    insertElt $sel, 'loop', $s->{loop};
    insertEmptyElt $sel, 'play-item', {ref => "v$s->{id}"};
    foreach my $c (@c)
    {
      $c .= "p1" if $selections{$c}{type} eq 'group';
      insertEmptyElt $sel, 'select', {ref => $c};
    }
    if ($s->{page}{useNext})
    {
      insertEmptyElt $sel, 'select' foreach (@c + 1 .. 8);
      insertEmptyElt $sel, 'select', {ref => $s->{page}{next} };
    }
    insert $elt, $sel;
  }
  return $elt;
}

###################################################################
#
# Menu creation and conversion functions
#

sub jobs () {{generate => \&generate, 
	      convert => \&convert}}

sub generate 
{
  my ($job) = @_;
  my $m = $selections{$job->{id}};

  print "Creating menu for \"$m->{title}\" as \"$job->{id}.png\".\n";

  my @choices;
  my @group = ();
  my $prevSrc = '';
  my $i = 1;
  foreach my $c (@{$m->{menuItems}}) 
  {
    my $s = $selections{$c};
    if ((!defined $s->{src} || $s->{src} ne $prevSrc) && @group) {
      push @choices, [@group];
      @group = ();
    }
    my $d = {};
    $d->{num} = $i;
    $d->{text} =  defined $s->{'menu-title'} ? $s->{'menu-title'} : $s->{title};
    $d->{extra} = defined $s->{'menu-extra'} ? $s->{'menu-extra'} : $s->{extra};
    $i++;
    
    push @group, $d;
    $prevSrc = defined $s->{src} ? $s->{src} : '';
  }
  push @choices, [@group];
  push @choices, [{num=>9, text=>"More..."}] if $m->{useNext};
  my $image = &createMenu(@$m{'title', 'extra', 'pageInfo'}, \@choices);
  $image->Write("$m->{id}.png");
  push @work, {action => 'convert', 
	       src => "$m->{id}.png", 
	       base => $m->{id}};
}

sub convert
{
  my ($job) = @_;
  my $base = $job->{base};

  die "norm != ntsc|pal" unless $videocd{norm} =~ /^ntsc|pal$/;

  print "Converting \"$job->{src}\" to mpeg still.\n";

  my $image0 = Image::Magick->new;
  $image0->Read($job->{src}) == 1 or die "Unable to Open \"$job->{src}\"\n";
  my $image1 = $image0->Copy;
  
  my $small = "$job->{base}-small.ppm";
  $image0->Scale('352x240!') if $videocd{norm} eq 'ntsc';
  $image0->Scale('352x288!') if $videocd{norm} eq 'pal';
  $image0->Write($small);
  $image0 = undef;

  my $large = "$job->{base}-large.ppm";
  $image1->Scale('704x480!') if $videocd{norm} eq 'ntsc';
  $image1->Scale('704x576!') if $videocd{norm} eq 'pal';
  $image1->Write($large);
  $image1 = undef;

  my $pnmdepthFlags = '';
  $pnmdepthFlags = '--pal' if $videocd{norm} eq 'pal';
  my $ppmtoy4mFlags = '-F 30000:1001';
  $ppmtoy4mFlags = '-F 25:1' if $videocd{norm} eq 'pal';

  system ("cat $large "
	  ."| pnmdepth 255"
	  ."| ppmntsc $pnmdepthFlags"
	  ."| ppmtoy4m -v 0 -S 420_jpeg $ppmtoy4mFlags"
	  ."| mpeg2enc -v 0 -f 6 -a 2 -T 120 -o $job->{base}-large.m1v");
  system ("cat $small "
	  ."| pnmdepth 255"
	  ."| ppmntsc $pnmdepthFlags"
	  ."| ppmtoy4m -v 0 -S 420_jpeg $ppmtoy4mFlags"
	  ."| mpeg2enc -v 0 -f 6 -a 2 -T 35 -o $job->{base}-small.m1v");
  system ("mplex -v 0 -f 6 $job->{base}-large.m1v $job->{base}-small.m1v "
	  ."-o $job->{base}.m1p");
}

sub annotateFit ( $ $ $ @ );

sub defaultParms ()
{

  (tryList => [{font => "\@$FONT_DIR/$NORMAL_FONT"},
	       {font => "\@$FONT_DIR/$CONDNS_FONT"}],
   default => {fill=> 'white', 
	       font=> "\@$FONT_DIR/$NORMAL_FONT"},
   background => 'black',
   title => {pointsize=>36, Gravity=>'North', height=>44},
   extra => {pointsize=>24, Gravity=>'North', height=>32},
   pageInfo => {pointsize=>20, Gravity=>'North', height=>26},
   num => {pointsize=>32, x=>60},
   numFunc => sub {"$_[0])"},
   choice => {pointsize=>32, x=>100},
   choiceExtra => {pointsize=>22, x=>100, y=>24},
   choiceExtraFunc => sub {"$_[0]"},
   start => 50, end => 520,
   height => 36, heightWithExtra => 58,
 )
}

sub createMenu ( $ $ $ $ )
{
  my ($choices, $parms) = @_[3,4];
  my %text;
  @text{'title','extra','pageInfo'} =  @_[0,1,2];
  $parms = \%menuParms;

  my $image = Image::Magick->new(size=>'768x576',
				 %{$parms->{default}});
  $image->Read("xc:$parms->{background}");
  $image->Set(density=>"72x72"); # so that pointsize = pixelsize

  my @tryList = @{$parms->{tryList}};

  my $start = $parms->{start};

  foreach my $what (qw(title extra pageInfo)) 
  {
    next unless hasValue $text{$what};
    my %parms = (text=>$text{$what}, %{$parms->{$what}});
    $parms{y} = $start + $parms{pointsize};
    $start += delete $parms{height};
    annotateFit $image, \%parms, 620, @tryList;
  }

  my $height = $parms->{height};
  my $heightWithExtra = $parms->{heightWithExtra};
  my $heightExtra = $heightWithExtra - $height;
  my $totalHeight = $parms->{end} - $start;

  my $numFunc = $parms->{numFunc};
  my $choiceExtraFunc = $parms->{choiceExtraFunc};

  my $numSpaces = @$choices - 1;
  my $numLittleSpaces = 0;
  foreach (@$choices) {$numLittleSpaces += @{$_} - 1;}
  if ($numSpaces < 1) {
    $choices = [map {[$_]} @{$choices->[0]}];
    $numSpaces = $numLittleSpaces;
    $numLittleSpaces = 0;
  }
  my $numChoices = $numSpaces + $numLittleSpaces + 1;
  my $numChoicesWithExtra = 0;
  foreach (@$choices) {foreach (@$_) {$numChoicesWithExtra++ 
					  if hasValue $_->{extra}}}
  my $useExtra = 1;
  my $totalSpaceHeight 
      = $totalHeight 
      - $height * ($numChoices - $numChoicesWithExtra)
      - $heightWithExtra * $numChoicesWithExtra;
  if ($totalSpaceHeight < 0) {
    $useExtra = 0;
    $totalSpaceHeight = $totalHeight - $height * $numChoices;
  }
  my $spaceHeight = int $totalSpaceHeight/(1 # leave a half space above 
					     # and below choices
					   + $numSpaces 
					   + $numLittleSpaces/3);
  my $littleSpaceHeight = int $spaceHeight/3;
  my $spaceHeightDiff = $spaceHeight - $littleSpaceHeight;

  my $pos = $start + $height + int $spaceHeight/2;
  foreach (@$choices) 
  {
    foreach (@$_) 
    {
      $image->Annotate(text=>&$numFunc($_->{num}), y=>$pos, %{$parms->{num}});
      annotateFit ($image, {text=>$_->{text}, y=>$pos, %{$parms->{choice}}},
		   695-$parms->{choice}{x}, @tryList);
      
      if ($useExtra && hasValue $_->{extra}) 
      {
	my %opts = %{$parms->{choiceExtra}};
	$opts{y} += $pos;
	annotateFit ($image, {text=>&$choiceExtraFunc($_->{extra}), %opts},
		     695-$opts{x}, @tryList);
	$pos += $heightExtra;
      }
      
      $pos += $height + $littleSpaceHeight;
    }
    $pos += $spaceHeightDiff;
  }

  return $image;
}

sub annotateFit ( $ $ $ @ )
{
  my ($image, $parms, $maxWidth, @tryList) = @_;
  my $width;

  my ($den, $ps) = $image->Get('x-resolution', 'pointsize');

  my $i = -1;
  do {
    $i++;
    (undef, undef, undef, undef, $width, undef, undef) =
	$image->QueryFontMetrics(%$parms, %{$tryList[$i]});
  } until ($i >= $#tryList || $width <= $maxWidth);

  print STDERR "WARNING: Text \"$parms->{text}\" has a width of $width which is larger than the maximum line width of $maxWidth.\n" if $width > $maxWidth;

  $image->Annotate(%$parms, %{$tryList[$i]});
}

###################################################################
#
# Util Functions
#

sub attsUnescaped ( $ ) 
{
  my ($node) = @_;
  my %hash;
  return \%hash unless defined $node;
  while  (my ($k,$v) = each %{$node->atts}) 
  {
    $hash{$k} = unescape $v;
  }
  return \%hash;
}

sub attsUnescapedTitle ( $ ) 
{
  my ($node) = @_;
  my $hash = attsUnescaped($node);
  return $hash unless defined $_[0];
  if (defined $hash->{title}) {
    # this will set the hash value to undef if the elements don't exist
    $hash->{extra} = $hash->{extra};
    $hash->{'menu-title'} = $hash->{'menu-title'};
    $hash->{'menu-extra'} = $hash->{'menu-extra'};
  }
  return $hash
}

sub hashNode ( $ )
{
  my ($node) = @_;
  my $hash = attsUnescaped $node;
  foreach my $n ($node->children)
  {
    $hash->{$n->gi} = attsUnescaped $n;
  }
  return $hash;
}

sub unescape ( $ ) 
{
  local $_ = $_[0];
  my %une = (apos=>"'", lt=>"<", gt=>">", quot=>'"', amp=>'&');
  s/\&(.+?)\;/$une{$1}/ge;
  s/\s+/ /g;
  return "$_";
}

sub isGroup ( $ )
{
  return exists $selections{$_[0]} && $selections{$_[0]}->{type} eq 'group';
}

sub depth ( $ )
{
  local $_ = $_[0]->{id};
  my $i = 0;
  while (/-/g) {$i++};
  return $i;
}

sub itemNum ( $ ) 
{
  local $_ = $_[0]->{id};
  return 'X' if $_ eq 'x';
  my ($num) = /-(\d)+$/ or die;
  return $num;
}

sub ensureDirs ( $ )
{
  my @dirs = split /\//, $_[0];
  pop @dirs;
  my $dir;
  foreach (@dirs) {$dir .= $_; mkdir $dir; $dir .= '/'}
}

###################################################################
#
# File system managment functions
#

sub baseName ( $ )
{
  $_[0] =~ /([^\/\\]+)$/ or die;
  return $1;
}

sub addFile ( % )
{
  my (%f) = @_;
  die "src tag not defined" unless defined $f{src};
  $f{name} = $f{src} unless defined $f{name};
  $f{name} = lc $f{name};
  my @dirs = split /\//, $f{name};
  my $folder = defined $f{folder} ? $f{folder} : \%filesystem;
  while (@dirs > 1) 
  {
    my $n = shift @dirs;
    my @f = grep {$_->{name} eq $n} @{$folder->{folders}};
    if (@f) {
      $folder = $f[0];
    } else {
      my $f0 = makeFolder($n);
      push @{$folder->{folders}}, $f0;
      $folder = $f0;
    }
  }
  my $n = shift @dirs;
  my $file;
  if (grep {$_->{name} eq $n} @{$folder->{files}}) {
    print "ERROR: file $n already exists\n";
  } else {
    $file = makeFile(%f,name => $n);
    push @{$folder->{files}}, $file;
  }
  return $file;
}

sub makeFolder ( % )
{
  my ($name) = @_;
  return {type => 'folder',
	  name => lc $name,
	  folders => [],
	  files => []};
}

sub makeFile ( % )
{
  my (%f) = @_;
  return {type => 'file', 
	  src  => $f{src},
	  name => defined $f{name} ? lc $f{name} : lc baseName($f{src}),
	  format => $f{format}};
}