path: root/bin/rdf2hours

#!/usr/bin/perl
#
# Copyright © 2013 Jonas Smedegaard <dr@jones.dk>
# Description: render opening hours webpage from RDF data
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3, or (at your option)
# any later version.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

use 5.010;
use strictures 1;
use utf8::all;
#use DDP alias => 'Dumper';

use DateTimeX::Easy;
use DateTime::Format::W3CDTF;
use Carp;
use Try::Tiny;
use RDF::Query;
use RDF::TrineX::Functions qw[curie model parse];
use HTML::HTML5::Builder qw[:standard];
use HTML::HTML5::Writer;

# TODO: add options --verbose and --debug

# TODO: add override options --theme and (multivalued) --category
my @category = <<LIST =~ m/(\S.*\S)/g;
    <http://schema.org/FoodEstablishment>
    <http://schema.org/GroceryStore>
    non-grocery store
    attraction
    transport
    public service
LIST

# TODO: add override options --from, --through and --theme
#my $globalfrom = DateTimeX::Easy->new('now');
# TODO: teach DTX::Easy / DT::F::Natural DT::F::Flexible words "current" and "present" (as alternatives to this)
my $globalfrom = DateTimeX::Easy->new('first day of this month');
# TODO: teach DTX::Easy / DT::F::Natural DT::F::Flexible these:
#  last day of month three months from now
#  last day of month in three months
#  last day of (the) month three months ahead
#  ... in the future
#  ... into the future
#  ... from now
#  ... later <- this last one for changing object, not create new
#my $globalthrough = DateTimeX::Easy->new('last day of month in 3 months');
my $globalthrough = DateTimeX::Easy->new($globalfrom);
$globalthrough->add( months => 4 )->subtract( days => 1 );

# TODO: add Getopt option --preset as shortcut to --category, --from and --through

my $parser = RDF::Trine::Parser::Turtle->new;
my $model = model();

# TODO: throw sensible error if no (non-opt) args provided
while (my $data = shift @ARGV) {
    try {
        parse($data, using => $parser, into => $model);
    } catch {
        say STDERR "Failed to parse file \"$data\": $_";
        die;
    }
}

# compose query for hourspec data at least partly within a "window" of time
# (yes, comparing global dates against opposite spec dates is deliberate)
my $w3c = DateTime::Format::W3CDTF->new;
my $query = qurie( sprintf(<<'SPARQL', $w3c->format_datetime($globalthrough), $w3c->format_datetime($globalfrom) ));
SELECT *
WHERE {
    {
        ?location
            a schema:Place ;
            gr:category ?category ;
            gr:name ?name ;
            gr:hasOpeningHourSpecification ?spec .
        ?spec
            gr:opens ?opens ;
            gr:closes ?closes ;
            rdfs:label ?speclabel ;
            gr:validFrom ?specfrom ;
            gr:validThrough ?specthrough .
        OPTIONAL { ?spec rdfs:comment ?speccomment } .
        OPTIONAL { ?location gr:description ?locationcomment } .
        FILTER ( ?specfrom <= "%s"^^xsd:dateTime ) .
        FILTER ( ?specthrough > "%s"^^xsd:dateTime )
    } UNION {
        ?location
            gr:category ?category ;
            gr:name ?name ;
            gr:hasOpeningHourSpecification ?spec .
        ?spec
            gr:opens ?opens ;
            gr:closes ?closes .
        OPTIONAL {
            ?spec
                rdfs:label ?speclabel ;
                gr:validFrom ?specfrom ;
                gr:validThrough ?specthrough .
        } .
        OPTIONAL { ?spec rdfs:comment ?speccomment } .
        OPTIONAL { ?location gr:description ?locationcomment } .
        FILTER (!bound(?specfrom)) .
        FILTER (!bound(?specthrough))
    }
}
SPARQL
# TODO: sort using SPARQL instead of perl
#    ORDER BY ?category ?name ?specfrom ?specthrough ?opens ?closes

my %data;
my $iterator = $query->execute($model);
while ( my $row = $iterator->next ) {
    my $category = $row->{category}->as_string;
    my $name = $row->{name}->literal_value;
    my $locationcomment = $row->{locationcomment} ? $row->{locationcomment}->literal_value : '';

    my $speclabel = $row->{speclabel} ? $row->{speclabel}->literal_value : '';

    # Strip surrounding quotes
    $category =~ s/^"(.*)"$/$1/;

    # merge identically named locations, tying varying descriptions to spec instead
#   my $name_key = titledescribe( $name, $locationcomment );
#   my $specbundle_key = $speclabel;
    my $name_key = $name;
    my $specbundle_key = titledescribe( $speclabel, $locationcomment );

    my $specfrom = $row->{specfrom} ? $row->{specfrom}->datetime : '';
    my $specthrough = $row->{specthrough} ? $row->{specthrough}->datetime : '';

    my $speccomment = $row->{speccomment} ? $row->{speccomment}->literal_value : '';

    # TODO: use DateTime objects instead.
    my $opens = $row->{opens}->literal_value;
    $opens =~ s/:\d\d$//;
    my $closes = $row->{closes}->literal_value;
    $closes =~ s/:\d\d$//;
    $closes =~ s/^23:59/24/;

    my @weekdays;
    my $iterator = $model->get_statements($row->{spec}, curie('gr_hasOpeningHoursDayOfWeek'), undef);
    while (my $statement = $iterator->next) {
        my $label = $statement->object;

        given ($label->as_string) {
            when (/Monday/) { push @weekdays, 1 };
            when (/Tuesday/) { push @weekdays, 2 };
            when (/Wednesday/) { push @weekdays, 3 };
            when (/Thursday/) { push @weekdays, 4 };
            when (/Friday/) { push @weekdays, 5 };
            when (/Saturday/) { push @weekdays, 6 };
            when (/Sunday/) { push @weekdays, 7 };
            when (/PublicHolidays/) { push @weekdays, 8 };
            default { die "failed to parse weekday: ", $label->as_string };
        }
    }
    my $weekdays = join ', ', sort @weekdays;
    $weekdays = 0 unless ($weekdays);
    my $weekdays_key = titledescribe( $weekdays, $speccomment );

    $data{$category}{$name_key}{name} = $name;
    $data{$category}{$name_key}{specbundle}{$specbundle_key}{locationcomment} = $locationcomment;
    $data{$category}{$name_key}{specbundle}{$specbundle_key}{speclabel} = $speclabel;
    $data{$category}{$name_key}{specbundle}{$specbundle_key}{specfrom} = $specfrom;
    $data{$category}{$name_key}{specbundle}{$specbundle_key}{specthrough} = $specthrough;
    $data{$category}{$name_key}{specbundle}{$specbundle_key}{spec}{$weekdays_key}{weekdays} = $weekdays;
    # TODO: extend SPARQL to cover specs without opens/closes, or drop below check
    if ($opens and $closes) {
        my $hours_key = $opens;
        $hours_key =~ s/\b(\d)\b/0$1/g;
        my $hourrange = "$opens - $closes";
        $data{$category}{$name_key}{specbundle}{$specbundle_key}{spec}{$weekdays_key}{hours}{$hours_key} = $hourrange;
        $data{$category}{$name_key}{specbundle}{$specbundle_key}{spec}{$weekdays_key}{speccomment} = $speccomment;
    }
}

my $title = 'Åbningstider';
my $intro = sprintf(
    'Åbningstider på Orø indenfor udvalgte kategorier, dækkende perioden %s.',
    daterangedescribe($globalfrom, $globalthrough),
);

# TODO: make simplified html (preferred for Scribus) optional
#push my @content, h1($title), "\n", p($intro);
push my @content, h1($title), "\n", $intro;

for my $category ( @category ) {
    push @content, "\n", h2( categorydescribe($category) ), "\n";
    for my $name ( sort keys %{ $data{$category} } ) {
        push @content, "\n", h3($name);
        my @bundle = keys %{ $data{$category}{$name}{specbundle} };
        # FIXME: respect locale when sorting (Galleri before Gaardstronomi)
        for my $specbundle ( sort {
            $data{$category}{$name}{specbundle}{$a}{specfrom}
            <=> $data{$category}{$name}{specbundle}{$b}{specfrom}
            || $a cmp $b
        } @bundle ) {
            # TODO: when global limits shown, show only speclabel plural spec bundles
            my $speclabel = speclabeldescribe(
                $data{$category}{$name}{specbundle}{$specbundle}{speclabel},
                $data{$category}{$name}{specbundle}{$specbundle}{locationcomment},
                $data{$category}{$name}{specbundle}{$specbundle}{specfrom},
                $data{$category}{$name}{specbundle}{$specbundle}{specthrough},
                scalar @bundle,
            );
            push @content, "\n", h4($speclabel) if ($speclabel);
            my @specbundle;
            for my $weekdays ( sort keys %{ $data{$category}{$name}{specbundle}{$specbundle}{spec} } ) {
                my $specdescription = specdescribe(
                    $data{$category}{$name}{specbundle}{$specbundle}{spec}{$weekdays}{weekdays},
                    $data{$category}{$name}{specbundle}{$specbundle}{spec}{$weekdays}{speccomment},
                );
                push @specbundle, br if (@specbundle);
                my @hours;
                for my $hours ( sort keys %{ $data{$category}{$name}{specbundle}{$specbundle}{spec}{$weekdays}{hours} } ) {
                    # TODO: make simplified html (preferred for Scribus) optional
#                   push @hours, br, "\n" if (@hours);
                    push @hours, br if (@hours);
                    push @hours, "\t", span(
                        $data{$category}{$name}{specbundle}{$specbundle}{spec}{$weekdays}{hours}{$hours}
                    );
                }
                push @specbundle, "\n", span(
                    span($specdescription, ":"), @hours,
                );
            }
            # TODO: make simplified html (preferred for Scribus) optional
#           push @content, p("\n", @specbundle) if (@specbundle);
            push @content, @specbundle if (@specbundle);
        }
    }
}

#Dumper %data;
#die;

my $writer = HTML::HTML5::Writer->new;
say $writer->document( html(
    -lang => 'da',
    head(
        title($title),
        Meta(-charset => 'utf-8'),
    ),
    body(
        "\n", @content
    ),
));

# create query object from curied SPARQL string
sub qurie {
    my $sparql = shift;
    $sparql =~ s/(?<=\s|\^)([a-z]+):([a-zA-Z]+)(?=\s)/curie("$1_$2")/eg;
    my $query = RDF::Query->new( $sparql );
    if (!$query) {
        say STDERR $sparql;
        say STDERR RDF::Query->error;
        croak "failed to prepare SPARQL query";
    }
    return $query;
}

sub daterangedescribe {
    my ($from, $through) = @_;

    return sprintf( '%s - %s',
        $from->format_cldr('d/M'),
        $through->format_cldr('d/M'),
    );
}

sub categorydescribe {
    my $cat = shift;

    $cat =~ s!<http://schema.org/FoodEstablishment>!spisesteder!;
    $cat =~ s!<http://schema.org/GroceryStore>!dagligvarebutikker!;
    $cat =~ s!non-grocery store!øvrige butikker!;
    $cat =~ s!attraction!attraktioner og museer!;
    $cat =~ s!public service!offentlige services!;

    return ucfirst($cat);
}

sub titledescribe {
    my ($title, $comment) = @_;

    return ($comment) ? "$title ($comment)" : $title;
}

sub speclabeldescribe {
    my ($label, $comment, $from, $through, $size) = @_;

    # TODO: support optionally enabling descriptive label
    my $compact = 1;

    return '' if ( ($compact) and ( $size == 1 ) );

    my $daterange =  daterangedescribe($from, $through);
    if (($from) and ($through)) {
        return titledescribe( $daterange, $comment )
            if ($compact);
        return $label, ' (', $daterange, ' - ', $comment, ')'
            if ($comment);
        return $label, ' (', $daterange, ')';
    }
    warn "gr:validFrom and gr:validThrough missing for label \"$label\"";
    return ($compact) ? '' : titledescribe( $label, $comment );
}

sub specdescribe {
    my ($weekdays, $comment) = @_;

    # TODO: translate properly
    $weekdays =~ s/1, 2, 3, 4, 5, 6, 7/alle ugedage/;
    $weekdays =~ s/1, 2, 3, 4, 5/mandag-fredag/;
    $weekdays =~ s/1, 2, 3, 4/mandag-torsdag/;
    $weekdays =~ s/2, 3, 4, 5, 6, 7/tirsdag-søndag/;
    $weekdays =~ s/3, 4, 5/onsdag-fredag/;
    $weekdays =~ s/^2, 3, 4(|, [^5].*)$/tirsdag-torsdag$1/;
    $weekdays =~ s/^(|.*?[\d^5], |.*?(?!fredag, ))6, 7(.*)$/$1weekend$2/;
    $weekdays =~ s/1/mandag/;
    $weekdays =~ s/2/tirsdag/;
    $weekdays =~ s/3/onsdag/;
    $weekdays =~ s/4/torsdag/;
    $weekdays =~ s/5/fredag/;
    $weekdays =~ s/6/lørdag/;
    $weekdays =~ s/7/søndag/;
    $weekdays =~ s/8/helligdage/;

    if ( $weekdays eq "0" and ($comment) ) {
        return $comment;
    }
    return titledescribe( $weekdays, $comment );
}

1;