#! /usr/bin/perl

# Copyright (C) 2006 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@linux.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.

# you need some datafile with this to make it usable. a minimal example
# would be:
# $VAR1 = [ { "wilderness-prob", [2,1],
#  "wilderness-day", [ 48, "tracks: [wilderness-day]", 12, "local humans",
#    3, "wolves" ],
#  "wilderness-night", [ 1, "[wilderness-day]" ] } ];
#
# The format is Data::Dumper-like, and will be evaled by the program. 
# It contains (primarily) encounter tables. An encounter table has a name
# and consists of 3 parts. The name of the table above is "wilderness", and
# I will use this name in my explanations.
#
# The first part, wilderness-prob, contains the probability of an encounter
# occurring during 4 given hours, during day and night, respectively. It is
# given in rolls on a d20 (or in other words, in multiples of 5%). [2,1]
# means 10% chance during 4 hours of day and 5% chance during 4 hours of
# night.
#
# The second part, wilderness-day, contains weights and names of
# encounters during the day. A die of a size of the sum of all weights will
# be rolled to choose the resulting encounter. 12, "local humans", for
# example means that "local humans" will appear with a weight of 12. In the
# case of things in square brackets the table given in the square brackets
# will be rolled and the result will be put into the given place.
#
# The third part wilderness-night, is like the second, only for encounters
# during the night.
#
# 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
  my($dawn)=6-sin(($yearday-79)/365*2*pi())*2.1666;
  print "$day.$mon.:\n";
  print($desc." Sonnenaufgang um ".
    int($dawn).":".sprintf("%02d",int(($dawn-int($dawn))*60))."\n");
  $_=join("\n",rollday("wildnis",$dawn));
  print "$_\n" if $_;
  # print join("\n",rollday("fluß",$dawn)), "\n";
  $localcode->() if ref($localcode) eq 'CODE';
  print "\n\n";
}

exit 0;

# gets momentary temperature, weather type
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);
    for (keys(%$typeval)) {
      # find out the season (spring/summer/autumn/winter)
      $type-=$$typeval{$_}[int(($yearday-79+d(30)-15)%365/92)+3];
      if ($type<1) {
        $type=$_;
	last;
      }
    }
    !$type || $type==0 || die "assertion failed: no weather found";
  }

  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);
  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);

  # 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
    }
  } 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($oldsnow)=$snow;
  if ($dry<1) {
    $dryname=(($min>0)?"Gewitter":"Schneesturm")." (".gewitterzeit().")";
    $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;
  }

# Todo: Wind ausgeben
# Todo: Nebel?
  return ($newtemp, $min, $max ,
    $dryname.($snow>0?" ".$snow."0cm Schnee ":"")." Wind: $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 momentary temperature, destination temperature
# obsolete. delete this ;)
sub herbstwetter($$) { # this is very crude. it should deal with different times
  # in the year and their influences, and be a much better approximation of
  # reality
  my($mom,$dest)=@_;
  my($dry)=d(20);
  my($dist)=d(24);
  # -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=6+int((12.5-$dist)**2/40)*($dist<=>12)+
    # -4 -3 -3 -2 -2 -1 -1 0 0 0 0 0 0 1 1 2 2 3 3 4
    int((abs(10.5-$dry)-1)/2)*($dry<=>10);
  my($dryname)="Regen";
  $dryname="Wechselnd" if $dry>8;
  $dryname="Trocken" if $dry>16;
  # -2 -1 -1 -1 0 0 0 0 0 0  0 0 0 0 0 0 1 1 1 2
  my $drychange=int((10.5-$dry)**2/40)*($dry<=>10);
  # 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)+
    $drychange;
  # 1-2 bis mittag, ab 3 ganz - nachoptimieren
  my $fog=($mom-$newtemp)*2+$drychange+d(2);
  $dist-- if $fog>0; $dist-- if $fog>2;
  my $fogname=", Nebel bis Mittag" if $fog>0; $fogname=", Nebel" if $fog>2;
  my $min=$newtemp-int($dist/2);
  my $max=$newtemp+int($dist/2+0.5);
  return ($newtemp, $min, $max , $dryname.$fogname." ".$min."-".$max);
}

# gets environment, dawntime
sub rollday($$) {
  my($env)=shift;
  my($dawn)=shift;
  my(@enctimes,$i);
  while ($i=encounterp(0,$env)) {push (@enctimes,$i); }
  while ($i=encounterp(4,$env)) {push (@enctimes,$i); }
  while ($i=encounterp(8,$env)) {push (@enctimes,$i); }
  while ($i=encounterp(12,$env)) {push (@enctimes,$i); }
  while ($i=encounterp(16,$env)) {push (@enctimes,$i); }
  while ($i=encounterp(20,$env)) {push (@enctimes,$i); }

  @enctimes=sort {abs($a)<=>abs($b)} @enctimes;

  my(@encounter);
  for (@enctimes) {
     (-$_>$dawn && -$_<24-$dawn)?($_=-$_):next if $_<0; # daytime encounters

     my($day)=($_>$dawn && $_<24-$dawn)?"-day":"-night";
     push (@encounter,$_.": ".rolltable(@{$table->{$env.$day}}));
  }

  return @encounter;
  
}

# gets basetime and environment
# gives: 0 if no encounter, time if encounter, -time if encounter only if
#   it is day
# BUG: this only makes sense if probability during day is not lower than
#   during night
sub encounterp($$) { 
  my($base,$env)=@_;
  my($res)=d(20);
  return 0 if $res>$table->{$env.'-prob'}->[0];
  return ($base+d(8)/2)*($res>$table->{$env.'-prob'}->[1]?-1:1);
}

# gets array with weights and values
# gives rolled value
# BUG: if values do not make sense this enters endless loop
sub rolltable(@) {
  my($nr)=d(sumtable(@_));
  while (($nr-=shift)>0) { shift; }
  while ($_[0]=~/\[([^\]]+)\]/) {
    my($res)=rolltable(@{$table->{$1}});
    $_[0]=~s/\[([^\]]+)\]/$res/;
  }
  return $_[0];
}

# gets array with weights and values
# gives sum of weights
sub sumtable(@) {
  my($nr)=0;
  while (@_) { $nr+=shift; shift; }
  return $nr;
}

# 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; }