diagram

#! /usr/bin/perl

use warnings;
use strict;

use GBTrains::Schema;

use DateTime::Format::Natural;
use YAML;

my $sch = GBTrains::Schema->connect("dbi:SQLite:dbname=mca.sqlite");

my $conf = YAML::LoadFile($ARGV[0]);

my $dateparse = DateTime::Format::Natural->new(time_zone => 'Europe/London');
my ($from, $to);
if (ref($conf->{date}) eq 'ARRAY') {
    ($from, $to) = map $dateparse->parse_datetime($_), @{$conf->{date}};
} else {
    ($from, $to) = $dateparse->parse_datetime_duration($conf->{date});
}

# Axis-rendering code only works in whole hours.

$from->truncate(to => 'hour');
unless (defined $to) {
    $to = $from->clone->add(days => 1);
}
$to->truncate(to => 'hour');

my $heading = $from->ymd;
if ($to->ymd ne $from->ymd) {
    $heading .= " to " . $to->ymd;
}

# Convert bare TIPLOCs into ones with empty configuration.
for (@{$conf->{tiplocs}}) {
    $_ = { $_ => { } } unless ref;
}

# Convert CRS codes into TIPLOCs.
for (@{$conf->{tiplocs}}) {
    my $code = (keys(%$_))[0];
    if (length($code) == 3) {
	my $ti = $sch->resultset("ti")->search({crs_code => $code})->single;
	if ($ti) {
	    $_ = { $ti->tiploc => $_->{$code}};
	} else {
	    warn "couldn't get a TIPLOC for $code\n";
	}
    }
}

# Separate TIPLOCS into names and configurations.
my @tiploc = map((keys(%$_))[0], @{$conf->{tiplocs}});
my %tiplocconf = map(%$_, @{$conf->{tiplocs}});

sub labelcase ($) {
    for (@_) {
	s/\b(\w)(\w+)/$1\L$2/g;
	return $_;
    }
}

# Set default configuration.
for (keys %tiplocconf) {
    unless (exists($tiplocconf{$_}{label})) {
	my $ti = $sch->resultset("ti")->search({tiploc => $_})->single;
	if ($ti) {
	    $tiplocconf{$_}{label} = labelcase($ti->tps_descr);
	} else {
	    warn "couldn't get a description for $_\n";
	}
    }
}

my %tiplocmap;
for (my $i = 0; $i < @tiploc; $i++) {
    $tiplocmap{$tiploc[$i]} = $i;
}

my $line = 0;
my $lasttime;

sub tweaktime {
    my $offset = $from->delta_ms($_[0])->in_halfmins;
    $offset = -$offset if $_[0] < $from;
    $_[0] = $offset;
}

sub pass {
    tweaktime($_[0]);
    printf "%d %d %s\n", @_[0,1], $line ? 'cont' : 'start';
    printf("%s\n", $_[2]) unless $line;
    $line = 1
}

sub pubarrdep {
    my ($arr, $dep, $stn, $act) = @_;
    tweaktime($arr) if $arr;
    tweaktime($dep) if $dep;
    my $qual = '';
    if (grep /^R$/, @$act) {
	$qual = 'req'; # Request stop
    }
    if ($arr && $dep) {
	printf "%d %d %d %d %sarrdep\n", $arr, $stn, $dep, $stn, $qual;
    } elsif ($arr) {
	printf "%d %d %sarr\n", $arr, $stn, $qual;
    } elsif ($dep) {
	printf "%d %d %sdep\n", $dep, $stn, $qual;
    }
}

sub dep {
    tweaktime($_[0]);
    printf "%d %d dep\n", @_;
}

sub done {
    if ($line) {
	printf "finish\n";
    }
    $line = 0;
    undef $lasttime;
}

print <<EOH;
%!PS-Adobe-3.1
%%Creator: diagram
%%DocumentSuppliedResources: procset bjh21-diagram 1 0
%%EndComments
%%BeginResource: procset bjh21-diagram 1 0
/bjh21-diagram
10 dict dup begin
/conv {
    18 mul exch
    tscale mul exch
} def

/start { gsave conv moveto } def
/cont { conv lineto } def
/adstyle { 1 setlinewidth } def
/arr { gsave newpath conv moveto -3 3 rmoveto
       3 0 rlineto 0 -6 rlineto -3 0 rlineto
       adstyle stroke grestore} def
/dep { gsave newpath conv moveto 3 3 rmoveto
       -3 0 rlineto 0 -6 rlineto 3 0 rlineto
       adstyle stroke grestore } def
/arrdep { gsave newpath conv 4 2 roll conv
          2 copy moveto 0 3 rmoveto 0 -6 rlineto
          4 2 roll 2 copy moveto 0 3 rmoveto 0 -6 rlineto
          2 copy moveto 3 3 rmoveto 4 2 roll 2 copy 3 add exch 3 sub exch lineto
          moveto -3 -3 rmoveto 3 sub exch 3 add exch lineto
          adstyle stroke grestore } def
/reqarrdep { gsave newpath conv 4 2 roll conv
	     moveto -3 -3 rmoveto 3 3 rlineto -3 3 rlineto
	     3 -3 rmoveto lineto 3 3 rmoveto -3 -3 rlineto 3 -3 rlineto
	     adstyle stroke grestore } def
/finish { stroke grestore } def

/heading {
    gsave 0 exch conv moveto 0 30 rmoveto
    /Helvetica-Bold findfont 20 scalefont setfont
    show grestore
} def

/labelright {
    gsave 1.5 -3 rmoveto show grestore
} def

/labelup {
    gsave currentpoint translate 90 rotate 0 0 moveto labelright grestore
} def

/axes {
    3 dict begin
    /tiplocs exch def
    /hours exch def
    % Major time divisions (hours)
    gsave 0.5 setlinewidth 0.5 setgray
    tiplocs length 1 sub
    0 1 hours length 1 sub { % for
	dup 120 mul 0 conv moveto dup 120 mul 2 index conv 10 add lineto
	hours exch get labelup
    } for
    stroke
    % Minor time divisions (five minutes)
    0.1 setlinewidth
    0 1 hours length 1 sub 12 mul {
	dup 10 mul 0 conv moveto dup 10 mul 2 index conv lineto pop
    } for
    stroke
    pop
    % Space divisions
    0.5 setlinewidth
    0 1 tiplocs length 1 sub
    { dup 0 exch conv moveto dup hours length 1 sub 120 mul exch conv lineto
	  tiplocs exch get labelright } for
    stroke grestore
    0 0 conv hours length 1 sub 120 mul tiplocs length 1 sub conv rectclip
    end
} def
end /ProcSet defineresource
%%EndResource
%%EndProlog
%%BeginSetup
<< /PageSize [ 841 595 ] >> setpagedevice
/bjh21-diagram /ProcSet findresource begin
%%EndSetup
%%Page 1 1
%%BeginPageSetup
1 setlinewidth
/Helvetica findfont 10 scalefont setfont
36 36 translate
%%EndPageSetup
userdict begin
EOH

sub DateTime::Duration::in_halfmins {
    my $self = shift;
    my ($m, $s) = $self->in_units('minutes', 'seconds');
    return $m * 2 + $s / 30;
}

printf "gsave -18 -18 moveto currentfont 0.5 scalefont setfont
        (CIF file ID: %s) show grestore\n",
       $sch->resultset('hd')->single->file_id;

my $stdwidth = 72*10;
print "/tscale ", $stdwidth / $from->delta_ms($to)->in_halfmins, " def\n";

printf "(%s) %d heading\n", $heading, scalar(@tiploc);

print "[ ";
for (my $tick = $from->clone;
     $tick <= $to;
     $tick->add(hours => 1)) {
    printf "(%s)", $tick->strftime("%H:%M");
}
print "]\n";
print "[";
for (@tiploc) {
    printf "(%s)", $tiplocconf{$_}{label};
}
print "] axes\n";

my $rs;
if (exists $conf->{trains}) {
    my @train = @{$conf->{trains}};
    $rs = $sch->resultset('bs')->search({unique_id => \@train})
} else {
    $rs = $sch->resultset('bs')->search({ 'lis.tiploc' => \@tiploc },
					{ join => { crs => 'lis' },
					  group_by => ['me.lineno'],
					  having => \ "count(*) > 1"});
}

sub tzstr {
    my $off = $_[0]->offset;
    use integer;
    return sprintf("%+03d%02d", $off / 3600, ($off / 60) % 60);
}

sub debugtime {
    printf("%% %10s: %s%s\n", $_[0], $_[1], tzstr($_[1])) if $_[1];
}

while (my $bs = $rs->next) {
    for (my $day = $from->clone->truncate(to => 'day')->subtract(days => 1);
	 $day < $to;
	 $day->add(days => 1)) {
	my $train;
	eval {
	    $train = $bs->instantiate($day);
	};
	if ($@) {
	    warn $bs->unique_id . " on " . $day->ymd . ": $@";
	}
	next unless defined $train;
	printf("%% %s (%s):\n", $train->bs->unique_id, $day->ymd);
	my $style = "";
	$style = "1 0 0 setrgbcolor % VT service"
	    if $train->bs->atoc_code eq 'VT';
	$style = "0 0 1 setrgbcolor % loco-hauled service"
	    if $train->bs->crs->first()->power_type eq 'D';
	$style = "0.75 setgray % bus service"
	    if grep($train->bs->crs->first()->category eq $_, ('BR', 'BS'));
	for my $loc ($train->stops) {
	    if (exists $tiplocmap{$loc->li->tiploc}) {
		no warnings qw/uninitialized/;
		printf("%% %-5s %-4s %-5s %-4s %-5s %s (%s)\n",
		       $loc->li->sched_arr_time, $loc->li->public_arr_time,
		       $loc->li->sched_pass,
		       $loc->li->public_dep_time, $loc->li->sched_dep_time,
		       $loc->li->tiploc, join(", ", @{$loc->li->activity}));
		debugtime("sched arr",  $loc->sched_arr_time);
		debugtime("sched pass", $loc->sched_pass);
		debugtime("sched dep",  $loc->sched_dep_time);
		debugtime("pub arr",    $loc->public_arr_time);
		debugtime("pub dep",    $loc->public_dep_time);
		for ($loc->sched_arr_time, $loc->sched_pass,
		     $loc->sched_dep_time) {
		    pass($_, $tiplocmap{$loc->li->tiploc}, $style) if $_;
		}
		pubarrdep($loc->public_arr_time, $loc->public_dep_time,
			  $tiplocmap{$loc->li->tiploc}, $loc->li->activity);
	    }
	}
	done;
    }
} 

print "showpage end\n%%EOF\n";