#!/usr/bin/perl5 -w
#
# adit_convert	K. J. Turner and R. Bland	18/10/07
#
# This script supports ADIT (Abstract Decision/Interactive Trees), converting
# among various representations of Clinical Guidance Trees. It takes one or more
# files on the command line and an option to convert these (exactly one of the
# following options must be specified, followed by one or more file names):
#
#  -c		convert to ADIT (e.g. file.tree to file.adit)
#
#  -g level	gate hiding: 0 hide/back (default), 1 i/back, 2 hide, 3 i
#		[for -l]
#
#  -i indent	indentation level as number of spaces (default 2)
#
#  -l		convert to LOTOS (e.g. file.adit to file.lot)
#
#  -t		convert to tree (e.g. file.adit to file.tree)
#
#  -w width	line width as number of characters (default 80) [for -l]
#
#  -x		convert to XML (e.g. file.tree to file.xml)

# Other command-line options are:
#
#   -e    use the given error reporting level (3 - panics, 2 - these plus
#	  errors, 1 (default) - these plus notes, 0 - these plus diagnostics)
#
#  -h	print usage

# The suffix of the output file is implied by the conversion operation. The
# suffix of the input file is usually implicit, but is required if several
# input conversions are possible (e.g. "-t" has file.adit as the default, but
# may be used file file.xml). Note that the output file is overwritten without
# warning if it already exists.

# Set the environment variable "TMP" to a temporary directory ("/tmp" by
# default). The relevant M4 binary needs to be on the "PATH".

# Examples of use are:
#
#   adit_convert -h		print usage
#
#   adit_convert -c walk	converter walk.tree to walk.adit
#
#   adit_convert -t walk diet	converter walk.adit to walk.tree
#
#   adit_convert -t flu.xml	converter flu.xml to flu.tree

use Getopt::Std;				# get options

######################### Main Program #########################

&customise;					# customise script
&initialise;					# set up script
&convert_files;					# convert files
&finalise;					# close down script

######################### Subroutines #########################

# check variable initialisation, reporting an error for undefined variables

sub check_initialisation {
  my($variable, $value) = @_;			# get variable and value
  my($new);					# locals

  while ($value =~ /\b([a-zA-Z]\w*)\b/go) {	# go through value identifiers
    $identifier = $1;				# get identifier
    if (($identifier cmp $variable) >= 0) {	# identifier comes later?
      &error("initialisation of '$variable' " .	# report error
	"uses uninitialised '$identifier'");
    }
  }
}

# clean up clean_attribute

sub clean_attribute {
  my($original) = @_;				# get original identifier
  my($new);					# locals

  $new = &clean_value($original);		# clean up original value
  $new = &trim($new);				# get trimmed value
  $new =~ s/(?:\r\n?|\n)\s*/ /gos;		# replace newline by space
  return($new);					# return new identifier
}

# clean up identifier, reporting an error if the result is empty

sub clean_identifier {
  my($original) = @_;				# get original identifier
  my($new);					# locals

  $new = &trim($original);			# get trimmed original ident
  $new =~ s/\s+/_/go;				# spaces to underscores
  $new =~ s/[^\w]//go;				# remove non-alphanumeric
  $new =~ s/^[^a-zA-Z]+//o;			# remove leading non-alpha
  if (!$new) {					# new identifier empty?
    &error("invalid node identifier '$original'"); # report error
  }
  return($new);					# return new identifier
}

# clean up label, reporting an error if the result is empty

sub clean_label {
  my($original) = @_;				# get original identifier
  my($new);					# locals

  $new = $original;				# get original identifier
  $new =~ s/^\s+//o;				# removing leading spaces
  $new =~ s/\s+$//o;				# removing trailing spaces
  $new =~ s/,//go;				# remove commas
  if ($new =~ /^\[(.*)\]$/o) {			# composed label?
    $new = $1;					# extract label(s)
    $new =~ s/\]\s*\[/ \& /go;			# use "&" between parts
  }
  if (!$new) {					# new identifier empty?
    &error("invalid node identifier '$original'"); # report error
  }
  return($new);					# return new identifier
}

# clean up value, surrounding it with M4 quotes if an unparenthesised
# comma is present, and checking for balance "`...'", "{...}" and "(...)"

sub clean_value {
  my($original) = @_;				# get original identifier
  my($brace, $char, $i, $last_brace,		# locals
    $last_parenthesis, $last_quote, $new,  $parenthesis, $quote);

  $new = $original;				# copy original value to new
  $new =~ s/"/'/go;				# double to single quotes
  $new =~ s/~/&#126;/go;			# tildes to HTML equivalent
  $new =~ s//&not;/go;				# nots to HTML equivalent
  $new =~ s/\$/\$/go;				# "$" to "$" to stop expansion
  $brace = 0;					# initialise brace count
  $parenthesis = 0;				# initialise parenthesis count
  $quote = 0;					# initialise quote count
  $last_brace = -1;				# set no last brace seen
  $last_parenthesis = -1;			# set no last brace seen
  $last_quote = -1;				# set no last brace seen
  for ($i = 0; $i < length($new); $i++) {	# go through value
    $char = substr($new, $i, 1);		# get character
    if ($char eq "{") {				# open brace?
      if (!$brace) {				# outer brace?
	$last_brace = $i;			# note last open brace
      }
      $brace++;					# increment brace count
    }
    elsif ($char eq "}") {			# close brace?
      $brace--;					# decrement brace count
      if ($brace < 0) {				# unmatched close brace?
	&error("unmatched '}' in '... " .	# report error
	  &string_context($i, $new) . " ...'");
	last;					# leave loop
      }
    }
    elsif ($char eq "(") {			# open parenthesis?
      if (!$parenthesis) {			# outer parenthesis?
	$last_parenthesis = $i;			# note last open parenthesis
      }
      $parenthesis++;				# increment parenthesis count
    }
    elsif ($char eq ")") {			# close parenthesis?
      $parenthesis--;				# decrement parenthesis count
      if ($parenthesis < 0) {			# unmatched close parenthesis?
	&error("unmatched ')' in '... " .	# report error
	  &string_context($i, $new) . " ...'");
	last;					# leave loop
      }
    }
    elsif ($char eq "`") {			# open quote?
      if (!$quote) {				# outer quote?
	$last_quote = $i;			# note last open quote
      }
      $quote++;					# increment quote count
    }
    elsif ($char eq "'") {			# close quote?
      $quote--;					# decrement quote count
      if ($quote < 0 && $last_quote >= 0) {	# unmatched close quote?
	&error("unmatched ''' in '... " .	# report error
	  &string_context($i, $new) . " ...'");
	last;					# leave loop
      }
    }
  }
  if ($brace > 0) {				# unmatched open brace?
    &error("unmatched '{' in '... " .		# report error
      &string_context($last_brace, $new) . " ...'");
  }
  if ($parenthesis > 0) {			# unmatched open parenthesis?
    &error("unmatched '(' in '... " .		# report error
      &string_context($last_parenthesis, $new) . " ...'");
  }
  if ($quote > 0) {				# unmatched open quote?
    &error("unmatched '`' in '... " .		# report error
      &string_context($last_quote, $new) . " ...'");
  }
  $new = "[[$new]]";				# quote value
  return($new);					# return new identifier
}

# convert tree for filenames given on command-line

sub convert_files {
  my($base, $file, $suffix);			# locals

  foreach $file (@ARGV) {			# go through command-line files
    if ($file =~ /^(.*)(\.[^.]+)$/o) {		# "file.suffix"?
      $base = $1;				# set file base name
      $suffix = $2;				# set file suffix
    }
    else {					# not "file.suffix
      $base = $file;				# set file base name
      $suffix = "";				# set file suffix
    }
    if ($opt_c) {				# convert to ADIT format?
      &parse_tree($base, $suffix);		# parse tree
      if ($exit_code == 0) {			# tree parsed?
	&write_adit($base, $suffix);		# write ADIT for tree
      }
    }
    elsif ($opt_l) {				# convert to LOTOS format?
      &write_lotos($base, $suffix);		# write LOTOS for ADIT
    }
    elsif ($opt_t) {				# convert to tree format?
      &write_tree($base, $suffix);		# write LOTOS for ADIT/XML
    }
    else {					# convert to XML format
      &parse_tree($base, $suffix);		# parse tree
      if ($exit_code == 0) {			# tree parsed?
	&write_xml($base, $suffix);		# write XML for tree
      }
    }
  }
}

# customise script to local needs

sub customise {
  $adit_prefix = "adit_";			# ADIT macro prefix (e.g. "adit_")
  $adit_suffix = ".adit";			# ADIT filename suffix
  $adit_version = "1.1";			# set tool version
  $attribute_size = 20;				# max. characters in attribute
  $adit_copyright =				# set tool copyright
    "$adit_version 2007-10-18  (C) K. J. Turner, University of Stirling";
  $context_size = 30;				# +/- characters in context
  $lotos_suffix = ".lot";			# LOTOS filename suffix
  $m4 = "m4";					# set M4 command
  $m4_suffix = ".m4";				# M4 filename suffix
  $tmp_dir = $ENV{TMP}; 			# temporary directory
  if (!defined($::tmp_dir)) {			# temp directory undefined?
    $tmp_dir = "/tmp"; 				# use /tmp directory
  }
  $tree_suffix = ".tree";			# tree filename suffix
  $xml_suffix = ".xml";				# XML filename suffix
  $xml_version = 				# set XML version
    "version=\"1.0\" encoding=\"ISO-8859-1\"";

  @months =					# set month names
    ("Jan", "Feb", "Mar", "Apr", "May", "Jun",
     "Jul", "Aug", "Sep", "Oct", "Nov", "Dec");
}

# given a message, print a diagnostic message

sub diagnostic {
  my($message) = @_;				# get diagnostic message
  my($program);					# locals

  if ($opt_e <= 0) {				# diagnostics needed?
    $program = defined($prog) ? $prog : "";	# set program
    print STDERR "[Diagnostic] $program: $message\n";# print message
  }
}

# given a message, report an error (i.e. user error)

sub error {
  my($message) = @_;				# get error message
  my($program);					# locals

  if ($opt_e <= 2) {				# errors to be reported?
    $program = defined($prog) ? $prog : "";	# set program
    print STDERR "[Error] $program: $message\n";# print message
  }
  $exit_code = 1;				# exit with result of 1
}

# finalise actions and exit

sub finalise {
  exit($exit_code);				# exit with code
}

# set up script

sub initialise {
  my($opt_h);					# locals
  $prog = $0;					# set program name
  $prog =~ s/.*\///g;				# remove directories
  $SIG{'INT'} = 'signal_handler';		# deal with interrupt
  $SIG{'QUIT'} = 'signal_handler';		# deal with quit
  $SIG{'TERM'} = 'signal_handler';		# deal with termination
  $exit_code = 0;				# exit code
  $opt_c = 0;					# initialise not ADIT format
  $opt_e = 1;					# set error reporting level
  $opt_g = 0;					# set no gate hiding
  $opt_h = 0;					# initialise not help
  $opt_i = 2;					# set indentation spaces
  $opt_l = 0;					# initialise not LOTOS format
  $opt_t = 0;					# initialise not tree format
  $opt_w = 80;					# initialise 80 characters wide
  $opt_x = 0;					# initialise not XML format
  if (!getopts('ce:g:hi:ltw:x') ||		# options wrong or ...
    $opt_h ||					# help or ...
    $opt_c + $opt_l + $opt_t + $opt_x != 1 ||	# one of -c/-l/-t/-x or ...
    $opt_w <= 0 ||				# non-positive width
    $#ARGV < 0) {				# no arguments?
    &usage();					# wrong options - print usage
  }
  $adit_debug = $opt_e;				# set error reporting level
  $adit_gate = $opt_g;				# set gate hiding level
  $adit_indent = $opt_i;			# set node indentation spaces

  # set tree attributes

  %field_attribute = (				# set field attribute
    "BoundVariable"		=> "variable",
    "ComposedHeadings"		=> "composed",
    "ComposedNodeJoiningText"	=> "conjunction",
    "DictionaryFile"		=> "dictionary",
    "DocumentingText"		=> "reason",
    "ExistsIf"			=> "visible",
    "GlobalMacros"		=> "macros",
    "InputType"			=> "format",
    "InstructionText"		=> "perform",
    "IntroText"			=> "display",
    "JoiningText"		=> "variable",
    "LongLabel"			=> "label",
    "NeutralPoint"		=> "neutral",
    "Payoff"			=> "payoff",
    "PrintIf"			=> "print",
    "Prob"			=> "probability",
    "QuestionText"		=> "query",
    "RequiresVersion"		=> "version",
    "ScaleIf"			=> "scale",
    "UserText"			=> "display",
    "ValidationRule"		=> "check",
    "ValidationRuleText"	=> "error"
  );

  %field_macro = (				# set field macro usage
    "BoundVariable"		=> 0,
    "ComposedHeadings"		=> 0,
    "ComposedNodeJoiningText"	=> 1,
    "DictionaryFile"		=> 0,
    "DocumentingText"		=> 1,
    "ExistsIf"			=> 1,
    "GlobalMacros"		=> 1,
    "InputType"			=> 0,
    "InstructionText"		=> 1,
    "IntroText"			=> 1,
    "JoiningText"		=> 1,
    "LongLabel"			=> 1,
    "NeutralPoint"		=> 0,
    "Payoff"			=> 0,
    "PrintIf"			=> 1,
    "Prob"			=> 0,
    "QuestionText"		=> 1,
    "RequiresVersion"		=> 0,
    "ScaleIf"			=> 1,
    "UserText"			=> 1,
    "ValidationRule"		=> 1,
    "ValidationRuleText"	=> 1
  );

  %field_operation = (				# set field operations
    "ComposedNodeJoiningText"	=> "Set_Tree",
    "DictionaryFile"		=> "Set_Tree",
    "ComposedHeadings"		=> "Set_Tree",
    "GlobalMacros"		=> "Set_Tree",
    "IntroText"			=> "Set_Tree",
    "NeutralPoint"		=> "Set_Tree",
    "RequiresVersion"		=> "Set_Tree",
    "TreeName"			=> "Set_Tree",
    "TreeVariable"		=> "Add_Variable",
    "BoundVariable"		=> "Set_Node",
    "DocumentingText"		=> "Set_Node",
    "ExistsIf"			=> "Set_Node",
    "ID"			=> "New_Node",
    "InputType"			=> "Set_Node",
    "InstructionText"		=> "Set_Node",
    "JoiningText"		=> "Set_Node",
    "LongLabel"			=> "Set_Node",
    "ParentID"			=> "Add_Parent",
    "Payoff"			=> "Set_Node",
    "PrintIf"			=> "Set_Node",
    "Prob"			=> "Set_Node",
    "QuestionText"		=> "Set_Node",
    "RequiresVersion"		=> "Set_Tree",
    "ScaleIf"			=> "Set_Node",
    "ShortLabel"		=> "Set_Node",
    "Type"			=> "Set_Node",
    "UserText"			=> "Set_Node",
    "ValidationRule"		=> "Set_Node",
    "ValidationRuleText"	=> "Set_Node",
    "End"			=> "End"
  );

  %field_type = (				# set field types
    "ComposedNodeJoiningText"	=> "Tree",
    "DictionaryFile"		=> "Tree",
    "ComposedHeadings"		=> "Tree",
    "GlobalMacros"		=> "Tree",
    "IntroText"			=> "Tree",
    "NeutralPoint"		=> "Tree",
    "RequiresVersion"		=> "Tree",
    "TreeName"			=> "Tree",
    "TreeVariable"		=> "Tree",
    "BoundVariable"		=> "Node",
    "DocumentingText"		=> "Node",
    "ExistsIf"			=> "Node",
    "ID"			=> "Node",
    "InputType"			=> "Node",
    "InstructionText"		=> "Node",
    "JoiningText"		=> "Node",
    "LongLabel"			=> "Node",
    "ParentID"			=> "Node",
    "Payoff"			=> "Node",
    "PrintIf"			=> "Node",
    "Prob"			=> "Node",
    "QuestionText"		=> "Node",
    "ScaleIf"			=> "Node",
    "ShortLabel"		=> "Node",
    "Type"			=> "Node",
    "UserText"			=> "Node",
    "ValidationRule"		=> "Node",
    "ValidationRuleText"	=> "Node",
    "End"			=> "End"
  );
}

# return header for time/date on which script was invoked

sub make_header {
  my($header, $hour, $mday, $min, $mon, $rest,	# locals
    $sec, $year);

  ($sec, $min, $hour, $mday, $mon, $year, $rest) =  # get time
    localtime(time);
  $year += 1900;				# get proper year
  $header =					# generate header
    sprintf("generated by $prog on %02d:%02d:%02d %02d %s %04d",
      $hour, $min, $sec, $mday, $::months[$mon], $year);
  return($header);				# return generated header
}

# return a string with tabs replacing two or more spaces, assuming the
# original string has no tabs

sub make_tabs {
  my($string1) = @_;				# get string
  my($char, $i, $spaces, $string2);		# locals

  $string2 = "";				# initialise new string
  $spaces = -1;					# note as not space counting
  for ($i = length($string1) - 1; $i >= 0; $i--) { # go back through string
    $char = substr($string1,$i,1);		# get character
    if ($i % 8 == 7) {				# at eighth position?
      if ($spaces != -1) {			# counting spaces?
	$string2 .= "\t";			# append tab to new string
      }
      $spaces = 0;				# note as counting spaces
    }
    if ($spaces != -1) {			# counting spaces?
      if ($char eq " ") {			# at space character?
	$spaces++;				# increment space count
      }
      else {					# at non-space character
	if ($spaces == 1) {			# one space?
	  $string2 .= " ";			# append space to new string
	}
	elsif ($spaces > 1) {			# two or more spaces?
	  $string2 .= "\t";			# append tab to new string
	}
	$spaces = -1;				# note as not space counting
	$string2 .= $char;			# append character to new string
      }
    }
    else {					# not counting spaces
      $string2 .= $char;			# append character to new string
    }
  }
  if ($spaces == 1) {				# one space?
    $string2 .= " ";				# append space to new string
  }
  elsif ($spaces > 1) {				# two or more spaces?
    $string2 .= "\t";				# append tab to new string
  }
  return(reverse($string2));			# return reversed new string
}

# given a message, report note (i.e. informational message)

sub note {
  my($message) = @_;				# get note message
  my($program);					# locals

  if ($opt_e <= 1) {				# notes to be reported?
    $program = defined($prog) ? $prog : "";	# set program
    print STDERR "[Note] $program: $message\n";	# print message
  }
}

# given a message, report panic (i.e. internal error)

sub panic {
  my($message) = @_;				# get panic message
  my($program);					# locals

  if ($opt_e <= 3) {				# panics to be reported?
    $program = defined($prog) ? $prog : "";	# set program
    print STDERR "[Panic] $program: $message\n";# print message
  }
  $exit_code = 1;				# exit with result of 1
  &finalise;					# close down script
}

# given a file base name and suffix, parse tree format into structure in
# global $adit

sub parse_tree {
  my($base, $suffix) = @_;			# get file base name
  my($is_tag, $last_tag, %node_id, 		# locals
    $node_reference, $rest, $tag, $text_buffer, $tree_in, $value,
    $variable_name);

  if ($suffix) {				# suffix given?
    if ($suffix eq $tree_suffix) {		# tree suffix?
      $tree_in = "$base$suffix";		# set tree filename
    }
    else {					# not tree suffix
      &error("conversion can be performed only on '$tree_suffix' files");
      return;					# leave subroutine
    }
  }
  else {					# no suffix given
    $tree_in = "$base$tree_suffix";		# set tree filename
  }

  $adit = ADIT->new();
  $last_tag = "None";				# set no last tag
  if (open(TREE_IN, "< $tree_in")) {		# tree file opened?
    for ($_ = <TREE_IN>; ; $_ = <TREE_IN>) {	# read tree file line
      $is_tag = 0;
      if (!$_) {				# end of file?
	$_ = "End:";				# set "End" tag
      }
      chomp;					# remove trailing newline
      s/\*\/.*//;				# remove comments
      if (/^\s*(\w*):\s*(.*)$/o) {		# tag: field?
	$tag = $1;				# get tag
	$rest = $2;				# get field
	if (defined($field_type{$tag})) {	# recognised tag?
	  $is_tag = 1;				# note as tag
	  # first line of tag - store material from the previous tag
	  if ($last_tag ne "None") {
	    $text_buffer =~ s/\s*$//os;		# remove trailing whitespace
	    $_ = $field_operation{$last_tag};
	    SWITCH: {
	      /Add_Variable/ && do {		# handle TreeVariable field
		$text_buffer =~ s/\s*//g;	# remove all whitespace
		($variable_name, $value) = split /=/, $text_buffer;
		$adit->add_variable($variable_name, $value);
		last SWITCH;
	      };
	      /Set_Tree/ && do {		# handle rest of tree fields
		$adit->set_attribute($last_tag, $text_buffer);
		last SWITCH;
	      };
	      /New_Node/ && do {		# handle ID field
		$node_reference = Node->new($text_buffer);
		$node_id{$text_buffer} = $node_reference;
		if (!$adit->has_root) {		# first node in the tree
		  $adit->set_attribute("Root", $node_reference);
		}
		last SWITCH;
	      };
	      /Add_Parent/ && do {		# handle ParentID field
		if ($text_buffer ne "") {
		  if (!defined($node_id{$text_buffer})) {
		    die "Can't find parent \"$text_buffer\""; }
		  my $parent = $node_id{$text_buffer};
		  $parent->connect($node_reference);
		}
		last SWITCH;
	      };
	      /Set_Node/ && do {		# handle rest of node fields
		if ($text_buffer ne "") {
		  $node_reference->set_attribute($last_tag, $text_buffer);
		}
		last SWITCH;
	      };
	    }
	  }
	  $last_tag = $tag;			# set last tag
	  $text_buffer = $rest;			# set text so far
	}
	else {
	  &error("unrecognised tag '$tag'\n");
	}
      }
      if (!$is_tag) {				# this line is a continuation
	$text_buffer .= "\n$_";
      }
      if ($last_tag eq "End") {
	last;
      }
    }
    if (!close(TREE_IN)) {			# tree file not closed?
      &panic("could not close '$tree_in' - $!"); # report panic
    }
  }
  else {					# tree file not opened
    &error("could not read '$tree_in' - $!");	# report error
  }
}

# return a string in reverse order

sub reverse {
  my($string1) = @_;				# get string
  my($i, $string2);				# locals

  $string2 = "";				# initialise new string
  for ($i = length($string1) - 1; $i >= 0; $i--) { # go back through string
    $string2 .= substr($string1,$i,1);		# append character to new string
  }
  return($string2);				# return new string
}

# run command, reporting any error

sub run {
  my($command) = @_;				# get command
  my($code);					# locals

  &diagnostic("running \"$command\"");		# report progress
  $code = system($command);			# run command
  if ($code) {					# command failed?
    &error("failure running '$command'");	# report error
  }
  return($code);				# return exit code
}

# handle signal given as parameter

sub signal_handler {
  print STDERR "$prog: abandoned\n";		# report abandoned
  $exit_code = 1;				# exit with result of 1
  &finalise;					# close down script
}

# return string context, +/- 30 characters for given position and string

sub string_context {
  my($i, $string) = @_;				# get index and string
  my($length);					# locals

  $length = length($string);			# get string length
  $start = $i - $context_size;			# go back in string
  if ($start < 0) {				# before start of string?
    $start = 0;					# set start of string
  }
  $finish = $i + $context_size;			# go forward in string
  if ($finish > $length) {			# beyond finish of string?
    $finish = $length;				# set end of string
  }
  return(substr($string, $start, $finish - $start)); # return context string
}

# return original text with leading and trailing white space removed

sub trim {
  my($text) = @_;				# get text

  $text =~ s/^\s+//o;				# removing leading white space
  $text =~ s/\s+$//o;				# removing trailing white space
  return($text);				# return new text
}

# print script usage

sub usage {
  print STDERR "$prog (version $adit_copyright)\n";
  print STDERR "  -h          " .
    "help on parameters\n";
  print STDERR "|\n";
  print STDERR "  [-c]        " .
    "convert to ADIT (e.g. file.tree to file.adit)\n";
  print STDERR "  [-e level]  " .
    "error level: 0 all, 1 notes (default), 2 errors, 3 panics\n";
  print STDERR "  [-g level]  " .
    "gate hiding: 0 hide/back (default), 1 i/back, 2 hide, 3 i [for -l]\n";
  print STDERR "  [-i indent] " .
    "indentation level as number of spaces (default 2)\n";
  print STDERR "  [-l]        " .
    "convert to LOTOS (e.g. file.adit to file.lot)\n";
  print STDERR "  [-t]        " .
    "convert to tree (e.g. file.adit to file.tree)\n";
  print STDERR "  [-w width]  " .
    "line width as number of characters (default 80) [for -l]\n";
  print STDERR "  [-x]        " .
    "convert to XML (e.g. file.tree to file.xml)\n";
  print STDERR "file ...      " .
    "files to process (suffix $adit_suffix, $lotos_suffix, $tree_suffix, " .
    "$xml_suffix)\n";
  exit(1);
}

# given an input file base name and suffix, write ADIT for parsed structure in
# global $adit

sub write_adit {
  my($base, $suffix) = @_;			# get file base name and suffix
  my($adit_out);				# locals

  $adit_out = "$base$adit_suffix";		# set ADIT filename
  if (open(ADIT_OUT, "> $adit_out")) {		# ADIT file opened?
    $adit->write_adit(\*ADIT_OUT);		# write ADIT representation
    if (!close(ADIT_OUT)) {			# tree file not closed?
      &panic("could not close '$adit_out' - $!"); # report panic
    }
  }
  else {					# ADIT file not opened
    &error("could not write '$adit_out' - $!");	# report error
  }
}

# given an input file base name and suffix, write LOTOS for parsed structure in
# global $cgt

sub write_lotos {
  my($base, $suffix) = @_;			# get file base name and suffix
  my($adit_in, $behaviour, $comment, $lotos_out,	# locals
    $spaces);

  if ($suffix) {				# suffix given?
    if ($suffix eq $adit_suffix) {		# ADIT suffix?
      $adit_in = "$base$suffix";			# set ADIT filename
    }
    else {					# not ADIT suffix
      &error("conversion can be performed only on '$adit_suffix' files");
      return;					# leave subroutine
    }
  }
  else {					# no suffix given
    $adit_in = "$base$adit_suffix";		# set ADIT filename
  }
  $lotos_out = "$base$lotos_suffix";		# set LOTOS filename
  $m4_in = "$tmp_dir/$prog${$}$m4_suffix";	# set M4 input file
  $m4_out = "$tmp_dir/$prog${$}$tree_suffix";	# set M4 output file
  if (open(M4_IN, "> $m4_in")) {		# M4 input file opened?
    print M4_IN "divert(-1)\n";			# divert output
    print M4_IN "include(adit_lotos$m4_suffix)\n"; # include ADIT LOTOS macros
    if (open(ADIT_IN, "< $adit_in")) {		# ADIT file opened?
      while (<ADIT_IN>) {			# read ADIT lines
	s/\s*\/\/.*//o;				# remove comment
	print M4_IN $_;				# write ADIT line to M4 file
      }
      if (!close(ADIT_IN)) {			# ADIT file not closed?
	&panic("could not close '$adit_in' - $!"); # report panic
      }
    }
    else {					# ADIT file not opened
      &panic("could not read '$adit_in' - $!");# report error
    }
    if (!close(M4_IN)) {			# M4 input file not closed?
      &panic("could not close '$m4_in' - $!");	# report panic
    }
    $definitions =				# set M4 definitions
      "-D adit_debug=$adit_debug -D adit_gate=$adit_gate " .
      "-D adit_indent=$adit_indent -D adit_prefix=$adit_prefix";
    $command = "$m4 $definitions '$m4_in' > '$m4_out'"; # M4 command to convert
    if (&run($command)) {			# M4 call failed?
      &error("M4 run not completed");		# report failure
    }
    else {					# M4 call succeeded
      if (unlink($m4_in) != 1) {		# M4 input file not removed?
	&panic("could not delete '$m4_in' - $!"); # report panic
      }
      if (open(M4_OUT, "< $m4_out")) {		# M4 output file opened?
	$empty = 1;				# pretend last line empty
	if (open(LOTOS_OUT, "> $lotos_out")) {	# LOTOS file opened?
	  print LOTOS_OUT "(* $lotos_out " . &make_header . " *)\n\n";;
	  while (<M4_OUT>) {			# read M4 output line
	    chomp;				# remove trailing newline
	    $behaviour = $_;			# get behaviour
	    $behaviour =~ s/^\s+$//o;		# make a blank line empty
	    if ($behaviour) {			# M4 line is non-empty?
	      $empty = 0;			# set last line not empty
	      if ($behaviour =~			# comment found?
		    /(.*?)\s+(\(\*.+\*\))/o) {
		$behaviour = $1;		# get behaviour
		$comment = $2;			# get comment
		$behaviour =~ s/\t/        /go;	# tabs to spaces
		$spaces =			# compute spaces between
		  $opt_w - length($behaviour) - length($comment);
		if ($spaces >= 0) {		# spaces between?
		    $behaviour .=		# insert spaces before comment
		      (" " x $spaces) . $comment
		  }
		  else {			# no room for spaces
		    print LOTOS_OUT "$behaviour\n"; # write behaviour to LOTOS
		    $spaces =			# compute spaces before comment
		      $opt_w - length($comment);
		    $behaviour =		# set spaced comment
		      (" " x $spaces) . $comment;
		  }
	      }
	      $behaviour =			# make tabs from spaces
		&make_tabs($behaviour) . "\n";
	      print LOTOS_OUT $behaviour;	# write M4 line to LOTOS
	    }
	    elsif (!$empty) {			# last was non_empty line?
	      $empty = 1;			# set last line empty
	      print LOTOS_OUT "\n";		# write empty line to tree file
	    }
	  }
	  if (!close(LOTOS_OUT)) {		# LOTOS file not closed?
	    &panic("could not close '$lotos_out' - $!"); # report panic
	  }
	}
	else {					# LOTOS file not opened
	  &error("could not write '$lotos_out' - $!"); # report error
	}
	if (!close(M4_OUT)) {			# M4 output file not closed?
	  &panic("could not close '$m4_out' - $!"); # report panic
	}
	if (unlink($m4_out) != 1) {		# M4 output file not removed?
	  &panic("could not delete '$m4_out' - $!"); # report panic
	}
      }
      else {					# M4 output file not opened
	&error("could not read '$m4_out' - $!");# report error
      }
    }
  }
  else {					# M4 file not opened
    &error("could not write '$m4_in' - $!");	# report error
  }
}

# given an input file base name and suffix, write tree for parsed structure in
# global $cgt

sub write_tree {
  my($base, $suffix) = @_;			# get file base name and suffix
  my($adit_in, $command, $definitions, $empty, 	# locals
    $m4_in, $m4_out, $tree_out);

  if ($suffix) {				# suffix given?
    if ($suffix eq $adit_suffix) {		# ADIT suffix?
      $adit_in = "$base$suffix";		# set ADIT filename
    }
    elsif ($suffix eq $xml_suffix) {		# XML suffix?
      &error("sorry, conversion not yet implemented for '$xml_suffix' files");
      return;					# leave subroutine
    }
    else {					# not ADIT suffix?
      &error("conversion can be performed only on '$adit_suffix' files");
      return;					# leave subroutine
    }
  }
  else {					# no suffix given
    $adit_in = "$base$adit_suffix";		# set ADIT filename
  }
  $tree_out = "$base$tree_suffix";		# set tree filename
  $m4_in = "$tmp_dir/$prog${$}$m4_suffix";	# set M4 input file
  $m4_out = "$tmp_dir/$prog${$}$tree_suffix";	# set M4 output file
  if (open(M4_IN, "> $m4_in")) {		# M4 input file opened?
    print M4_IN "divert(-1)\n";			# divert output
    print M4_IN "include(adit_tree$m4_suffix)\n"; # include ADIT tree macros
    if (open(ADIT_IN, "< $adit_in")) {		# ADIT file opened?
      while (<ADIT_IN>) {			# read ADIT lines
	s/\s*\/\/\s.*//o;			# remove comment
	print M4_IN $_;				# write ADIT line to M4 file
      }
      if (!close(ADIT_IN)) {			# ADIT file not closed?
	&panic("could not close '$adit_in' - $!"); # report panic
      }
    }
    else {					# ADIT file not opened
      &error("could not read '$adit_in' - $!");# report error
    }
    if (!close(M4_IN)) {			# M4 input file not closed?
      &panic("could not close '$m4_in' - $!");	# report panic
    }
    $definitions =				# set M4 definitions
      "-D adit_indent=$adit_indent -D adit_prefix=$adit_prefix";
    $command = "$m4 $definitions '$m4_in' > '$m4_out'"; # M4 command to convert
    if (&run($command)) {			# M4 call failed?
      &error("M4 run not completed");		# report failure
    }
    else {					# M4 call succeeded
      if (unlink($m4_in) != 1) {		# M4 input file not removed?
	&panic("could not delete '$m4_in' - $!"); # report panic
      }
      if (open(M4_OUT, "< $m4_out")) {		# M4 output file opened?
	$empty = 1;				# pretend last line empty
	if (open(TREE_OUT, "> $tree_out")) {	# tree file opened?
	  print TREE_OUT "*/ $tree_out " . &make_header . "\n\n";;
	  while (<M4_OUT>) {			# read M4 output line
	    chomp;				# remove trailing newline
	    s/^\s+$//o;				# make blank line empty
	    if ($_) {				# M4 line is non-empty?
	      $empty = 0;			# set last line not empty
	      print TREE_OUT "$_\n";		# write M4 line to tree file
	    }
	    elsif (!$empty) {			# last was non_empty line?
	      $empty = 1;			# set last line empty
	      print TREE_OUT "\n";		# write empty line to tree file
	    }
	  }
	  if (!close(TREE_OUT)) {		# tree file not closed?
	    &panic("could not close '$tree_out' - $!"); # report panic
	  }
	}
	else {					# tree file not opened
	  &error("could not write '$tree_out' - $!"); # report error
	}
	if (!close(M4_OUT)) {			# M4 output file not closed?
	  &panic("could not close '$m4_out' - $!"); # report panic
	}
	if (unlink($m4_out) != 1) {		# M4 output file not removed?
	  &panic("could not delete '$m4_out' - $!"); # report panic
	}
      }
      else {					# M4 output file not opened
	&error("could not read '$m4_out' - $!");# report error
      }
    }
  }
  else {					# M4 file not opened
    &error("could not write '$m4_in' - $!");	# report error
  }


}

# given an input file base name and suffix, write XML for parsed structure in
# global $cgt

sub write_xml {
  my($base, $suffix) = @_;			# get file base name and suffix
  my($xml_out);					# locals

  $xml_out = "$base$xml_suffix";		# set XML filename
  if (open(XML_OUT, "> $xml_out")) {		# XML file opened?
    $adit->write_xml(\*XML_OUT);		# write XML representation
    if (!close(XML_OUT)) {			# tree file not closed?
      &panic("could not close '$xml_out' - $!"); # report panic
    }
  }
  else {					# XML file not opened
    &error("could not write '$xml_out' - $!");	# report error
  }
}

######################### Clinical Guidance Tree #########################

package ADIT;

require Exporter;

our @ISA = qw(Exporter);
our @EXPORT = qw();
our @EXPORT_OK = qw();
our $VERSION = $::adit_version;

use FileHandle;					# filehandles
use strict;					# strict variable naming

use fields (					# tree node variables
  "ComposedNodeJoiningText",			# string
  "ComposedHeadings",				# string ("yes" or "no")
  "DictionaryFile",				# string (a filename)
  "GlobalMacros",				# string containing McDefines
  "IntroText",					# string containing HTML
  "NeutralPoint",				# string (a number 0-100)
  "RequiresVersion",				# string (a decimal number)
  "TreeName",					# string
  "TreeVariables",				# reference to hash (name/value)
  "Root"					# reference to the root node
);

# class constructor
# usage: $cgt = ADIT->new;

sub new {
  my $class = shift;				# first arg is name of class
  my $self = fields::new(ref $class || $class);
  bless $self, $class;				# mark object as from this class
  $self->{TreeVariables} = {};			# empty hash
  return $self;					# return reference to new object
}

# add a tree variable
# usage: $adit->add_variable($name, $value)

sub add_variable {
  my $self = shift;
  my $name = shift;
  my $value = shift;

  if (!defined($value)) {
    $value = "NaN";
  }
  $self->{TreeVariables}->{$name} = $value;
}

# class method returning version number as a string (e.g. 1.0)
# usage: $v = ADIT->get_version

sub get_version {
  return $VERSION;
}

# return true if tree has root node installed
# usage: $adit->has_root

sub has_root {
  my $self = shift;
  return $self->{Root};
}

# set an attribute
# usage: $adit->set_attribute($name, $value)

sub set_attribute {
  my $self = shift;
  my $name = shift;
  my $value = shift;
  $self->{$name} = $value;
}

# build and output the ADIT version, accumulating macro information in
# global $macros and node information in global $nodes
# usage: $adit->write_cgt($fileHandle)

sub write_cgt {
  my $self = shift;
  my $file_handle = shift;
  my($attribute, $attributes, $declarations,	# locals
    $id, $label, $node, $tag, $type, $value, @variable, $variable,
    $variables);

  $::macros = 					# intiailise macros
    "${main::adit_prefix}comment(" . &::make_header . ")\n\n";
  $::nodes = "";				# initialise nodes

  # append tree description
  $type = "tree";				# set node type
  $id = &::clean_identifier($self->{TreeName});	# set node identifier
  $label = $id;					# set node short label (unused)
  $attributes = "";				# initialise local attributes
  foreach $tag (				# go through fields
      "RequiresVersion", "DictionaryFile", "NeutralPoint", "ComposedHeadings",
      "ComposedNodeJoiningText", "IntroText", "GlobalMacros") {
    $value = $self->{$tag};			# get tag value
    $attribute = $::field_attribute{$tag};	# set attribute name
    if (defined($attribute) && defined($value)) { # attribute and value defined?
      if ($attributes) {			# attributes non empty?
	$attributes .= " ";			# append space
      }
      if ($::field_macro{$tag} ||		# attribute uses macro or
	  length($value) > $::attribute_size) {	# attribute too long?
	$value = &::clean_value($value);	# clean up value
	$::macros .=				# append attribute macro
"${main::adit_prefix}text(${id}_\u$attribute, $value)

";
	$attributes .= $attribute;		# append attribute name
      }
      else {					# attribute is literal
	$value = &::clean_attribute($value);	# clean up value
	$attributes .= "$attribute=\"$value\"";	# append attribute value
      }
    }
  }
  $variables = $self->{TreeVariables};		# get tree variables reference
  @variable =					# get tree variables
    defined($variables) ? sort(keys(%{$variables})) : ();
  if (@variable) {				# tree has variables?
    $declarations = "";				# start variable declarations
    foreach $variable (@variable) {		# go through variables
      $value = $variables->{$variable};		# get variable value
      if ($value ne "NaN") {			# value defined?
	&::check_initialisation($variable, $value); # check initialisation value
	$declarations .= "\n  $variable, $value,"; # append variable declaration
      }
      else {					# value undefined
	$declarations .= "\n  $variable, ,";	# append variable declaration
      }
    }
    $::macros .=				# append attribute macro
"${main::adit_prefix}text(${id}_Variables," .
"${main::adit_prefix}declare($declarations))

";
    if ($attributes) {				# attributes non empty?
      $attributes .= " ";			# append space
    }
    $attributes .= "variables";			# append attribute name
  }
  $node = 					# set node description
    "${main::adit_prefix}$type($id, $label, $attributes";
  $::nodes .= "$node,";				# append node description

  # append children descriptions
  $node = $self->{Root};			# get root node
  $node->write_cgt(1, $file_handle);		# write children of root node
  $::nodes .= ")\n";				# append closing parenthesis

  # output accumulated macros and node descriptions
  print $file_handle $::macros;			# output macros
  print $file_handle $::nodes;			# output nodes
}

# build and output the XML version
# usage: $adit->write_xml($fileHandle)

sub write_xml {
  my $self = shift;
  my $file_handle = shift;
  my($tag, $value, $variable);

  print $file_handle "<?xml $::xml_version?>\n\n";
  print $file_handle "<!-- " . &::make_header . " -->\n\n";
  print $file_handle "<cgtTree";
  foreach $tag (
    "TreeName", "RequiresVersion", "DictionaryFile", "NeutralPoint",
    "ComposedHeadings", "ComposedNodeJoiningText") {
    if (defined($self->{$tag})) {
      my $s = $self->{$tag};
      print $file_handle "\n    $tag=\"$s\"";
    }
  }
  print $file_handle "\>\n";
  foreach $tag ("IntroText", "GlobalMacros") {
    if (defined($self->{$tag})) {
      my $s = $self->{$tag};
      print $file_handle "  <$tag>\n";
      print $file_handle "    <![CDATA[$s]]>\n";
      print $file_handle "  </$tag>\n";
    }
  }
  foreach $variable (sort keys %{$self->{TreeVariables}}) {
    print $file_handle "  <TreeVariable name=\"$variable\"";
    $value = $self->{TreeVariables}->{$variable};
    if ($value ne "NaN") {
      &::check_initialisation($variable, $value); # check initialisation value
      print $file_handle " value=\"$value\"";
    }
    print $file_handle "/>\n";
  }
  # now the nodes
  my $root = $self->{Root};
  $root->write_xml(1, $file_handle);
  print $file_handle "</cgtTree>\n";
}

######################### Clinical Guidance Tree Node #########################

package Node;

require Exporter;

our @ISA = qw(Exporter);
our @EXPORT = qw();
our @EXPORT_OK = qw();
our $VERSION = $::adit_version;

use strict;					# strict variable naming

use fields (					# tree node variables
  "Children",					# list of references
  "BoundVariable",				# string
  "DocumentingText",				# string
  "ExistsIf",					# string
  "ID",						# string
  "InputType",					# string
  "InstructionText",				# string
  "JoiningText",				# string
  "LongLabel",					# string
  "Payoff",					# string
  "PrintIf",					# string
  "Prob",					# string
  "QuestionText",				# string
  "ScaleIf",					# string
  "ShortLabel",					# string
  "Type",					# string
  "UserText",					# string
  "ValidationRule",				# string
  "ValidationRuleText"				# string
);

# class constructor
# usage: $node = Node->new($id)

sub new {
  my $class = shift;				# first arg is name of class
  my $self = fields::new(ref $class || $class);
  my $id = shift;

  bless $self, $class;				# mark object as from this class
  $self->{Children} = ();			# empty list
  $self->{ID} = $id;
  return $self;					# return reference to new object
}

# connect a child to this node
# usage: $adit->connect($child)

sub connect {
  my $self = shift;
  my $child = shift;
  push @{$self->{Children}}, $child;
}

# get an attribute
# usage: $node->get_attribute($name)

sub get_attribute {
  my $self = shift;
  my $name = shift;
  return $self->{$name};
}

# class method returning version number as a string (e.g. 1.0)
# usage: $v = ADIT->get_version

sub get_version {
  return $VERSION;
}

# set an attribute
# usage: $node->set_attribute($name, $value)

sub set_attribute {
  my $self = shift;
  my $name = shift;
  my $value = shift;

  $self->{$name} = $value;
}

# build the ADIT version, accumulating macro information in global $macros
# and node information in global $nodes (file handle unused)
# usage: $node->write_cgt($indent, $filehandle)

sub write_cgt {
  my $self = shift;
  my $indent = shift;
  my $file_handle = shift;
  my($attribute, $attributes, $child, @children,# locals
    $children, $i, $id, $label, $node, $spaces, $tag, $type, $value);

  # append node description
  $type = lc($self->{Type});			# set node type in lower case
  $id = &::clean_identifier($self->{ID});	# set node identifier
  $label = &::clean_label($self->{ShortLabel});	# set node short label
  $attributes = "";				# initialise local attributes
  $spaces = $::adit_spaces x $indent;		# set node indentation
  foreach $tag (				# go through fields
      "LongLabel", "ExistsIf", "UserText", "InstructionText", "QuestionText",
      "BoundVariable", "InputType", "ValidationRule", "ValidationRuleText",
      "Payoff", "Prob", "PrintIf", "ScaleIf", "DocumentingText",
      "JoiningText") {
    $value = $self->{$tag};			# get tag value
    $attribute = $::field_attribute{$tag};	# set attribute name
    if (defined($attribute) && defined($value)) { # attribute and value defined?
      if ($attributes) {			# attributes non empty?
	$attributes .= " ";			# append space
      }
      if ($::field_macro{$tag} ||		# attribute uses macro or
	  length($value) > $::attribute_size) {	# attribute too long?
	$value = &::clean_value($value);	# clean up value
	$::macros .=				# append attribute macro
"${main::adit_prefix}text(${id}_\u$attribute, $value)

";
	$attributes .= $attribute;		# append attribute name
      }
      else {					# attribute is literal
	$value = &::clean_attribute($value);	# clean up value
	$attributes .= "$attribute=\"$value\"";	# append attribute value
      }
    }
  }

  # append children descriptions
  $children = $self->{Children};		# get children reference
  @children = 					# set children list
    defined($children) ? @{$children} : ();
  $children = $#children;			# set children count
  $node = 					# set node description
    "\n$spaces${main::adit_prefix}$type($id, $label, $attributes";
  $::nodes .= @children ? "$node," : $node;	# append node description

  for ($i = 0; $i <= $children; $i++) {		# go through children
    $child = $children[$i];			# set child
    $child->write_cgt($indent+1, $file_handle);	# write child description
    if ($i != $children) {			# not last child?
      $::nodes .= ",";				# append separating comma
    }
  }
  $::nodes .= ")";				# append trailing parenthesis
}

# build and output the XML version
# usage: $node->write_xml($indent, $filehandle)

sub write_xml {
  my $self = shift;
  my $indent = shift;
  my $file_handle = shift;
  my($child, @children, $children, $id, $spaces,# locals
    $tag, $type, $value);

  # output node
  $type = $self->{Type};			# set node type
  $id = $self->{ID};				# set node identifier
  $spaces = $::adit_spaces x $indent;		# set node indentation
  print $file_handle "$spaces<$type ID=\"$id\"";
  foreach $tag ("ShortLabel", "LongLabel", "BoundVariable", "InputType") {
    if (defined($self->{$tag})) {
      $value = $self->{$tag};
      print $file_handle "\n$spaces    $tag=\"$value\"";
    }
  }
  print $file_handle "\>\n";
  foreach $tag (
    "ExistsIf", "PrintIf", "ScaleIf", "UserText", "InstructionText",
    "DocumentingText", "JoiningText", "QuestionText", "ValidationRule",
    "Payoff", "Prob", "ValidationRuleText") {
    if (defined($self->{$tag})) {
      $value = $self->{$tag};
      print $file_handle "$spaces  <$tag>\n";
      print $file_handle "$spaces    <![CDATA[$value]]>\n";
      print $file_handle "$spaces  </$tag>\n";
    }
  }

  # recursively serialise the children of this node
  $children = $self->{Children};		# get children reference
  @children = 					# set children list
    defined($children) ? @{$children} : ();
  foreach $child (@children) {			# go through children
    $child->write_xml($indent+1, $file_handle);	# write child XML
  }
  print $file_handle "$spaces</$type>\n";
}