#!/usr/bin/perl
use strict;
require 'html-content.pl';
our $LIST;

use Getopt::Long;
use Pod::Usage;
my $target = 'pre';
my %argv;
GetOptions (
  q<help> => \$argv{help},
  q<no-transitional> => \$argv{'no-transitional'},
  q<no-strict> => \$argv{'no-strict'},
  q<no-frameset> => \$argv{'no-frameset'},
  q<element-type=s> => \$target,
) or pod2usage (2);
pod2usage (-exitval => 0, -verbose => 1) if $argv{help};

sub is_element ($) {
  my ($value) = @_;
  $value =~ /[%A-Z]/ ? 0 : 1;
}

my $OK = 'O';
my $NG = 'X';

sub mark (%);
sub mark (%) {
  my %opt = @_;
  my @member;
  push @member, split /[\s|]+/, $opt{$_}->{$opt{class}} for @{$opt{member}};
  ELEMENT: for my $element (@member) {
    if (is_element $element) {
      for (@{$opt{table}}) {
        if ($_->[0] eq $element) {
          $_->[-1] = $opt{mark};
          next ELEMENT;
        }
      }
      my $row = [$element];
      for (my $i = $#{$opt{table}->[0]} - 1; $i > 0; $i--) {
        push @$row, '-1';
      }
      push @$row, $opt{mark};
      push @{$opt{table}}, $row;
    } else {
      mark %opt,
           class => $element,
           member => [qw/list list2/];
    }
  }
}

sub add (%) {
  my (%opt) = @_;
  push @{$opt{table}->[0]}, $opt{name};
  push @{$opt{table}->[$_]}, '-1' for 1..$#{$opt{table}};
  mark %opt, mark => $OK, class => $opt{target},
       member => [qw/list list2 plus/];
  mark %opt, mark => $NG, class => $opt{target},
       member => [qw/minus/];
}

sub element ($) {
  my $el = shift;
  if ($el =~ /[A-Z%]/) {
    qq<<code>$el</code>>;
  } else {
    qq<<code class="HTMLe">$el</code>>;
  }
}

sub serialize ($$) {
  my ($tbl, $span) = @_;
  my $r = q<<table border><thead><tr>>;
  $r .= join '', map {qq<<th>$_</th>>} @{$tbl->[0]};
  $r .= q<</tr></thead><tbody>>;
  for my $i (1..$#$tbl) {
    $r .= q<<tr>>;
    $r .= q<<th>>.element ($tbl->[$i]->[0]).q<</th>>;
    for my $j (1..$#{$tbl->[$i]}) {
      if ($tbl->[$i]->[$j]) {
        $r .= q{<td};
        $r .= q< rowspan=">.$span->[$i]->[$j]->{row}.q<"> if $span->[$i]->[$j]->{row};
        $r .= q< colspan=">.$span->[$i]->[$j]->{col}.q<"> if $span->[$i]->[$j]->{col};
        $r .= q{>};
        $r .= element ($tbl->[$i]->[$j]) || '-' unless $tbl->[$i]->[$j] eq '-1';
        $r .= q<</td>>;
      }
    }
    $r .= qq<</tr>\n>;
  }
  $r .= qq<</tbody></table>\n>;
  $r;
}

sub equal ($$) {
  my ($x, $y) = @_;
  return $x eq $y;
}

sub merge_row ($$) {
  my ($tbl, $span) = @_;
  for my $i (1..($#$tbl-1)) {
    for my $j (1..$#{$tbl->[$i]}) {
      if ($tbl->[$i]->[$j]) {
        my $s = 1;
        for my $ii (($i+1)..$#$tbl) {
          if ($tbl->[$ii]->[$j] and
              $span->[$i]->[$j]->{col} == $span->[$ii]->[$j]->{col} and
              equal $tbl->[$i]->[$j] => $tbl->[$ii]->[$j]) {
            $s++;
            $tbl->[$ii]->[$j] = 0;
          } else {
            last;
          }
        }
        $span->[$i]->[$j]->{row} = $s if $s > 1;
      }
    }
  }
}

sub merge_col ($$) {
  my ($tbl, $span) = @_;
  for my $i (1..$#$tbl) {
    for my $j (1..($#{$tbl->[$i]}-1)) {
      if ($tbl->[$i]->[$j]) {
        my $s = 1;
        for my $jj (($j+1)..$#{$tbl->[$i]}) {
          if ($tbl->[$i]->[$jj] and
              $span->[$i]->[$j]->{row} == $span->[$i]->[$jj]->{row} and
              equal $tbl->[$i]->[$j] => $tbl->[$i]->[$jj]) {
            $s++;
            $tbl->[$i]->[$jj] = 0;
          } else {
            last;
          }
        }
        $span->[$i]->[$j]->{col} = $s if $s > 1;
      }
    }
  }
}

my $tbl = [['']];
my @span;

for (@$LIST) {
  next if $argv{'no-strict'} and $_->{name} =~ /Strict|ISO-HTML|XHTML 1.1/
                                   and not $_->{name} =~ /Legacy/;
  next if $argv{'no-transitional'} and $_->{name} =~ /Transitional|Legacy/
                                   and not $_->{name} =~ /Frameset/;
  next if $argv{'no-frameset'} and $_->{name} =~ /Frameset/
                                   and not $_->{name} =~ /Transitional/;
  add target => $target, table => $tbl, name => $_->{name},
      list => $_->{class}, list2 => $_->{class_misc},
      plus => $_->{plus}, minus => $_->{minus};
}
merge_col $tbl, \@span;
merge_row $tbl, \@span;

print STDOUT qq<<!DOCTYPE table SYSTEM>\n>;
print STDOUT serialize $tbl, \@span;

=head1 NAME

mkclstbl - HTML Element Type Class History Table Generator

=head1 SYNOPSIS

  mkclstbl.pl [--no-strict] [--no-transitional] [--no-frameset] > table.html
  mkclstbl.pl --help

=head1 DESCRIPTION

This script generates an HTML table that describes what element type belongs
what element class(es) in versions of HTML.

=head1 OPTIONS

This script has four arguments:

=over 4

=item --help

Show help message.

=item --no-frameset

Omit some columns that describes Frameset DTDs.

=item --no-strict

Omit some columns that describes Strict DTDs, ISO-HTML, XHTML 1.1 or
XHTML m12n Abstract Modules.

=item --no-transitional

Omit some columns that describes Transitional DTDs.

=back

=head1 SEE ALSO

HTML Specifications and DTDs.

<http://suika.fam.cx/www/2004/html/>.

=head1 LICENSE

Copyright 2004 Wakaba <w@suika.fam.cx>

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

# $Date: 2004/09/23 01:29:03 $