#!/usr/bin/perl -w

# this script takes the sexchart as input, with these 2 fixes:
#
#   - bug in the chart: "--bohr " should be "- bohr "
#   - bug in the chart: at ling 248 and 249 there is a bubble in a line.
#
# and all the descriptional lines removed.
#
# you can find the sex chart at http://www.attrition.org/hosted/sexchart
#
# it outputs a .dot file for graphviz, so you can view a more graphical
# version of the chart.
# 
# still have to figure out how to use graphviz tools to make the resulting
# graph better organised.
#


use strict;

my $lineinfo= [];
my $ypos= 0;
while(<>) {
    $lineinfo= ParseLine($_, $ypos++, $lineinfo);
}

#Person::print();

exit(0);
# todo:
# change Person and Track, to both have a similar interface
# both can be attached, and extended.
#
sub ProcessTrackSegment {
    my ($xpos, $ypos, $c, $prevdown, $infodown, $cur)= @_;
    #print "($xpos,$ypos): '$c', pd[$xpos]=", (defined $prevdown->[$xpos]?"def":"undef"), ", ct=", (defined $cur->{curtrack}?"def":"undef"), ", pp=", (defined $cur->{prevperson}?"def":"undef"), "\n";
    if ($c eq "|") {
        if (!$prevdown->[$xpos]) {
            die "nothing to connect to at ($xpos, $ypos)\n";
        }
        elsif ($prevdown->[$xpos]->isPerson()) {
            my $track= Track->new($xpos, $ypos);
            $track->AttachPerson($prevdown->[$xpos]);
            $infodown->[$xpos]= $track;
        }
        else {
            $prevdown->[$xpos]->ExtendTrack($xpos, $ypos);
            $infodown->[$xpos]= $prevdown->[$xpos];
        }

    }
    elsif ($c eq ".") {
        if ($cur->{curtrack}) {   # { ` | person }---. 
            $cur->{curtrack}->ExtendTrack($xpos, $ypos);
            $infodown->[$xpos]= $cur->{curtrack};
            $cur->{curtrack}= undef;
            $cur->{prevperson}= undef;
        }
        else {    #   .----
            $cur->{curtrack}= Track->new($xpos, $ypos);
            $infodown->[$xpos]= $cur->{curtrack};
        }
    }
    elsif ($c eq "`") {
        if ($cur->{curtrack}) {   #  ---`
            die "unclosed track ", $cur->{curtrack}->AsString(), " at ($xpos, $ypos)\n";
        }
        else {    #   `----
            if (!$prevdown->[$xpos]) {
                die "missing up track at ($xpos, $ypos)\n";
            }
            elsif ($prevdown->[$xpos]->isPerson()) {
                $cur->{curtrack}= Track->new($xpos, $ypos);
                $cur->{curtrack}->AttachPerson($prevdown->[$xpos]);
            }
            else {
                $cur->{curtrack}= $prevdown->[$xpos];
                $cur->{curtrack}->ExtendTrack($xpos, $ypos);
            }
        }
    }
    elsif ($c eq "'") {
        if ($cur->{curtrack}) {   #  ---'
            if ($infodown->[$cur->{curtrack}{xstart}]) {  # .---'
                if ($prevdown->[$xpos]->isPerson()) {
                     $cur->{curtrack}->AttachPerson($prevdown->[$xpos]);
                }
                else {
                    $prevdown->[$xpos]->ExtendTrack($cur->{curtrack}{xstart}, $ypos);
                    $infodown->[$cur->{curtrack}{xstart}]= $prevdown->[$xpos];
                }
                $cur->{curtrack}= undef;
                $cur->{prevperson}= undef;
            }
            else {    #  `----'
                if ($prevdown->[$xpos]->isPerson()) {
                    $cur->{curtrack}->AttachPerson($prevdown->[$xpos]);
                }
                else {
                    $cur->{curtrack}->ExtendTrack($xpos, $ypos);
                    $cur->{curtrack}->AppendTrack($prevdown->[$xpos]);
                }
                $cur->{curtrack}= undef;
                $cur->{prevperson}= undef;
            }
        }
        else {    #   '----
            die "missing track at ($xpos, $ypos)\n";
        }
    }
    elsif ($c eq "-") {
        if (defined $cur->{prevperson}) {
            $cur->{curtrack}= Track->new($xpos, $ypos);
            $cur->{curtrack}->AttachPerson($cur->{prevperson});
        }
        elsif (!defined $cur->{curtrack}) {
            die "missing track at ($xpos, $ypos)\n";
        }
        else {
            # ok, just extending current track.
        }
    }
    elsif ($c eq " ") {
        if ($cur->{curtrack}) {
            die "interrupted track at ($xpos, $ypos)\n";
        }
    }
    else {
        die "unexpected character $c at ($xpos, $ypos)\n";
    }
}
sub ParseLine {
    my ($line, $ypos, $prevdown)= @_;

    # make sure the line ends with a space.
    $line =~ s/\s+$/ /;


    my @infodown;
    # find names, assign name-id's
    #   - a name is any sequence of non-whitespace chars that have
    #     word characters in them.  /\s\([!#@*$%]*\S*\w\S*[!#@*$%]*\s\)\+/
    #   -  ... complication: names may contain single spaces.
    #   - names can be padded with [!#@*$%], the padding is not part of
    #     the name.
    #   - bug in the chart: "--bohr " should be "- bohr "
    #   - bug in the chart: at ling 248 and 249 there is a bubble in a line.
    #
    # find endpoints, assign track-id's
    #
    #   - a "." (dot)  connects downwards, and either to the left or right.
    #   - a "'" (quote) connects upwards, and to the left
    #   - a "`" (tick) connects upwards, and to the right
    #   - a "|" (bar) connects upwards and downwards
    #   - a name, connects to all directions.

    my %cur= (
        curtrack=>undef,
        prevperson=>undef,
    );
    while ($line =~ /\s(?:[!#@*$%]*\S*\w\S*[!#@*$%]*\s)+/g) {
        my $person= Person->new(pos($line)-length($&),$ypos,  pos($line)-1,$ypos, $&);

        if (defined $cur{curtrack}) {
            $cur{curtrack}->AttachPerson($person);
        }

        # process tracks leading up to person.
        for (my $xpos= ($cur{prevperson} ? $cur{prevperson}{xend}+1 : 0) ; $xpos < $person->{xstart} ; $xpos++) {
            my $c= substr($line, $xpos, 1);
            ProcessTrackSegment($xpos, $ypos, $c, $prevdown, \@infodown, \%cur);
        }
        for (my $xpos= $person->{xstart} ; $xpos<=$person->{xend} ; $xpos++) {
            if ($prevdown->[$xpos] && !$prevdown->[$xpos]->isPerson()) {
                $prevdown->[$xpos]->AttachPerson($person);
            }
            $infodown[$xpos]= $person;
        }
        $cur{prevperson}= $person;
        $cur{curtrack}= undef;
    }
    for (my $xpos= ($cur{prevperson} ? $cur{prevperson}{xend}+1 : 0) ; $xpos < length($line) ; $xpos++) {
        my $c= substr($line, $xpos, 1);
        ProcessTrackSegment($xpos, $ypos, $c, $prevdown, \@infodown, \%cur);
    }
    if (defined $cur{curtrack}) {
        die "open ended track", $cur{curtrack}->AsString(), " at end of line $ypos\n";
    }

    return \@infodown;
}

package Track;
my $id= 0;
sub new {
    my ($class, $xpos, $ypos)= @_;
    return bless { id=>$id++, xstart=>$xpos, ystart=>$ypos }, $class;
}
sub AsString {
    my ($self)= @_;

    return "track $id ($self->{xstart},$self->{ystart}) -> ($self->{xend},$self->{yend})\n";
}
sub AttachPerson {
    my ($self, $person)= @_;

    push @{$self->{persons}}, $person;

    if (@{$self->{persons}} ==2) {
        print "$person->{name} -> $self->{persons}[0]{name}\n";
    }
    elsif (@{$self->{persons}} >2) {
        die "more than 2 persons on track ", $self->AsString(), "\n";
    }
}
sub ExtendTrack {
    my ($self, $xpos, $ypos)= @_;
    $self->{xend}= $xpos;
    $self->{yend}= $ypos;
}
sub AppendTrack {
    my ($self, $track)= @_;
    $self->{xend}= $track->{xpos};
    $self->{yend}= $track->{ypos};
}
sub isPerson { return 0; }

package Person;
use Dumpvalue;
my %names;
sub new {
    my ($class, $xstart,$ystart, $xend,$yend, $name)= @_;

    $name =~ s/^\s[!#@*$%]*//;
    $name =~ s/[!#@*$%]*\s$//;

    if (!exists $names{$name}) {
        $names{$name}= bless { name=>$name, positions=>[]}, $class;
    }
    my $self= $names{$name};

    my %pos= ( xstart=>$xstart, ystart=>$ypos, xend=>$xend, yend=>$ypos );
    push @{$self->{positions}}, \%pos;
    $self->{$_}= $pos{$_} for keys %pos;

    return $self;
}
sub isPerson { return 1; }

sub print {
    my $d= new Dumpvalue;
    $d->dumpValue(\%names);
}