package CFX5::PreRulesProcessor;

use strict;

use CFX5::Output qw(:all);
use CFX5::Config qw(%Config);
use CFX5::PathManip qw(join_file fullpath);

use CFX5::CUEI;

use CFX5::CCLI;

my $Max_Line = 70;

#
# Terminology note: We use the term "data hash" for the name=>value
# hash derived from the parameters of the RULES CCL objects OBJECT,
# PARAMETER, CONTEXT and SINGLETON.  This is to avoid confusion
# between 'parameters' and PARAMETERs.
# 
# Rules data is read into a hash which has the following structure, which
# represents the top-level content of /RULES
#
# { 
#   "dataHash"  => { <hash from param names to values> }, 
#   "objectHash" => { <hash from "<type>:<name>" to object definition hash refs> ]
# }
#
# The "dataHash" represents top-level rules parameters (NB _not_ PARAMETERS!!)
# The "objectHash" represents OBJECT, SINGLETON and PARAMETER definitions. Each
# value in the object hash  has the following structure:
#
# { 
#   "type"           => <OBJECT|SINGLETON|PARAMETER>,
#   "name"           => <object/singleton type|parameter name>
#   "dataHash"       => { <hash from param names to values> },
#   "contextHash"    => { <hash from CONTEXT subobj name to context-dept data (see below)> }
#   "localParamHash" => {<hash from local PARAMETER subobject name to data hash>} 
# }
#
# The "contextHash" has the structure:
#  
# {
#   "dataHash"  => { <hash from param names to values> },
#   "localParamHash" => {<hash from local PARAMETER subobject name to data hash>} 
# }

sub new {
  my $this=shift;
  my $class=ref($this) || $this;
  my $self={};
  bless $self, $class;
  $self;
}

sub go {
  my $self=shift;
  my $outDir=shift || fullpath('.');
  my $noPhysRules=shift;

  $self->{rulesData} = readRulesData($Config{CFX_PRE_RULES_ORIG});

  $self->readExtraRules($Config{CFX_PRE_EXEC_RULES_ORIG})
    or die "read execrules.ccl failed";
  $self->readExtraRules($Config{CFX_PRE_RULES_EXTRA})
    or die "failed";

  # SEAN PEARSON change using name RULES_CHANGE instead of CFXPreRulesChange.txt
  #$self->writeRulesChange(join_file($outDir, 'CFXPreRulesChange.txt'))
  $self->writeRulesChange(join_file($outDir, 'RULES_CHANGE'))
    or die "write failed";
  #$Config{CFX_PRE_RULES_CHANGE} = join_file($outDir, 'CFXPreRulesChange.txt');
  $Config{CFX_PRE_RULES_CHANGE} = join_file($outDir, 'RULES_CHANGE');
  if (!$noPhysRules) {
    $self->writeRulesData(join_file($outDir, 'CFXPrePhysicalRules.ccl'))
      or die "write failed";
  }

  $self->readExtraRules($Config{CFX_PRE_RULES_APPLICATION})
    or die "read rules.application failed";

  doCUEChecks($self->{rulesData}) or die "ERRORS detected in RULES data";

  $self->writeRulesData(join_file($outDir, 'CFXPreRules.ccl'))
    or die "write failed";
  $Config{CFX_PRE_RULES_CCL} = join_file($outDir, 'CFXPreRules.ccl');

  return 1;
}

sub readExtraRules {
  my $self=shift;
  my $extraFile=shift;

  my $extraData = readRulesData($extraFile);
  $self->{rulesData} = mergeData($self->{rulesData}, $extraData);

  1;
}

sub writeRulesData {
  my $self=shift;
  my $outFile=shift;
  $self->printRulesData($outFile, $self->{rulesData});
}

sub writeRulesChange {
  my $self=shift;
  my $outfile=shift;

  _info "Writing merged change data to $outfile...";

  # collect the data to be output into a list
  my @ccl;
  $self->outputRulesData(sub { push @ccl, split("\n", $_[0]) }, $self->{rulesData});

  my $api = CFX5::CCLI::new_api_object();
  $api->setChangeList(1);
  my $cclErr;
  if (defined ($cclErr = $api->parseCCLData(\@ccl))) {
    die "CCL Parser failed with errors\n" . $cclErr;
  }

  my @changelist;
  if (defined ($cclErr = $api->getChangeList(\@changelist))) {
    die "CCL Parser failed with errors\n" . $cclErr;
  }

  unless (open FILE, ">$outfile") {
    _error("Error writing $outfile: $!");
    return '';
  }
  print FILE map { "$_\n" } @changelist;
  unless (close FILE) {
    _error("Error finishing write to $outfile: $!");
    return '';
  }

  _info "...done";

  1;
}

sub readRulesData {
  my $fileName = shift;
  _info "Reading rules file '$fileName'...";
  my $cclLinesRef = readFile($fileName);
  my $data = parseData($cclLinesRef);
  _info "...done";
  return $data;
}

sub readFile {
  my $inFile = shift;

  my @cclLines;
  my $ifh = *STDIN;
  my $opened;
  if ($inFile ne "STDIN") {
    open(MYIFH, "< $inFile") || die "Can't open file $inFile\n";
    $ifh = *MYIFH;
    $opened = 1;
  }
  while(<$ifh>) {
    push (@cclLines, $_);
  }
  $opened && close(MYIFH);
  return \@cclLines;
}

sub parseData {
  my $cclLinesRef = shift;

  my $api = CFX5::CCLI::new_api_object();
  my $cclErr;
  if (defined ($cclErr = $api->parseCCLData($cclLinesRef))) {
    die "CCL Parser failed with errors\n" . $cclErr;
  }
    
  my $rulesInfo;
  $api->getChildInfoList("/RULES", \$rulesInfo);

  my %objectDefs;
  my %topParams;

  foreach my $rulesObj (@{$rulesInfo}) {

    my $name = $rulesObj->{name};
    my $class = $rulesObj->{className};
    my $type = $rulesObj->{type};

    if ($class eq "Object") {

      my $typeName = $type . ":" . $name;
      $objectDefs{$typeName} = makeObjDef($api, $type, $name);

    } elsif ($class eq "Param") {

      $api->getStringValue("/RULES/" . $name, \$topParams{$name});

    }
  }

  my %rulesData;
  $rulesData{dataHash} = \%topParams;
  $rulesData{objectHash} = \%objectDefs;
  return \%rulesData;

}
 

# Sort comparison function to obtain an ordering for output of
# RULES objects. Order is SINGLETONs OBJECTs first ordered by
# name, followed by PARAMETERs, ordered by name. We may want to 
# do something cleverer in future.
# 
sub typeNameCmp {

  my ($typeA, $nameA) = split ':', $a;
  my ($typeB, $nameB) = split ':', $b;

  if ($typeA =~ /^(OBJECT|SINGLETON)/) {
    if ($typeB =~ /^(OBJECT|SINGLETON)/) {
      return $nameA cmp $nameB;
    } else {
      return -1;
    }
  } else {
    if ($typeB =~ /^(OBJECT|SINGLETON)/) {
      return 1;
    } else {
      return $nameA cmp $nameB;
    }
  }
}

sub printRulesData {
  my $self=shift;

  my ($outFile, $data) = @_;

  _info "Printing merged data to $outFile...";

  local *MYOFH;
  unless (open(MYOFH, "> $outFile")) {
    _abort("Can't open $outFile for writing");
  }

  $self->outputRulesData(sub { print MYOFH @_ }, $data);

  # Reset the default output filehandle
  unless (close MYOFH) {
    _error("Error finishing write to $outFile: $!");
    return '';
  }

  _info "...done";

  1;
}

sub outputRulesData {
  my $self=shift;
  my $outfn=shift;
  my $data=shift;

  $outfn->('#' x 80 . "\n");
  $outfn->("# !!!!!!!!!!!\n");
  $outfn->("# ! WARNING !\n");
  $outfn->("# !!!!!!!!!!!\n");
  $outfn->("#\n");
  $outfn->("# This file has been automatically generated by PreRulesProcessor.\n");
  $outfn->("# Do not edit it directly - edit the input files instead.\n");
  $outfn->('#' x 80 . "\n\n");

  $outfn->("RULES:\n\n");

  # Print top level parameters
  $self->outputParams($outfn, $data->{dataHash});

  # Now Print objects in order specified by typeNameCmp function
  foreach my $typeName (sort typeNameCmp keys %{$data->{objectHash}}) {
    my $objDef = $data->{objectHash}{$typeName};
    $self->outputObjectDef($outfn, $objDef);
  }

  $outfn->("\nEND\n");

  1;
}

sub makeObjDef() {

  my ($api, $objType, $objName) = @_;

  my %objDef;
  $objDef{type} = $objType;
  $objDef{name} = $objName;

  my $objPath = "/RULES/" . $objType . ":" . $objName;
  $objDef{dataHash} = getDataHash($api, $objPath);
  $objDef{contextHash}  = getContextHash($api, $objPath);
  $objDef{localParamHash} = getLocalParamHash($api, $objPath);

  return \%objDef;
}

# Extract name => value data from the path.
sub getDataHash {

  my ($api, $path) = @_;

  my $rulesInfo;
  my $errCCL;
  if (defined ($errCCL = $api->getChildInfoList($path, \$rulesInfo))) {
    die "Failed CCLAPI::getChildInfoList with path $path.";
  }

  my %paramHash;
  foreach my $rulesObj (@{$rulesInfo}) {

    my $name = $rulesObj->{name};
    my $class = $rulesObj->{className};
    my $type = $rulesObj->{type};

    if ($class eq "Param") {
      if ($name eq "Ignore Global Definition") {
        # Special case for this parameter : if it is true we will add
        # it to the hash, if false we won't.  So later we can just
        # check for its existence and not have to worry about the
        # interpretation of logical values.
        my $logVal;
        $api->getLogicalValue($path . "/" . $name, \$logVal);
        if ($logVal) {
          $paramHash{$name} = "True";
        }
      }
      else {
        $api->getStringValue($path . "/" . $name, \$paramHash{$name});
      }
    }
  }

  return \%paramHash;
}

sub getContextHash {

  my ($api, $path) = @_;

  my $rulesInfo;
  my $errCCL;
  if (defined ($errCCL = $api->getChildInfoList($path, \$rulesInfo))) {
    die "Failed CCLAPI::getChildInfoList with path $path.";
  }

  my %contextHash;
  foreach my $rulesObj (@{$rulesInfo}) {

    my $name = $rulesObj->{name};
    my $class = $rulesObj->{className};
    my $type = $rulesObj->{type};

    if ($class eq "Object") {

      if ($type ne "CONTEXT" && $type ne "PARAMETER") {
	die "Confused by RULES file!";
      }

      if ($type eq "CONTEXT") {
        my $contextPath = $path . "/CONTEXT:" . $name;
        $contextHash{$name}{dataHash} = getDataHash($api, $contextPath);
        $contextHash{$name}{localParamHash} = getLocalParamHash($api, $contextPath);
      }
    }
  }

  return \%contextHash;
}  

sub getLocalParamHash {
  
  my ($api, $path) = @_;

  my $rulesInfo;
  my $errCCL;

  if (defined ($errCCL = $api->getChildInfoList($path, \$rulesInfo))) {
    die "Failed CCLAPI::getChildInfoList with path $path.";
  }

  my %localParamHash;
  foreach my $rulesObj (@{$rulesInfo}) {

    my $name = $rulesObj->{name};
    my $class = $rulesObj->{className};
    my $type = $rulesObj->{type};

    if ($class eq "Object" && $type eq "PARAMETER") {
      $localParamHash{$name} = getDataHash($api, $path . "/PARAMETER:" . $name);
    }
  }

  return \%localParamHash;
}

sub outputObjectDef {
  my $self=shift;
  my $outfn=shift;
  my $objDefRef = shift;

  $outfn->("\n  ");
  $outfn->($objDefRef->{type} . ": " . $objDefRef->{"name"} . "\n");
  $self->outputParams($outfn, $objDefRef->{dataHash}, "  ");
  $self->outputLocalParams($outfn, $objDefRef->{localParamHash}, "  ");
  $self->outputContexts($outfn, $objDefRef->{contextHash});
  $outfn->("  END\n");
}

sub outputContexts {
  my $self=shift;
  my $outfn=shift;
  my $contextHashRef = shift;

  my $indent = "    ";
  if (scalar %{$contextHashRef}) {
    $outfn->("\n");
    foreach my $name (keys %{$contextHashRef}) {
      $outfn->($indent . "CONTEXT: " . $name . "\n");
      $self->outputParams($outfn, $contextHashRef->{$name}{dataHash}, $indent);
      $self->outputLocalParams($outfn, $contextHashRef->{$name}{localParamHash}, $indent);
      $outfn->($indent . "END\n\n");
    }
  }
}

sub outputParams {
  my $self=shift;
  my $outfn=shift;
  my ($paramHashRef, $indent) = @_;

  if (!defined $indent) {
    $indent = "";
  }
  $indent .= "  ";

  # Some parameters are deemed to be special and are to be output
  # first in a defined order.
  my @specialParamsList = ( "CCLObject Class", "Category", "Scheduler",
			    "Scheduler Links", "Calculate Function" );
  
  # Create a lookup hash of the parameters
  my %specialParamsHash;
  foreach my $param (@specialParamsList) {
    $specialParamsHash{$param} = 1;
  }

  # Print any special params first in the list order.
  foreach my $spec (@specialParamsList) {
    if (exists $paramHashRef->{$spec}) {
      $self->outputParam($outfn, $spec, $paramHashRef->{$spec}, $indent);
    }
  }

  # Now the remainder, skipping the special ones
  foreach my $name (keys %{$paramHashRef}) {
    next if exists $specialParamsHash{$name};
    $self->outputParam($outfn, $name, $paramHashRef->{$name}, $indent);
  }

}

sub outputLocalParams {
  my $self=shift;
  my $outfn=shift;

  my ($localParamHashRef, $indent) = @_;

  if (!defined $indent) {
    $indent = "";
  }
  $indent .= "  ";

  foreach my $name (keys %{$localParamHashRef}) {
    $outfn->($indent . "PARAMETER: " . $name . "\n");
    my %params = %{$localParamHashRef->{$name}};
    while (my ($key, $value) = each (%params)) {
      $self->outputParam($outfn, $key, $value, $indent."  ");
    }
    $outfn->($indent . "END\n\n");
  }
}

sub outputParam {
  my $self=shift;
  my $outfn=shift;

  my ($name, $value, $indent) = @_;

  my $nameEqStr = $indent . $name . " = ";

  my %paramInfo;
  $paramInfo{name} = $name;
  $paramInfo{value} = $value;
  $paramInfo{"value indent"} = length($nameEqStr);
  $paramInfo{"value len"} = length($value);

  $value = formatParamValue(\%paramInfo);

  $outfn->($nameEqStr . $value . "\n");

}

sub formatParamValue {

  my $info = shift;

  if ($info->{"value len"} + $info->{"value indent"} <= $Max_Line) {
    return $info->{value};
  }

  if ($info->{name} eq "Description") {
    return formatTextParam($info);
  } elsif ($info->{name} eq "Calculate Function") {
    return formatTripletParam($info);

    # >> Add other special cases in elsif blocks here <<<
  } else {
    return formatListParam($info);
  }

}
 
#
# Format a parameter value that contains text (e.g. the "Description"
# parameter of PARAMETER). This involves tokenising at spaces and 
# inserting line breaks at appropriate points.
#
sub formatTextParam {

  my $info = shift;

  my @tokens = split ' ', $info->{value};

  my $indent = $info->{"value indent"};
  my $currPos = $indent;
  my $retVal = "";

  foreach my $tok (@tokens) {
    my $tokLen = length($tok);
    $retVal .= $tok . " ";
    $currPos += $tokLen + 1;
    if ($currPos > $Max_Line) {
      $retVal .= "\\\n" . " " x $indent;
      $currPos = $indent;
    }
  }

  # Get rid of trailing spaces and continuations
  $retVal =~ s/\\\n\s*$//;

  return $retVal;
}

# Triplet parameters such as rhe "Calculate Function" parameter is 
# conventionally formatted in rules as follows:
#
# Calculate Function = <scheduler name>, <library name>, <function name>, \
#                      <scheduler name>, <library name>, <function name>, \
#                      ...
#
# where the names are aligned in columns.
#
sub formatTripletParam {

  my $info = shift;

  my @tokens = splitParamValue($info->{value});

  if (scalar(@tokens) % 3 != 0) {
    print "Invalid number of entries in \"". $info->{name} . "\" list.\n";
    exit 1;
  }

  my $indent = $info->{"value indent"};
  my $retVal = "";

  # Find max lengths of names in the three 'columns'
  my @colLen = (0, 0, 0);
  for (my $iTok = 0; $iTok < scalar(@tokens); $iTok += 3) {
    for (my $col = 0; $col < 3; ++$col) {
      my $tok = $tokens[$iTok + $col];
      my $tokLen = length $tok;
      $colLen[$col] = $tokLen if $tokLen > $colLen[$col];
    }
  }

  # Now we can format with appropriate padding
  for (my $iTok = 0; $iTok < scalar(@tokens); $iTok += 3) {
    for (my $col = 0; $col < 3; ++$col) {
      my $tok = $tokens[$iTok + $col];
      my $tokLen = length $tok;
      my $padLen = $colLen[$col] - $tokLen;
      my $padding = " " x $padLen;
      $retVal .= $tok . ", " . $padding;
    }
    $retVal .= "\\\n" . " " x $indent;
  }

  # Get rid of trailing spaces and continuations
  $retVal =~ s/,\s*\\\n\s*$//;

  return $retVal;
}

#
# Format a parameter value that contains a list. This involves tokenising at 
# commas and inserting line breaks at appropriate points.
#
sub formatListParam {
  
  my $info = shift;

  my @values = splitParamValue($info->{value});

  my $indent = $info->{"value indent"};
  my $currPos = $indent;
  my $retVal = "";

  foreach my $val (@values) {
    my $valLen = length($val);
    $retVal .= $val . ", ";
    $currPos += $valLen + 2;
    if ($currPos > $Max_Line) {
      $retVal .= "\\\n" . " " x $indent;
      $currPos = $indent;
    }
  }

  # Get rid of trailing ',' and continuations
  $retVal =~ s/\\\n\s*$//;
  $retVal =~ s/, $//;

  return $retVal;
}

#
# Merge two sets of rules data. The first is considered to be
# 'base data', the second additional ('extra') data. The latter
# is merged in place into the former.
#

sub mergeData {

  my ($baseData, $extraData) = @_;

  my $baseParams  = $baseData->{dataHash};
  my $extraParams = $extraData->{dataHash};

  _info "Merging data...";

  # May need to modify ROOT specification in $extraData to ensure
  # it gets appended properly

  if (exists $extraData->{objectHash}{"SINGLETON:ROOT"}) {
    my $root = $extraData->{objectHash}{"SINGLETON:ROOT"};
    if (exists $root->{dataHash}{"Optional Child List"}) {
      my $value = $root->{dataHash}{"Optional Child List"};
      if ($value !~ /^\s*<[+\-]>/) {
	$value = "<+>" . $value;
	$root->{dataHash}{"Optional Child List"} = $value;
      }
    }
  }
  else {
    my @root;
    # Loop over all extra child objects and look for extensions to root.
    foreach my $typeName (keys %{$extraData->{objectHash}}) {
      if ( $typeName =~ /OBJECT:/ or $typeName =~ /SINGLETON:/ ) {
        my $obj = $extraData->{objectHash}{ $typeName };
        if ( defined( $obj ) ) {
          my $value = $obj->{dataHash}{ "Allowed Parent List" };
          if ( defined $value && $value eq "ROOT" ) {
            my ($type, $name) = split ':', $typeName;
            push( @root, $name );
          }
        }
      }
    }
    
    if ( scalar ( @root ) > 0 ) {
      my $value = "<+>" . join ",", @root ;
      # Create a local root object.
      $extraData->{objectHash}{ "SINGLETON:ROOT" }->{dataHash}{ "Optional Child List" } =
        $value;
    }
  }

  $baseData->{dataHash} = mergeParams("RULES:", $baseParams, $extraParams);

  $baseData = mergeObjects($baseData, $extraData);
  _info "...done";
  return $baseData;
}
  
 
sub mergeParams {

  my ($objName, $base, $extra) = @_;

  my @extraOnly = setDifference($extra, $base);
  my @common = setIntersection($extra, $base);

  # Extra params can simply be written into base without merging
  foreach my $param (@extraOnly) {
    my $value = $extra->{$param};

    if ($value =~ /^\s*\<[\-]\>\s*/) {
      die "In object '$objName', invalid parameter $param only in\n" .
	"\"extra\" data that has value $value.\n";
    } else {
      # Get rid of 'append' string if it is there.
      $value =~ s/^\s*\<[+]\>\s*(.*)$/$1/;
      if ($value !~ /^\s*$/) {
	$base->{$param} = $value;
      }
    }
  }

  # Now deal with common params
  foreach my $param (@common) {
    my $value = $extra->{$param};

    if ($param eq "Parameter Type" 
	&& $base->{$param} eq "String List"
	&& exists $base->{"Allowed String List"}) {

      if ($value eq "String") {
	die "In object '$objName', parameter '$param'\n"
	  . "is being changed from type 'String List' to 'String'\n"
	    . "but it has an 'Allowed String List'. This is not allowed\n"
	      . "as it is liable to generate bad rules.\n";
      }
    }

    my $mergedValue;
    if ($value =~ /^\s*\<[\-]\>\s*/) {
      checkMergeableParam($param);
      $value =~ s/^\s*\<[\-]\>\s*(.*)$/$1/;
      $base->{$param} = subtractValues($base->{$param}, $value);
    } elsif ($value =~ /^\s*\<[+]\>\s*/) {
      checkMergeableParam($param);
      $value =~ s/^\s*\<[+]\>\s*(.*)$/$1/;
      $base->{$param} = combineValues($param, $base->{$param}, $value);
    } else {
      
      # Overwrite base value with extra value
      if ($value =~ /^\s*$/) {
	# Empty extra value is a special case - means delete parameter completely
	delete $base->{$param};
      } else {
	$base->{$param} = $value;
      }
    }
  }

  return $base;
}

sub mergeObjects {

  my ($base, $extra) = @_;

  my $baseObjHashRef = $base->{objectHash};
  my $extraObjHashRef = $extra->{objectHash};

  # Now split extra objects into those that are completely new and
  # those which represent modifications to base objects.

  my @newTN;
  my @modifiedTN;
  foreach my $typeName (keys %{$extraObjHashRef}) {
    if (exists $baseObjHashRef->{$typeName}) {
      push @modifiedTN, $typeName;
    } else {
      push @newTN, $typeName;
    }
  }
  
  # Now merge the data...

  # Deal with modified objects first
  foreach my $typeName (@modifiedTN) {
    $base->{objectHash}{$typeName} = 
      mergeObject($baseObjHashRef->{$typeName}, $extraObjHashRef->{$typeName});
  }

  # Added objects are relatively easy
  foreach my $typeName (@newTN) {
    $base->{objectHash}{$typeName} = $extraObjHashRef->{$typeName};
  }

  return $base;
}

sub mergeObject {
  
  my ($baseObjDefRef, $extraObjDefRef) = @_;

  # Merge the param=>value data first
  my $typeName = $baseObjDefRef->{type} . ":" . $baseObjDefRef->{name};

  $baseObjDefRef->{dataHash} = mergeParams($typeName,
                                           $baseObjDefRef->{dataHash},
                                           $extraObjDefRef->{dataHash});

  # If not a parameter merge the local parameters and context objects...
  
  if ($baseObjDefRef->{type} ne "PARAMETER") {

    # 1. Local parameters
    mergeParameterObjects($typeName, 
                          $baseObjDefRef->{localParamHash},
                          $extraObjDefRef->{localParamHash});

    # 2. Contexts
    
    # Need to check which are new and which are to be merged
    my @commonContexts = setIntersection($baseObjDefRef->{contextHash},
                                         $extraObjDefRef->{contextHash});
    my @extraOnlyContexts = setDifference($extraObjDefRef->{contextHash},
                                          $baseObjDefRef->{contextHash});
    
    # Merge the common ones
    foreach my $commCtxt (@commonContexts) {
      $baseObjDefRef->{contextHash}{$commCtxt}{dataHash} = 
        mergeParams($typeName . "/CONTEXT:" . $commCtxt,
                    $baseObjDefRef->{contextHash}{$commCtxt}{dataHash},
                    $extraObjDefRef->{contextHash}{$commCtxt}{dataHash});
      # PARAMETERS at CONTEXT level.
      mergeParameterObjects($typeName . "/CONTEXT:" . $commCtxt,
                            $baseObjDefRef->{contextHash}{$commCtxt}{localParamHash},
                            $extraObjDefRef->{contextHash}{$commCtxt}{localParamHash});
    }

    # Add the new ones
    foreach my $newCtxt (@extraOnlyContexts) {
      $baseObjDefRef->{contextHash}{$newCtxt} = $extraObjDefRef->{contextHash}{$newCtxt};
    }
  }

  return $baseObjDefRef;
}


sub mergeParameterObjects {

  # Note that we merge _into_ $baseParams
  my ($rootName, $baseParams, $extraParams) = @_;

  my @common = setIntersection($extraParams, $baseParams);
  my @extraOnly = setDifference($extraParams, $baseParams);

  # Merge the common ones
  foreach my $comm (@common) {
    $baseParams->{$comm} = mergeParams($rootName . "/PARAMETER:" . $comm,
                                 $baseParams->{$comm}, $extraParams->{$comm});
  }

  # Add the new ones
  foreach my $extra (@extraOnly) {
    $baseParams->{$extra} = $extraParams->{$extra};
  }

}
 

#
# This subroutine should cause merge to abort if the parameter
# is one which cannot be merged. Ideally we want to be able to
# identify list valued parameters. Most of these can be identified
# as having name "<something> List", but there are exceptions.
#
sub checkMergeableParam {

  my $name = shift;

  my $ok = 1;

  # Concievably could attempt to split this at commas.
  if ($name eq "Description") {
    $ok = 0;
  }

  if (!$ok) {
    die "Can't merge parameter $name - not a list type.";
  }

}


sub combineValues {

  my ($param, $value1, $value2) = @_;
  
  if ($value1 =~ /^\s*$/) {
    return $value2;
  }

  my @list1 = splitParamValue($value1);
  my %in1;
  foreach my $item (@list1) {
    $in1{$item} = 1;
  }

  my @list2 = splitParamValue($value2);
  my $filtered;
  foreach my $item (@list2) {
    if (!exists $in1{$item}) {
      $filtered .= ", " . $item;
    }
  }

  unless (defined $filtered) {
    _error("combineValues: all additional values '$value2' for parameter $param appear in original data '$value1'");
    $filtered='';
  }

  return $value1 . $filtered;

}

sub subtractValues {

  my ($value1, $value2) = @_;
  
  if ($value2 =~ /^\s*$/) {
    return $value1;
  }

  my @list2 = splitParamValue($value2);
  my %in2;
  foreach my $item (@list2) {
    $in2{$item} = 1;
  }

  my @list1 = splitParamValue($value1);
  my $filtered;
  foreach my $item (@list1) {
    if (!exists $in2{$item}) {
      $filtered .= $item . ", ";
    }
  }

  $filtered =~ s/, $//;
  return $filtered;
}


sub setDifference {
  return grep { !exists $_[1]->{$_} } keys %{$_[0]};
}

sub setIntersection {
  return grep { exists $_[1]->{$_} } keys %{$_[0]};
}

sub listToSet {
  return map { $_, 1 } @_;
}

sub splitParamValue {
  return split /\s*,\s*/, shift;
}
  
sub getSplitParamValue {
  my ($paramHash, $paramName) = @_;
  my @ret;
  if (exists $paramHash->{$paramName}) {
    @ret = splitParamValue($paramHash->{$paramName});
  }
  return @ret;
}

sub doCUEChecks {

  my $rulesData = shift;
  _info "Final checks of merged data...";

  my (%paramObjRefs, %objParamRefs);
  getObjParamXrefs($rulesData, \%paramObjRefs, \%objParamRefs);
  my $ok = 
    checkParamObjXref($rulesData, \%paramObjRefs) &&
    checkSchedulerRefs($rulesData, \%objParamRefs);

  _info "...done " . ($ok ? "(succeeded)." : "(failed).");
  
  return $ok;
}
  
sub getObjParamXrefs {
  
  my ($rulesData, $paramObjRefs, $objParamRefs) = @_;

  my @paramNames;

  while ( my ($typeName, $objDef) = each %{$rulesData->{objectHash}} ) {
    if ($objDef->{type} eq "PARAMETER") {
      push @paramNames, $objDef->{name};
    }
    else {
      extractParamRefs($objDef->{dataHash}, $typeName, 
                       $paramObjRefs, $objParamRefs);
      
      foreach my $ctxtName (keys %{$objDef->{contextHash}}) {
	extractParamRefs($objDef->{contextHash}{$ctxtName}{dataHash},
			 $typeName, $paramObjRefs, $objParamRefs);
      }
    }
  }

  # Warn, but don't fail, it there are unreferenced PARAMETERS
  foreach my $param (@paramNames) {
    if (!exists $paramObjRefs->{$param}) {
      _print("\"PARAMETER:$param\" is not referenced in any object!\n");
    }
  }
}

sub extractParamRefs {

  my ($dataHash, $typeName, $paramObjRefs, $objParamRefs) = @_;

  foreach my $listParam ("Optional Parameter List",
			 "Essential Parameter List",
			 "Default Parameter List",
                         "Internal Parameter List") {
    if (exists $dataHash->{$listParam}) {
      foreach my $item (splitParamValue($dataHash->{$listParam})) {
	$objParamRefs->{$typeName}{$item} = 1;
        $paramObjRefs->{$item}{$typeName} = 1;
      }
    }
  }
}

# As a sanity check, ensure that parameters referenced in object
# definitions (keys in the %{$paramObjXref} hash) have corresponding
# PARAMETER definitions.
#

sub checkParamObjXref {

  my ($rulesData, $paramObjXref) = @_;
  my $ok = 1;

  foreach my $paramName (keys %{$paramObjXref}) {
    
    my $found = 0;
    if (exists $rulesData->{objectHash}{"PARAMETER:" . $paramName}) {
      $found = 1;
    }
    else {
      
      # There is no global PARAMETER definition so we need to check
      # that there is a local definition in each referencing object.
      # Note that some objects may reference a local PARAMETER for
      # which there is also a global definition.  We don't care about
      # that here as long as there is *some* definition.

      my $nmissing = scalar(keys %{$paramObjXref->{$paramName}});
      foreach my $refObj (keys %{$paramObjXref->{$paramName}}) {
        # A PARAMETER is not allowed to be defined only at CONTEXT
        # level so we only need to look at the object local level.
        if (exists $rulesData->{objectHash}{$refObj}{localParamHash}{$paramName}) {
          --$nmissing;
        }
        else {
          _print("Undefined parameter $paramName is referenced in $refObj.\n");
        }
      }
      $found = $nmissing == 0;
    }
    
    $ok = $ok && $found;

  }
  return $ok;
}

sub checkSchedulerRefs {

  my ($rulesData, $objParamRefs) = @_;

  my $ok = 1;

  foreach my $typeName (keys %{$objParamRefs}) {
    
    my $objHash = $rulesData->{objectHash}{$typeName};
    my $objDataHash = $objHash->{dataHash};
    my %schedulerSet;
    if (exists $objDataHash->{Scheduler}) {
      %schedulerSet = listToSet(splitParamValue($objDataHash->{Scheduler}));
    }

    foreach my $param (keys %{$objParamRefs->{$typeName}}) {
      
      my %localTypes;

      # lookup "local type" for the parameter
      
      # first of all check context levels:

      my $nCtxt = scalar(keys %{$objHash->{contextHash}});
      my $missingCtxt = 0;
      foreach my $ctxt (keys %{$objHash->{contextHash}}) {
        my $ctxtHash = $objHash->{contextHash}{$ctxt};
        if (exists $ctxtHash->{localParamHash}{$param}) {
          if (exists $ctxtHash->{localParamHash}{$param}{"Local Type"}) {
            $localTypes{$ctxtHash->{localParamHash}{$param}{"Local Type"}} = 1;
          }
          else {
            # There is at least one context where no Local Type defined.
            ++$missingCtxt;
          }
        }
      }
      my $checkObjectLocal = $nCtxt == 0 || $missingCtxt > 0;
      my $checkObjectGlobal = $checkObjectLocal;

      # check the object local level
      if ($checkObjectLocal &&
          exists $objHash->{localParamHash}{$param} &&
          exists $objHash->{localParamHash}{$param}{"Local Type"}) {
        $localTypes{$objHash->{localParamHash}{$param}{"Local Type"}} = 1;
        # Have accounted for all contexts now.
        $checkObjectGlobal = 0;
      }
      

      # Fallback to global definition if we didn't find a (complete) local one
      if ($checkObjectGlobal && 
          (!exists $objHash->{localParamHash}{$param} ||
           !exists $objHash->{localParamHash}{$param}{"Ignore Global Definition"}) &&
          exists $rulesData->{objectHash}{"PARAMETER:$param"}) {
        if (exists $rulesData->{objectHash}{"PARAMETER:$param"}{dataHash}{"Local Type"}) {
          $localTypes{$rulesData->{objectHash}{"PARAMETER:$param"}{dataHash}{"Local Type"}} = 1;
        }
      }

      foreach my $localType (keys %localTypes) {
        if (!exists $schedulerSet{$localType}) {
          _warn "In object $typeName, parameter $param has invalid local scheduler type $localType\n";
          $ok = 0;
        }
      }
    }
  }
  return $ok;
}

