#!/bin/perl -w

# Module to decode CLIMAT.
#
# Author
#   W. M. Connolley 
#   wmc@bas.ac.uk / http://www.nbs.ac.uk/icd/wmc
#
# 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 2
# of the License, 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.
# http://www.gnu.org/copyleft/gpl.html
#
# Useful methods:
#
# new - create new CLIMAT object
# set_message(ref-to-string) - setup the message to decode
# decode - decode
# as_text - output as a text string
#
# upgrades:
#
# 2000/09/08:  fix problems with detecting old-style messages
#              change line to $message =~ /^(\d{5}) (\d{5}) ([\d\/]{4}) ([\d\/]{4}) ([\d\/]{4}) /) 
#              to allow "/"'s in some of the groups.
#              also add change of multiple whitespaces to single space.
# 2001/05/21:  permit 5xxx group to be missing.
#              allow return if just MSLP decoded
# 2004/09/13   WMO standards allow adding 50 to MM to represent speeds
#              in knots not m/s *but only in FM 75/76*. It makes no sense
#              for CLIMATs (FM 71) because there are no speeds! But people
#              occasionally make this mistake. If self->Permit_50_in_MM is set 
#              probably view new (... Permit_50_in_MM=>1 ...) then
#              this error will be corrected.

package CLIMAT;

require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw();
@EXPORT_OK = ();

use strict;

# ----------------------------------------------

sub new {

  my $self = { 
    Error_message => "",
    Warn_message => "",
    Error => 0,
    Warn => 0,
    DEBUG => 1,
    P0P0P0P0 => "null",
    PPPP => "null",
    TTT => "null",
    St => "null",
    Tn => "null",
    Tx => "null",
    eee => "null",			# Vapour P
    R1R1R1R1 => "null",			# Ppn, mm
    nrnr => "null",			# Days with > 1mm
    S1S1S1 => "null",			# Sunshine hours
    pspsps => "null",			# .............. as percentage of normal
    mpmp => "null",			# Present days: pressure
    mtmt => "null",                     # (non-missing) temperature
    mxmx => "null",                     #               extreme temperature
    meme => "null",                     #               vapour pressure
    mrmr => "null",                     #               rainfall
    msms => "null",                     #               sunshine
    Permit_50_in_MM => "1",             # Permit error correction if 50 is added to the month (default yes)
    @_
  };
  bless $self;

  return $self;

};

# ----------------------------------------------
 
sub as_oracle {

  my $self = shift;

  my %opts = (
               data => "full"
             , @_
             );

  my $text;
  my $mess = ${$self->{message}};
  $mess =~ s/\s+/ /g; 

  $text = "$self->{IIiii}, $self->{JJJ}, $self->{MM}, $self->{P0P0P0P0}, $self->{PPPP}, $self->{TTT}, $self->{St}, $self->{Tn}, $self->{Tx}, $self->{eee}, $self->{R1R1R1R1}, $self->{nrnr}, $self->{S1S1S1}, $self->{pspsps}, $self->{mpmp}, $self->{mtmt}, $self->{mxmx}, $self->{meme}, $self->{mrmr}, $self->{msms}, $mess";

  return $text;

};

# ----------------------------------------------

sub as_brief {

  my $self = shift;

  my %opts = (
               data => "full"
             , @_
             );

  my $text;
  my $mess = ${$self->{message}};
  $mess =~ s/\s+/ /g;

  $text = "$self->{IIiii}, $self->{JJJ}, $self->{MM}, $self->{P0P0P0P0}, $self->{PPPP}, $self->{TTT}, $self->{St}, $self->{Tn}, $self->{Tx}, $self->{eee}, $self->{R1R1R1R1}, $self->{nrnr}, $self->{S1S1S1}";

  return $text;

};

# ----------------------------------------------
 
sub as_text {

  my $self = shift;

  my %opts = (
               data => "full"
             , @_
             );

  my $text;

  $text = "$self->{IIiii} $self->{MM}/$self->{JJJ}: SfcP $self->{P0P0P0P0} (hPa) MSLP $self->{PPPP} (hPa) SfcT (SD/Min/Max): $self->{TTT} ($self->{St}/$self->{Tn}/$self->{Tx}) VapP $self->{eee} (hPa) Ppn $self->{R1R1R1R1} (mm; in $self->{nrnr} days) Sun $self->{S1S1S1} (hours; $self->{pspsps}%)";

  if ($self->{Warn}) { $text .= " [Warning: $self->{Warn_message}]" };

  return $text;

};

# ----------------------------------------------

sub warn {

  my $self = shift;
  my $message = shift;

  $self->{Warn_message}.= " [$message]";
  $self->{Warn}=1;

  return 1

};

# ----------------------------------------------

sub clear_error {

  my $self = shift;

  undef $self->{Error_message};
  $self->{Error}=0;

  return 1

};

# ----------------------------------------------

sub error {

  my $self = shift;
  my $message = shift;

  $self->{Error_message}=$message;
  $self->{Error}=1;

  return 0

};

# ----------------------------------------------

sub set_message {

  my $self = shift;
  
  $self->{message} = shift;

};

# ----------------------------------------------

sub checkn {

# Use: checkn($n,$message,$group)
#   n - number of chars expected
#   message - what to say on failure
#   group - to check

  my $self = shift;
  my $n = shift;
  my $message = shift;
  my $group = shift;

  if (length($group) != $n) { 
    return $self->error("[checkn error] $message <$group> length <> $n")
  };
  
  return 1;

};

# ----------------------------------------------

sub checknm {

# Use: checknm($n,$m,$message,$group)
#   n - number of chars expected
#   m - leading digit expected
#   message - what to say on failure
#   group - to check

  my $self = shift;
  my $n = shift;
  my $m = shift;
  my $message = shift;
  my $group = shift;

  if (!defined($group) or length($group) != $n) { 
    return $self->error("[checknm error] $message <$group> length <> $n")
  };
 
  my $c = substr($group,0,1);
  if ($c !~ /\d/ or $c != $m) {
    return $self->error("[checknm error] $message <$group> \#$m group in 111 head (".substr($group,0,1).")")
  };

  return 1;

};

# ----------------------------------------------

sub decode {

  my $self = shift;

  my $rmessage = $self->{message};
  my $message = $$rmessage;

  my $extra;				# Extra stuff (which we don't expect)
  my $junk;				# Guess
  my $line="";                  	# One line of message
  my $in;
  my $ok;
  my $header;
  my $k;
  my %bits;

  if ($self->{DEBUG}) { print "starting CLIMAT decode (".length($message).": ".substr($message,0,200).")\n" };

# We may have to skip junk. Note that we don't want to match CLIMAT TEMP
# (if you use CLIMAT.pl, CLIMAT TEMP is removed anyway)
  $ok = ($message =~ /\bCLIMAT (\d)/);
  $message = $1.$'; 

  if (! $ok) { return $self->error("No CLIMAT found") };

# Split on 111, 222, etc
  my @bits = split (/\b(\d)\1\1\b/,$message);

# Pull out the MMJJJ IIiii (hopefully!) groups
  $header = shift @bits;

# Make the rest into hash: $bits{1}=111 groups. We hope.
  %bits = @bits;
#  for $k (keys %bits) { 
#    print "$k $bits{$k}\n"
#  };

# Attempt to decode the header portion, which *should* be MMJJJ IIiii, then
# a 111 (or 222, etc) group. Regrettably, eccentric coding of CLIMATs is widespread,
# so if we can we shall try some "specials"
  $message=~s/\s+/ /g;
  if (! $self->decode_start($header)) {

# Check for coding of null messages (why bother to send these?)
    if ($message =~ /^(\d{5})\s+(\d{5})\s+NIL\s*/ ) {

      my ($MMJJJ,$IIiii) = ($1,$2);

# What should we return? Success (if we can parse MMJJJ and IIiii) I suppose, but the message will be all null's
      return 0 unless $self->parse_MMJJJ($MMJJJ);
      return 0 unless $self->parse_IIiii($IIiii);
      $self->warn("message was NIL");
      return 1;

# One "popular" miscode appears to be, eg, CLIMAT 02900 89642 9814 9867 1052 024// 219//=
# We'll allow this, up to the 1052-type group, which I think is temperature, subject to the first
# two being plausible pressures.
    } elsif ($message =~ /^(\d{5}) (\d{5}) ([\d\/]{4}) ([\d\/]{4}) ([\d\/]{4}) /) {

      $self->clear_error;
      my ($MMJJJ,$IIiii,$P0P0P0P0,$PPPP,$TTT)=($1,$2,$3,$4,$5);
      return 0 unless $self->parse_MMJJJ($MMJJJ);
      return 0 unless $self->parse_IIiii($IIiii);
      return 0 unless $self->decode_p0p0p0p0("1".$P0P0P0P0);
      return 0 unless $self->decode_pppp("2".$PPPP);
      return 0 unless $self->decode_ttt("3".$TTT."///");
      $self->warn("non-standard message format");
      return 1;
 
    } else {

#      print " ...fail\n"
      return 0;
    };

  };
  if (defined $bits{1}) { return 0 unless $self->decode_111($bits{1}) };

  return 1;

};

# ---------------------------------------------

sub parse_MMJJJ {

  my $self = shift;
  my $MMJJJ = shift;

  $self->checkn(5,"MMJJJ",$MMJJJ);
  return $self->error("MMJJJ not digits") unless ($MMJJJ=~/\d{5}/);
  my ($MM,$JJJ) = ($MMJJJ=~/(..)(...)/);
 
  $self->{MM}=$MM; 
# JJJ is year mod 1000. We *might* get back-messages from, say, 1960 (=960) to do...
# Also (sigh) although year *is* modulo 1000 some people think its 1900+year, so lets allow that...
  if ($JJJ > 80 and $JJJ < 120) {
    $self->warn("Year format problem corrected: 1900+ \-> modulo 1000 ($JJJ)");
    $JJJ += 1000
  }; 
  return $self->error("Year (JJJ) range (permitted 1980-2020) error: $JJJ") unless ($JJJ < 20 or $JJJ > 980);
  if ($JJJ < 100) { $JJJ += 2000 } else { $JJJ += 1000 };
  $self->{JJJ}=$JJJ;
# Permit, conditionally, error of adding 50 to MM
  if (($MM > 50 and $MM < 63) and $self->{Permit_50_in_MM}) { 
    $self->warn("MM value is: $MM; subtracting 50 (knots / m/s problem)");
    $MM = $MM - 50; 
    $self->{MM}=$MM; 
  };
  return $self->error("Month range error: $MM") unless ($MM > 0 and $MM < 13);

  return 1;

};

# ---------------------------------------------

sub parse_IIiii {

  my $self = shift;
  my $IIiii = shift;

  return 0 unless $self->checkn(5,"IIiii",$IIiii);
  $self->error("IIiii not digits") unless ($IIiii=~/\d{5}/);
  $self->{IIiii}=$IIiii; 

};

# ---------------------------------------------

sub decode_p0p0p0p0 {

# First group: SfcP

  my $self = shift;
  local $_ = shift;

  return 0 unless $self->checknm(5,1,"111:P0P0P0P0",$_);
  my ($n,$P) = (/(.)(....)/);
  return $self->warn("111:PPPP warning ($P)") unless ($P =~ /\d{4}/);
  if ($P < 5000) { $P += 10000 };
  $self->{P0P0P0P0} = $P/10;

  return 1

};

# ---------------------------------------------

sub decode_pppp {

# Second group: MSLP

  my $self = shift;
  local $_ = shift;

  return 0 unless $self->checknm(5,2,"111:PPPP",$_);
  my ($n,$P) = (/(.)(....)/);
  return $self->warn("111:PPPP warning ($P)") unless ($P =~ /\d{4}/);
  if ($P < 5000) { $P += 10000 };
  $self->{PPPP} = $P / 10.;

  return 1

};

# ---------------------------------------------

sub decode_ttt {

  my $self = shift;
  local $_ = shift;

# Third group: SfcT
  return 0 unless $self->checknm(8,3,"111:TTTststst",$_);
  my ($n,$Sn,$T,$St) = (/(.)(.)(...)(...)/);
# Allow us to do nowt if group is "///"
  return 1 if ($T eq "///");
  return $self->error("111:TTT group format error ($T)") unless ($T =~ /\d{3}/);
  if ($Sn == 1) { $T *= -1 };
  $self->{TTT} = $T/10;
  if ($St =~ /\d{3}/) { $St /= 10 } else { $St = "null" };
  $self->{St} = $St;

  return 1

};

# ---------------------------------------------

sub decode_start {

  my $self = shift;
  my $text = shift;

  my @groups = split(/\s+/,$text);

#  print "decode_start (".join(",",@groups).")\n";

  if (scalar(@groups) != 2) { return $self->error("Header error (before 111 group) does not have 2 groups") };

#
# Extract, error check and decode MMJJJ group
#
  my $MMJJJ = shift @groups;
  return 0 unless $self->parse_MMJJJ($MMJJJ);

#
# Extract IIiii group (station ID)
#
  my $IIiii = shift @groups;
  return 0 unless $self->parse_IIiii($IIiii);

#  if ($self->{DEBUG}) { print "Station: $IIiii Date: $self->{MM}/$self->{JJJ}" };

};

sub decode_111 {
 
  my $self = shift;
  my $text = shift;

  my $group;

#  print "decode_111\n";

  $text =~ s/^\s+(.*)/$1/;
  my @groups = split(/\s+/,$text);

# We expect the groups to be 1.... 2.... etc

# First group: SfcP
  $_ = shift @groups;
  return 0 unless $self->decode_p0p0p0p0($_);

# Second group: MSLP
  $_ = shift @groups;
  return 0 unless $self->decode_pppp($_);

#
# If we've got as far as here, we have useful information. Any failures to
# decode further down should return with what we have plus a warning.
#

# Third group: Temperature
#
# Regrettably, this group is sometimes omitted. Permit this, if the next
# group looks like a legal 4xxx group
  $_ = shift @groups;
  if ($self->decode_ttt($_)) {
  } elsif ($self->checknm(9,4,"111:4xxx (look-ahead test since 3xxx failed)",$_)) {
    unshift @groups, $_;
    $self->clear_error;
    $self->warn("111: 3xxx group missing")
  } else {
    return $self->warn("111: Stopped decoding at 3xxx")
  };

# Fourth group: min/max Temps
#
# Regrettably, this group is sometimes omitted. Permit this, if the next
# group looks like a legal 5xxx group
  $_ = shift @groups;
  if ($self->checknm(9,4,"111:TxTn",$_)) {
    my ($Sn,$Tx,$Sn1,$Tn) = (/.(.)(...)(.)(...)/);
    return $self->warn("111:Tx format warning ($Tx; $Sn)") unless ( $Tx =~ /\d{3}/ and $Sn =~ /\d{1}/ );
    return $self->warn("111:Tn format warning ($Tn; $Sn1)") unless ( $Tn =~ /\d{3}/ and $Sn1 =~ /\d{1}/ );
    if ($Sn == 1) { $Tx *= -1 };
    if ($Sn1 == 1) { $Tn *= -1 };
    $Tx /= 10.;
    $Tn /= 10.;
    $self->{Tx} = $Tx;
    $self->{Tn} = $Tn;
# Better check min < max
    return $self->error("MinT ($Tn) > MaxT ($Tx)") if ($Tn > $Tx);
# If we have a mean temperature, I suppose we'd better check its between the max and min...
    return $self->error("MeanT error ($self->{TTT}) not between min ($Tn) and max ($Tx)") if ($self->{TTT} ne "null" and ($self->{TTT} > $Tx or $self->{TTT} < $Tn));
  } elsif ($self->checknm(4,5,"111:5eee (look-ahead test since 4xxx failed)",$_)) {
    unshift @groups, $_;
    $self->clear_error;
    $self->warn("111: 4xxx group missing")
  } else {
    return $self->warn("111: Stopped decoding at 4xxx")
  };
    
# Fifth group: vapour pressure. Again, can be missing.
  $_ = shift @groups;
  if ($self->checknm(9,5,"111:5eee",$_)) {
    my ($e) = (/.(...)/);
    if ($e eq "///") {
      $self->{eee} = "null"
    } elsif ($e =~ /\d{3}/) {
      $self->{eee} = $e/10
    }
  } elsif ($self->checknm(8,6,"111:6RRRR (look-ahead test since 4xxx failed)",$_)) {
    unshift @groups, $_;
    $self->clear_error;
    $self->warn("111: 5xxx group missing")
  } else {
    return $self->warn("111: Stopped decoding at 5xxx")
  };

# Sixth group: ppn
#
# Regrettably, this group is sometimes omitted. Permit this, if the next
# group looks like a legal 5xxx group
# We allow this (and subsequent) to be missing
  $_ = shift @groups;
  if ($self->checknm(8,6,"111:6RRRR",$_)) {
    my ($R1R1R1R1,$Rd,$nrnr)=(/.(....)(.)(..)/);

# Technically (code table 3596) R1R1R1R1 goes from 0 to 8899 mm. Then
# 9999 means "between 0 and 1". 8900-9998 appear to be undefined.
    if ($R1R1R1R1 eq "////") {
      $self->{R1R1R1R1} = "null"
    } elsif ($R1R1R1R1 =~ /\d{4}/) {
      $self->{R1R1R1R1} = $R1R1R1R1
    } else {
      return $self->warn("111: Stopped decoding at 6xxx")
#      return $self->error("111:6RRRR: R1R1R1R1 error ($R1R1R1R1)")
    };

    if ($nrnr eq "//") {
      $self->{nrnr} = "null"
    } elsif ($nrnr =~ /\d{2}/) {
      $self->{nrnr} = $nrnr
    } else {
      return $self->error("111:6RRRR: nrnr error ($nrnr)")
    };

  } elsif ($self->checknm(7,7,"111:7SSSppp (look-ahead test since 6xxx failed)",$_)) {
    unshift @groups, $_;
    $self->clear_error;
    $self->warn("111: 6xxx group missing")
  } else {
    return $self->warn("111:6xxx: checknm warning")
  };

# Seventh group: sunshine
#
# We allow this (and subsequent) to be missing
  return 1 if (scalar(@groups) == 0);
  $_ = shift @groups;
  return $self->warn("111:7xxx: checknm warning") unless $self->checknm(7,7,"111:7sss",$_);
  my ($S1,$ps) = (/.(...)(...)/);

  if ($S1 eq "///") {
    $self->{S1S1S1} = "null"
  } elsif ($S1 =~ /\d{3}/) {
    $self->{S1S1S1} = $S1
  } else {
    return $self->error("111:7xxx: S1S1S1 error ($S1)")
  };

  if ($ps eq "///") {
    $self->{pspsps} = "null"
  } elsif ($ps =~ /\d{3}/) {
    $self->{pspsps} = $ps
  } else {
    return $self->error("111:7xxx: pspsps error ($ps)")
  };

# Eighth group: missing days
#
# We allow this (and subsequent) to be missing or to fail checknm
  return 1 if (scalar(@groups) == 0);
  $_ = shift @groups;
  return $self->warn("111:8xxx: checknm warning") unless $self->checknm(7,8,"111:8mmm",$_);
  my ($Mp,$Mt,$Mx) = (/.(..)(..)(..)/);

  if ($Mp eq "//") {
    $self->{mpmp} = "null"
  } elsif ($Mp =~ /\d{2}/) {
    $self->{mpmp} = $Mp
  } else {
    return $self->warn("111:8xxx: mpmp warning ($Mp)")
  };

  if ($Mt eq "//") {
    $self->{mtmt} = "null"
  } elsif ($Mt =~ /\d{2}/) {
    $self->{mtmt} = $Mt
  } else {
    return $self->warn("111:8xxx: mtmt warning ($Mt)")
  };

  if ($Mx eq "//") {
    $self->{mxmx} = "null"
  } elsif ($Mx =~ /\d{2}/) {
    $self->{mxmx} = $Mx
  } else {
    return $self->warn("111:8xxx: mxmx warning ($Mx)")
  };

# Ninth group: missing days (2)
#
# We allow this (and subsequent) to be missing
  return 1 if (scalar(@groups) == 0);
  $_ = shift @groups;
  return $self->warn("111:9xxx: checknm warning") unless $self->checknm(7,9,"111:9mmm",$_);
  my ($Me,$Mr,$Ms) = (/.(..)(..)(..)/);

  if ($Me eq "//") {
    $self->{meme} = "null"
  } elsif ($Me =~ /\d{2}/) {
    $self->{meme} = $Me
  } else {
    return $self->warn("111:9xxx: meme warning ($Me)")
  };

  if ($Mr eq "//") {
    $self->{mrmr} = "null"
  } elsif ($Mr =~ /\d{2}/) {
    $self->{mrmr} = $Mr
  } else {
    return $self->warn("111:9xxx: mrmr warning ($Mr)")
  };

  if ($Ms eq "//") {
    $self->{msms} = "null"
  } elsif ($Ms =~ /\d{2}/) {
    $self->{msms} = $Ms
  } else {
    return $self->warn("111:9xxx: msms warning ($Ms)")
  };

  return 1

};

1;