#! /usr/bin/perl

# Copyright (C) 2006-2018 Arne Wichmann
#
# This little thing is distributed under the GNU General Public License,
# version 2. If you need the license, ask your distributor for it.

# There may be instances of german in the code, if you have problems
# understanding ask me (possibly after trying babelfish) -- aw@saar.de

# as it is, this program is quite curtailed to our specific circumstances.
# this can be remedied, and i may be willing to put a bit of time into that
# if you have suggestions. for example the weather code is written with
# middle europe in mind. it seems to be quite ok for western europe, too,
# but for everything else i do not have enough experience.

# TODO: config only for weather, improve documentation

# you need some datafile with this to make it usable. a minimal example
# would be:
# $VAR1 = [ { "wilderness-prob", [2,1],
#  "wilderness-day", [ 48, "wolves" ],
#  "wilderness-night", [ 1, "[wilderness-day]" ] }, 0, 
#  {"o",[5,20,0,16, 8,16,16],
#  "no",[0,20,0, 2, 1, 2, 3],
#  "so",[10,20,0,3, 3, 2, 2],
#  "n",[0,10,1,  2, 1, 3, 9],
#  "s",[25,10,0, 9,18, 2, 1],
#  "sw",[18,5,1,20,30,18, 9],
#  "w",[12,5,1, 30,30,30,30],
#  "nw",[4,5,1, 18, 9,27,30]},
#  [20,0]
# ];
#
# The format is Data::Dumper-like, and will be evaled by the program. 
#
# It contains a mostly unused encounter table (which I shifted into another
# tool - tableroller), a hook for local perl code which will be executed
# daily (use with caution, of course), a weather table, and a humidity
# array

# the encounter table is unused (TODO: check)

# the weather table should contain a table of weather types and definition
# arrays, where the definition array should have the following values: base
# temperature (average temperature over the year given this weather type),
# temperature amplitude (max difference to base temperature in
# summer/winter), humidity (0 - arid, 1 - humid), probability in spring,
# summer, autumn, winter

# the humidity array contains a die and a value which is substracted from
# the die - the higher the resulting value the dryer.

# the above example should fit to the upper rhine valley, germany

# I am aware that this description is not very good (at least not for
# people who cant write perl), but if you are prepared to help me in
# improving it, do not hesitate to ask.
#
# You can also ask me for datafiles.

# usage: $0 <day> <mon> <nrofdays> <lasttemp> <weathertype> <snowheight>
#   <datafile>
#
# <day> and <mon> are the beginning date
# <nrofdays> is the number of days to be rolled
# <lasttemp> is the average temperature of yesterday
# <weathertype> is (at the moment) the prevailing wind: (o - east)
#   n, no, o, so, s, sw, w, nw
# <snowheight> is the amount of snow in dm, round down
# <datafile> is a file with encounter probabilities and similar things

use strict;

use Date::Manip; # yearday
# use Math::Trig; # pi -> see below ;)

my($day)=shift()-1;
my($mon)=shift;
my($daycount)=shift()+1;

# wheather initialisation
my($temp)=shift;
my($type)=shift;
my($snow)=shift; # this is the amount of snow that is lying, in dm (approx)

# Initialisation, using a structure like Data::Dumper would generate
# using (hopefully, this is untested):
# my(@outdata)=($table);
# use Data::Dumper;
# $Data::Dumper::Indent=1;
# print Dumper \@outdata;
# exit 0;

# there is one special thing: you can put code you want to be called every
# day into $VAR1->[1] (which should be a code reference). This is made so
# that you can put code there that is specific to your campaign.

# $VAR1->[2] should contain the climate-data.
# $typeval=
# {"type",[average,yeardist,humid,springprob,summerprob,autprob,winterprob]}


our($VAR1);
for (@ARGV) { do "$_"; }
our($table)=$VAR1->[0];
our($localcode)=$VAR1->[1];
our($typeval)=$VAR1->[2];
our($rainfactor)=$VAR1->[3];


my($yearday)=Date_DayOfYear($mon,$day,2001);

while (--$daycount) {
  $day++; $yearday++;
  my($desc);
  ($temp,undef,undef,$desc,$type)=wetter($temp,$type);
  # approx of german dawn times 1.93==1:56~=Frankfurt, 1:43 Basel, 2:11
  # Hamburg
  # TODO: configure
  my($dawn)=6-sin(($yearday-79)/365*2*pi())*1.93;
  print "$day.$mon.:\n";
  print($desc." Sonnenaufgang um ".
    int($dawn).":".sprintf("%02d",int(($dawn-int($dawn))*60))."\n");
  $_=join("\n",rollday());
  print "$_\n" if $_;
  $localcode->() if ref($localcode) eq 'CODE';
  print "\n\n";
}

exit 0;

# gets momentary temperature, weather type (typically == Windrichtung)
sub wetter($$) {
  my($mom,$type)=@_;

  # weather tendencies tend to keep up for 10 days
  # TODO: this should vary according to a number of things
  if (d(10)==1) {
    $type=d(100);
    # seasons do not change strictly according to calendar. a bit of
    # variance is in order.
    my($fuzzy)=d(30);
    for (keys(%$typeval)) {
      # find out the season (spring/summer/autumn/winter) - increase by 3
      # as 0-2 in %$typeval are $av,$yd,$h - see below
      $type-=$$typeval{$_}[int(($yearday-79+$fuzzy-15)%365/92)+3];
      if ($type<1) {
        $type=$_;
	last;
      }
    }
    !$type or $type==0 or die "assertion failed: no weather found ($type)";
  }

  my($av,$yd,$h)=@{$$typeval{$type}};
  
  # average+-yeardist depending on day of year. if snow up to 20C colder.
  # humidity makes this less prominent
  my($dest)=$av+sin(($yearday-79)/365*2*pi())*$yd-((($snow<=>1)+1)*10/(1+$h));
  # inverse exponential density of a random number multiplied by 0.8
  # is (50%-chance) added or subtracted from yesterdays temperature
  # then we weigh in 10% of the dest temperature and round up or down
  my $newtemp=int((log(1-rand())*4/5*(2*d(2)-3)+$mom)*9/10+$dest/10+0.5);
  # the first factor is the size of the die -> if it is smaller the weather
  # changes less; the second factor is the overall humidity - if this is
  # above 0 rainstorms start appearing even if temperature does not change
  my($dry)=d($$rainfactor[0])+(1-$h)*6-$$rainfactor[1];
  $dry-=int($newtemp/2) if $newtemp<-1; # it seldomly snows if it is very cold
  warn "dry constraint failure" if ($dry<-2 and $h==0);

  # +4 wenn humid, +-4 je nach jahreszeit (max mitte November)
  # der nebelcode geht davon aus, daß die gruppe am wasser ist
  my($fog)=$h*4+int(sin(($yearday-240)/365*2*pi())*4+0.5);

  # if it gets too hot or too cool, more violent weatherchanges may occur
  if ($newtemp-$dest>17-rand(4)**2) {
    if ($h) { # Wolkenbruch/Gewitter
      $dry=-1;
      $newtemp-=int(1/2*(d(52)/10-2)**3+5);
    } else { # starker ostwind 
      $newtemp-=int(1/2*(d(42)/10-2)**3+4);
      $dry+=4;
      # wind -> kein nebel
      $fog-=4;
    }
  } elsif ($dest-$newtemp>17-rand(4)**2) {
    if ($h) { # Wolkenbruch/Gewitter
      $dry=-1;
      $newtemp-=int(1/2*(d(52)/10-2)**3+5)-7;
    } else { # klarer, fast windstiller Tag
      $dry+=2;
    }
  }
  
  my($dist)=(d(24)+$dry)/2;
  # -3 -2 -2 -1 -1 -1 0 0 0 0 0 0  0 0 0 0 0 0 1 1 1 2 2 3
  $dist=9+int((12.5-$dist)**2/40)*($dist<=>12);
  my $min=$newtemp-int($dist/2);
  my $max=$newtemp+int($dist/2+0.5);

  # precipitation
  my($dryname);
  my($gewitter)=0; # for wind
  my($oldsnow)=$snow;
  if ($dry<1) {
    $dryname=(($min>0)?"Gewitter":"Schneesturm")." (".gewitterzeit().")";
    # number of gewitter returned
    $gewitter=$dryname;
    $gewitter=~s/[^,]//g;
    $gewitter=length($gewitter)+1;
    $snow+=d(2) if $min<=0;
    $snow+=d(2) if $max<=1;
  } elsif ($dry<8) {
    $dryname="Regen";
    $dryname="Schneeregen" if $min<0;
    $dryname="Schnee" if $min<0 and $max<3;
    $snow+=1 if $min<0 and $max<3;
    $snow+=1 if $max<1;
  } elsif ($dry<14) {
    $dryname="Wechselnd";
    $snow+=d(2)-1 if $min<0 and $max<3;
    $snow+=d(2)-1 if $max<1;
  } else {
    $dryname="Trocken";
  }

  # falling snow raises temperature
  if ($oldsnow<$snow) {
    $newtemp+=int(($snow-$oldsnow)/2);
    $dist++ if ($snow-$oldsnow)%2;
    $min=$newtemp-int($dist/2);
    $max=$newtemp+int($dist/2+0.5);
  }

  # snow might melt, which lowers temperature
  my($newsnow)=$snow;
  $newsnow-=int($max/2) if $max>1;
  $newsnow-=int($max/4) if $max>3;
  $newsnow=0 if $newsnow<0;
  if ($newsnow<$snow) {
    $max-=$snow-$newsnow;
    $newtemp=int(($min+$max)/2);
    $dist-=$snow-$newsnow;
    # TODO: report melting snow
    $snow=$newsnow;
  }

  # fog ist die anzahl der nebelwachen (1 wache 4h)
  # zwischen +-4 je nach windrichtung
  $fog+=2 if $type=~/n/;
  $fog+=2 if $type eq 'n';
  $fog-=2 if $type=~/s/;
  $fog-=2 if $type eq 's';
  # temperatur sollte sinken (boden wärmer als luft - nur näherung zusammen
  # mit obigem)
  $fog-=$newtemp-$mom;
  # wenn es wirklich kalt ist ist nebel unwahrscheinlich
  $fog+=$newtemp/2 if $newtemp<-1;
  # starker regen/schnee wäscht nebel weg
  $fog-=2*(8-$dry) if $dry<8;
  # starke sonne verdunstet nebel
  $fog-=$max/2-8 if $max>16;
  # bei starker temperatursenkung ist wind wahrscheinlich
  # siehe auch ~8 zeilen höher -> das hier ist recht rohbehauen
  $fog-=abs($mom-$newtemp)-2 if $newtemp-$mom<1;
  # bei 12 sollte 75% der zeit ganztägig nebel sein (d.h. fog>4)
  $fog-=d(12)-1;
  $fog=int($fog);

  ### Wind
  # TODO: konfigurierbar machen
  # ausgegebener wind -> küste. auf offener see +2, im inland (>70km) -2,
  # nahe küste (15-70km) -1
  # wald (am boden) -2, hügeltal>100m -1, mittelgebirgstal>700m -2
  # bei windeschwindigkeiten <=3 wird nur je 0.5 abgezogen. abrunden.

  # - windrichtung, grundwerte - base = durchschnitt, var = max abweichung
  # TODO: konfigurierbar machen
  my %windbase=("s",2,"so",2,"o",3,"no",4,"n",4,"nw",6,"w",5,"sw",4);
  my %windvar=("s",3,"so",3,"o",3,"no",3,"n",4,"nw",6,"w",6,"sw",6);

  my $base=$windbase{$type};
  my $var=$windvar{$type};

  # Am Rande (±15d) der Jareszeiten variiert der Wind täglich zwischen den
  # beiden Jahreszeiten
  my $season=int(($yearday-79+d(30)-15)%365/92);

  # jahreszeitliche anpassungen
  # TODO: konfigurierbar machen
  unless ($season) {
    $base+=2 if $type eq "nw";
    $var-=2 if $type eq "nw";
    $base-- if $type eq "n";
  } elsif ($season==1) { $base-=2; }
  elsif ($season==2) {
    $var+=2 if $type eq "s";
    $base-=2 if $type eq "no";
    $var+=2 if $type eq "no";
  } elsif ($season==3) {
    $var+=2;
    $base++ if $type eq "no";
    $var-=4 if $type eq "nw";
  }

  # temperaturaenderung
  $base+=int(abs($mom-$newtemp)/2)-1;
  $var+=int(abs($mom-$newtemp)/2)-1;

  # nebel und gewitter
  # $flags='' unless defined($flags);
  # my($nebel,$gewitter,$modifier)=(0,0);
  # if ($flags=~/n(\d*)/) { $nebel=($1||1); }
  # if ($flags=~/g(\d*)/) { $gewitter=($1||1); }
  # if ($flags=~/m(\d*)/) { $modifier=($1||1); }

  # nebel im frühling und sommer der mit windstille einher geht löst sich
  # meist am morgen wieder auf
  $fog=0 if $fog<0;
  if ($base<$fog and $season<2 and $fog>2) { $fog=$base-1; }
  $base-=$fog;
  $var+=$fog;

  my $cut;
  # Wenn mehr als 12bf gewürfelt werden kann wird der würfel verkleinert
  if (($cut=$base+$var-12)>0) { $var-=$cut; }
  # Wenn weniger als 0bf gewürfelt werden kann wird der würfel verkleinert
  # Das funktioniert nicht gut - besser auf den Reroll unten verlassen.
  # if (($cut=$var-$base)>0) {
  #    $var-=$cut;
  #  if ($base>0) { $var-=$cut; }
  #  else {
  #    $base=$var+$base;
  #    $var=int($base/2);
  #    $base=int($base/2+0.5);
  #  }
  # }
  $var=0 if $var<0;

  # Gewitter -> mehr Wind
  $base+=2 if $gewitter;
  $var+=2*$gewitter-2 if $gewitter>1;

  # print("# b $base, v $var\n");

  # ab hier berechnung der (finalen) windstaerke in $base, $var -> varianz
  $base-=$var+1;
  $var*=2;
  $base=$base+int((d($var+1)+d($var+1))/2);
  # 0bf ist selten an der Küste
  $base=$base+int((d($var+1)+d($var+1))/2) if $base<=0;

  # $base-=$modifier;
  # if ($base<3 and $modifier>$base) {
  #   $modifier=2 if $modifier>2;
  #   $base=int(($base+$modifier+1)/2);
    $base=0 if $base<0;
  # }

  $base=12 if $base>12; # TODO: extreme weather

  # $var & $base fertig
  my @beaufort=("Windstille","leiser Zug","leichte Brise","schwache Brise",
    "maessige Brise","frische Brise","starker Wind","steifer Wind",
    "stuermischer Wind","Sturm","schwerer Sturm","orkanartiger Sturm",
    "Orkan");

  # ergebnis: ($beaufort[$base]."($base)");


  # Nebel verringert Tag/Nacht-Temperaturabstand
  $dist-- if $fog>1; $dist-- if $fog>4;
  $min=$newtemp-int($dist/2);
  $max=$newtemp+int($dist/2+0.5);


# TODO: Nebel debuggen
  return ($newtemp, $min, $max ,
    $dryname.($snow>0?" ".$snow."0cm Schnee ":"").($fog>0?" Nebel($fog)":"").
      ", ".$beaufort[$base]."($base) aus $type, $min - ".$max,$type);
}

# returns daytime of thunderstorms
sub gewitterzeit() {
  my($when)=d(72)-1;
  if ($when>63) { # multiple thunderstorms on one of 9 days
    return gewitterzeit().", ".gewitterzeit();
  }
  $when-=24 if $when>47; # most thunderstorma are in the afternoon
  my($odd)=($when%2?"30":"00");
  return int($when/2).":$odd";
}

# gets environment, dawntime (both for compatibility only)
sub rollday() {
  my(@enctimes);
  # one roll for encounters for every 4 hours. rerolled if successful.
  # success chance is 15/20, the rolled value is noted. in case of rerolls
  # the noted value is set to the smallest rolled value so far. after this
  # a more precise time is rolled (precision is half-hours), the list of
  # encounters is sorted by time.

  # TODO: maybe list the environments the encounter is valid for
  for my $base (0,4,8,12,16,20) {
    my($min)=20;
    while ($min=encounterp($min)) {
      # TODO: 20% WK auf gleichzeitige ereignisse
      push (@enctimes,($base+d(8)/2).": $min");
  } }

  return sort {
    abs([split(":",$a)]->[0])<=>abs([split(":",$b)]->[0])
  } @enctimes;
}

# gets basetime and max possible value
# gives: 0 if no encounter, else value
sub encounterp($$) { 
  my($min)=@_;
  my($res)=d(20);
  return 0 if $res<15;
  
  # return ($base+d(8)/2)*($res>$table->{$env.'-prob'}->[1]?-1:1);
  return $res>$min?$min:$res;
}

# rolls a die.
# gets size of the die; or number of dies and size of one die
# returns rolled value
sub d($;$) {
    my($num)=($#_?shift:1);
    my($size)=shift;
    my($res)=0;
    for(1..$num) {
        $res+=int(rand($size))+1;
    }
    return $res;
}

sub pi() { 3.14159265358979; }