lamperi
/
pna


			
				
					
						
						
							123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473
							#!/usr/bin/env perl

# Ruokalistaparseri v1.5.4
# Copyright (c) 2007-2010 Timo Sirainen
#               2011-2013 Toni Fadjukoff
# This is Public Domain

use strict;
use POSIX qw(strftime mktime);
use HTML::TokeParser;
use HTML::Entities;

use vars qw(@day_names);
@day_names = ( "Maanantai", "Tiistai", "Keskiviikko", "Torstai", 
	       "Perjantai", "Lauantai", "Sunnuntai" );

require 'amica.pl';
require 'sodexo.pl';
require 'juvenes.pl';
require 'pky.pl';

my @allergies = ( "M", "L", "VL", "G", "K", "Ve" );
my %allergy_descriptions = (
  "M" => "Maidoton",
  "L" => "Laktoositon",
  "VL" => "Vähälaktoosinen",
  "G" => "Gluteiiniton",
  "K" => "Kasvis",
  "Ve" => "Vegaani"
);

my $global_prefix = "";
my $use_old = 0; # 1 is good for testing, 0 for production system!
my @unordered;

my @l = localtime;
my $this_week = strftime("%V", @l);

push @unordered, get_juvenes_restaurants($use_old);
push @unordered, get_amica_restaurant($use_old);
push @unordered, get_sodexo_restaurants($use_old);
push @unordered, get_pky_restaurants($use_old, $l[6] == 0 || $l[6] == 6);

my $max_week = 0;
foreach my $r (@unordered) {
  my $week = @{$r}[2];
  $max_week = $week if ($week > $max_week || $week == 1);
}

if ($l[6] != 0 && $this_week != $max_week) {
  # it's not sunday, don't force next week's menu yet
  $max_week = $this_week;
}

my $stamp = time() - 3600*24*7;
my $max_week_daterange = "";
if ($max_week >= 1 && $max_week <= 52) {
  # figure out the date range
  for (;;) {
    my $stamp_week = strftime("%V", localtime($stamp));
    last if ($stamp_week == $max_week);
    $stamp += 3600*24;
  }
  my @l1 = localtime($stamp);
  my @l2 = localtime($stamp + 3600*24*6);
  if ($l1[4] == $l2[4]) {
    # same month
    $max_week_daterange = $l1[3]."-".$l2[3].".".($l1[4]+1).".";
  } else {
    # different months
    $max_week_daterange = $l1[3].".".($l1[4]+1)."-".$l2[3].".".($l2[4]+1).".";
  }
  $max_week_daterange = " ($max_week_daterange)"
}

my $file_header = '<?xml version="1.0" encoding="iso-8859-1"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="fi" lang="fi">
<head>
  <title>Ruokalistat</title>
  <link rel="stylesheet" type="text/css" href="'.$global_prefix.'/ruoka.css" />
</head>
<body>

<div id="notice" style="border: 1px solid black; border-radius: 5px; padding: 5px;">
PNA.fi on kolmannen osapuolen tarjoama palvelu. En voi taata ruokalistojen oikeellisuutta.  Virallisen ruokalistan saat näkyviin siirtymällä ravintolan omille sivuille painamalla sen nimestä. Jos huomaat ruokalistassa virheen, nopeiten virhe saadaan pois näkyvistä kun lähetät minulle siitä sähköpostia: <a href="mailto:lamperi+pna@gmail.com">lamperi+pna@gmail.com</a>
</div>

<form method="get" action="/cgi-bin/food.cgi">
';
my $file_footer = "<div class=\"footer\">Päivitetty ".
    strftime("%d.%m.%Y %H:%M:%S", localtime).
    " <input type=\"submit\" value=\"Päivitä nyt\" />".
    " / Palaute <a href=\"mailto:lamperi+pna\@gmail.com\">lamperi+pna\@gmail.com</a>".
    " / <a href=\"$global_prefix/code.html\">Koodit täältä</a>".
    " / <a href=\"$global_prefix/pna.html\">Mikä on PNA?</a>".
    "</div>\n</form>\n</body></html>\n";

sub find_last_day_with_foods {
  my $restaurants_ref = shift;

  my $last_day = 0;
  foreach my $r (@${restaurants_ref}) {
    my ($title, $open_hours, $week, $week_foods_ref) = @{$r};
    my @week_foods = @{$week_foods_ref};
    for (my $day = 0; $day < 7; $day++) {
      if (defined($week_foods[$day])) {
	$last_day = $day if ($day > $last_day);
      }
    }
  }
  return $last_day;
}

sub write_days_header {
  my ($fout, $day, $last_day) = @_;
  
  print $fout "  <span class=\"days\">";
  for (my $i = 0; $i <= $last_day; $i++) {
    if ($i == $day) {
      print $fout $day_names[$i]." ";
    } else {
      print $fout "<a href=\"".($i+1).".html\">".$day_names[$i]."</a> ";
    }
  }
  if ($day < 0) {
    print $fout "Taulukko";
  } else {
    print $fout "<a href=\"table.html\">Taulukko</a>";
  }
  print $fout "</span>\n";
}

sub write_prefix_header {
  my ($fout, $prefix, $day) = @_;
  
  $day = "table" if ($day == 0);
  print $fout "<span class=\"location\">";
  if ($prefix eq "") {
    print $fout "Kaikki ";
  } else {
    print $fout "<a href=\"$global_prefix/$day.html\">Kaikki</a> ";
  }
  if ($prefix eq "tay/") {
    print $fout "TaY ";
  } else {
    print $fout "<a href=\"$global_prefix/tay/$day.html\">TaY</a> ";
  }
  if ($prefix eq "tays/") {
    print $fout "TAYS ";
  } else {
    print $fout "<a href=\"$global_prefix/tays/$day.html\">TAYS</a> ";
  }
  if ($prefix eq "tty/") {
    print $fout "TTY ";
  } else {
    print $fout "<a href=\"$global_prefix/tty/$day.html\">TTY</a> ";
  }
  print $fout "</span>\n";
}

sub write_day {
  my ($day, $header, $outfname, $last_day, $restaurants_ref, $prefix) = @_;
  my @restaurants = @{$restaurants_ref};

  open(my $fout, ">$outfname") || die ("Can't create file $outfname");
  print $fout "$file_header<h1>$header</h1>\n";
  # print weekday links
  print $fout "<div class=\"title\">\n";
  write_days_header($fout, $day, $last_day);
  print $fout "  <span class=\"allergy\">Näytä: ";
  foreach my $a (@allergies) {
    print $fout "<input type=\"checkbox\" name=\"allergy_$a\" id=\"allergy_$a\" onclick=\"highlight()\" />";
    print $fout "<span title=\"".$allergy_descriptions{$a}."\">$a</span>";
  }
  print $fout "</span>\n";
  write_prefix_header($fout, $prefix, $day+1);
  print $fout "</div>\n";

  # print foods
  my $foodnum = 0;
  my %eatable_food_numbers;
  my %maybe_eatable_food_numbers;
  my $class = "left";
  print $fout "<div class=\"foods\"><div class=\"$class\">\n";
  foreach my $r (@restaurants) {
    my ($title, $open_hours, $week, $week_foods_ref, $info_ref) = @{$r};
    my ($title2, $url, $lazy_allergies, $info_class) = @{$info_ref};
    my @week_foods = @{$week_foods_ref};
    if (defined($week_foods[$day]) || $day < 5) {
      # Bio+Kliininen often have the same foods
      next if (try_merge_bio_kliininen(\$title, $day));

      if ($info_class ne $class) {
	$class = $info_class;
	print $fout "</div><div class=\"$class\">\n";
      }
      $url =~ s/&/&amp;/g;
      print $fout "<h2><a href=\"$url\">$title</a></h2>\n";
      
      if (!defined($week_foods[$day])) {
	print $fout "<p class=\"missing\">Ruokalistaa ei saatavilla.</p>";
	next;
      }
      if ($week ne "" && $week != $max_week) {
	if ($week > $max_week || ($week == 1 && $max_week == 52)) {
	  # early..
	  print $fout "<p class=\"nextweek\">Viikon $week ruokalista:</p>";
	} else {
	  print $fout "<p class=\"missing\">Saatavilla vain viikon $week ruokalista.</p>";
	  next;
	}
      }
      if (scalar(@{$week_foods[$day]}) == 0) {
	print $fout "<p class=\"missing\">Ei ruokatietoja päivälle.</p>";
	next;
      }
      
      print $fout "<ul class=\"food\">\n";
      foreach my $food (@{$week_foods[$day]}) {
	my $output = "";
	my %total_allergies;
	my %maybe_allergies;
	my $part_count = 0;
	foreach my $part (split("\n", $food)) {
	  next if ($part =~ /^(Peruna|Riisi) /); # who cares?
	  # fries: well, maybe we do care, but we don't care about allergy stuff
	  # and keep it in the same line as the previous food so as not to
	  # waste visible space
	  my $fries = ($part =~ /^(Tikkuperunat|Ranskalaiset perunat)/);
	  $part_count++;
	  
	  # add missing () around allergies
	  $part =~ s/ (([MLGK]|VL|Ve|Veg|Hot)(,([MLGK]|VL|Ve|Veg|Hot|))+)$/ ($1)/;
	  
	  if ($part =~ /^(.*) \(([^\)]+)\)$/) {
	    # fix allergy issues
	    my ($food, $allergy) = ($1, $2);
	    # standardization
	    $allergy =~ s/Kasvis/K/g;
	    $allergy =~ s/([MLGK]|VL)([MLGK]|VL)/$1,$2/g;
	    # spaces to commas
	    $allergy =~ s/saatavana[: ]+(.*)$/eriks: $1/;
	    $allergy =~ s/ +/,/g;
	    # remove double commas
	    $allergy =~ s/,+/,/g;
	    # eriks: standardization
	    $allergy =~ s/,?eriks:,?/, eriks: /g;
	    # remove extra commas/spaces from beginning/end
	    $allergy =~ s/^[, ]+//;
	    $allergy =~ s/[, ]+$//;
	    $part = "$food ($allergy)";
	  }
	  
	  $output .= "<br />\n" if ($output ne "" && !$fries);
	  if ($part =~ /Saatavana myös: (.*)/) {
	    # standardize allergy stuff
	    my $alt = $1;
	    $alt =~ s/^\((.*)\)$/$1/;
	    $alt =~ s/[, ]+/,/g;
	    $alt =~ s/^,+//;
	    $alt =~ s/,+$//;
	    $part =~ s/\)[- ]*Saatavana myös:.*/, eriks: $alt)/;
	    $part =~ s/[- ]*Saatavana myös:.*/ (eriks: $alt)/;
	  }
	  if ($part =~ /^(.*)(\([^\)]+\))$/) {
	    my ($text, $allergy) = ($1, $2);
	    if ($fries) {
	      $output .= ", $text";
	    } else {
	      $output .= "$text <span class=\"allergy\">$allergy</span>";
	    }
	    $allergy =~ s/^\((.*)\)$/$1/;
	    $allergy =~ s/ *eriks: //;
	    my %this_allergies;
	    foreach my $a (split(/[, ]/, $allergy)) {
	      foreach my $al (@allergies) {
		if ($a eq $al) {
		  $this_allergies{$a} = 1;
		  last;
		}
	      }
	    }
	    # is M=L always correct? not at least in all restaurants..
	    #$this_allergies{"L"} = 1 if ($this_allergies{"M"});
	    $this_allergies{"VL"} = 1 if ($this_allergies{"L"});
	    foreach my $a (keys %this_allergies) {
	      $total_allergies{$a}++;
	      $maybe_allergies{$a}++;
	    }
	    if ($lazy_allergies =~ /M/) {
	      # L might mean M
	      if ($this_allergies{"L"} && !$this_allergies{"M"}) {
		$maybe_allergies{"M"}++;
	      }
	    }
	  } else {
	    if ($lazy_allergies eq "all") {
	      # no allergy info, make everything maybe
	      foreach my $a (@allergies) {
		$maybe_allergies{$a}++;
	      }
	    }
	    $output .= $part;
	  }
	}
	my $allergy_output = "";
	foreach my $a (@allergies) {
	  if ($total_allergies{$a} == $part_count) {
	    if (!defined($eatable_food_numbers{$a})) {
	      $eatable_food_numbers{$a} = "";
	    } else {
	      $eatable_food_numbers{$a} .= ",";
	    }
	    $eatable_food_numbers{$a} .= $foodnum;
	  } elsif ($maybe_allergies{$a} == $part_count) {
	    if (!defined($maybe_eatable_food_numbers{$a})) {
	      $maybe_eatable_food_numbers{$a} = "";
	    } else {
	      $maybe_eatable_food_numbers{$a} .= ",";
	    }
	    $maybe_eatable_food_numbers{$a} .= $foodnum;
	  }
	}
	print $fout "  <li id=\"f$foodnum\">$output</li>\n";
	$foodnum++;
      }
      print $fout "</ul>\n";
    }
  }
  # write allergy scripts
  print $fout '<script type="text/javascript" src="'.$global_prefix.'/ruoka.js"></script>';
  print $fout '<script type="text/javascript">';
  print $fout "var eatable_foods = [];";
  print $fout "var maybe_eatable_foods = [];";
  foreach my $a (@allergies) {
    print $fout "eatable_foods[\"$a\"] = [".$eatable_food_numbers{$a}."];\n";
    print $fout "maybe_eatable_foods[\"$a\"] = [".$maybe_eatable_food_numbers{$a}."];\n";
  }
  my @allergy_strings = map('"'.$_.'"', @allergies);
  print $fout "var allergies = [".join(",", @allergy_strings)."];\n";
  print $fout "var food_count = $foodnum\n";
  print $fout "window.onload = function() { set_allergies(); show_warning(); };\n";
  print $fout "</script>\n";

  print $fout "</div></div>$file_footer";
  close $fout;
}

sub write_all_days {
  my ($restaurants_ref, $prefix, $title) = @_;
  my $last_day = find_last_day_with_foods($restaurants_ref);
  
  for (my $day = 0; $day < 7; $day++) {
    my $outfname = $prefix.($day+1).".html";
    if ($day > $last_day) {
      unlink($outfname);
      next;
    }
    my $header = $day_names[$day]." - $title vko $max_week$max_week_daterange";
    write_day($day, $header, $outfname, $last_day, $restaurants_ref, $prefix);
  }
}

sub write_table {
  my ($restaurants_ref, $prefix, $title) = @_;
  my @restaurants = @{$restaurants_ref};
  my $last_day = find_last_day_with_foods($restaurants_ref);

  my $outfname = $prefix."table.html";
  open(my $fout, ">$outfname") || die ("Can't create file $outfname");
  my $header = "$title vko $max_week$max_week_daterange";
  print $fout "$file_header<h1>$header</h1>\n";
  print $fout "<div class=\"title\">\n";
  write_days_header($fout, -1, $last_day);
  write_prefix_header($fout, $prefix, 0);
  print $fout "</div><table border=\"1\"><tr><th>Päivä</th>";
  foreach my $r (@restaurants) {
    my ($title, $open_hours, $week, $week_foods_ref, $info_ref) = @{$r};
    my ($title2, $url) = @{$info_ref};
    $url =~ s/&/&nbsp;/g;
    print $fout "<th><a href=\"$url\">$title</a></th>";
  }
  print $fout "</tr>\n";
  for (my $day = 0; $day <= $last_day; $day++) {
    print $fout "<tr><td>".$day_names[$day]."</td>\n";
    foreach my $r (@restaurants) {
      my ($title, $open_hours, $week, $week_foods_ref, $info_ref) = @{$r};
      my @week_foods = @{$week_foods_ref};
      if (defined($week_foods[$day]) && ($week eq "" || $week == $max_week)) {
	print $fout "<td><ul>\n";
	foreach my $food (@{$week_foods[$day]}) {
	  print $fout "<li>$food</li>";
	}
	print $fout "</ul></td>\n";
      } else {
	print $fout "<td></td>\n";
      }
    }
    print $fout "</tr>\n";
  }
  print $fout "</table>$file_footer";
  close $fout;
}

sub get_restaurants_sorted {
  my @restaurants = @_;
  my @out;
  foreach my $r (@restaurants) {
    push @out, $r if (@{@{$r}[4]}[3] eq "left");
  }
  foreach my $r (@restaurants) {
    push @out, $r if (@{@{$r}[4]}[3] eq "right");
  }
  foreach my $r (@restaurants) {
    my @e = @{@{$r}[4]};
    push @out, $r if ($e[3] eq "middle" && $e[1] !~ /TAMK/);
  }
  foreach my $r (@restaurants) {
    my @e = @{@{$r}[4]};
    push @out, $r if ($e[3] eq "middle" && $e[1] =~ /TAMK/);
  }
  return @out;
}

sub get_restaurants_with_prefix {
  my $prefix = shift;
  my @out;
  foreach my $r (@_) {
    my $name = @{$r}[0];
    if ($name =~ /^\($prefix\)/) {
      push @out, $r;
    }
  }
  return get_restaurants_sorted(@out);
}

my $tty_title = "TTY:n ruokalistat";
my @tty = get_restaurants_with_prefix("TTY", @unordered);
write_all_days(\@tty, "tty/", $tty_title);
write_table(\@tty, "tty/", $tty_title);

my $tay_title = "Tampereen yliopiston ruokalistat";
my @tay = get_restaurants_with_prefix("TaY", @unordered);
write_all_days(\@tay, "tay/", $tay_title);
write_table(\@tay, "tay/", $tay_title);

my $tays_title = "TAYS:n ruokalistat";
my @tays = get_restaurants_with_prefix("TAYS", @unordered);
write_all_days(\@tays, "tays/", $tays_title);
write_table(\@tays, "tays/", $tays_title);

foreach my $r (@unordered) {
  if (@{$r}[0] =~ /^\(TaY\)/) {
    @{@{$r}[4]}[3] = "left";
  }
  if (@{$r}[0] =~ /^\(TTY\)/) {
    @{@{$r}[4]}[3] = "right";
  }
  if (@{$r}[0] =~ /^\(TAYS\)/) {
    @{@{$r}[4]}[3] = "middle";
  }
}

my $all_title = "Tampereen yliopistojen ruokalistat";
my @all_restaurants = get_restaurants_sorted(@unordered);
# move fusion kitchen last
my @fusion = splice(@all_restaurants, 1, 1);
splice(@all_restaurants, 4, 0, @fusion);

write_all_days(\@all_restaurants, "", $all_title);
write_table(\@all_restaurants, "", $all_title);