#!/usr/bin/perl 
#use warnings;
use strict;
use Data::Dumper;
my $file = "sequence.ama";
my $string = get_file($file);
my $still_alive = 1000;
my @C = get_chromosome($string);
my @R = qw//;
wrapper(0,$still_alive);


sub get_file{
	my $infile  =  shift;
	my $string;
	open (my $fh, "<", $infile) or die "nopen $infile, $!";
	while (<$fh>){
		chomp;
		s/:.*//;	#comments
		s/(\d)\s/$1,/g;  #space to comma
		s/(\d);/$1,;/g; # forgottn comma before ;
		s/\s//g;	#get rid of space
		s/,,+/,/g;	#get rid of duplicate commas
		$string .= $_
	}
	return  $string;
}

sub output{
	for (@R){
		print "$_  ";
	}
}
sub finish{
	my $message = shift;
	print "$message \nthe end. let's print output:\n";
	output (\@R);
	die

}
sub deathcount{
	$still_alive--;
	finish ("counted down\n") unless ($still_alive);
}

sub get_chromosome{
	my $Genome = shift;#string
	my @C = 
	 map {
	 [
	  
	  map{
	  [
	   /(\d+),/g	# the parens excise the commas
	  
	   ]
	   }
	   /\d+,\d+,\d+,/g
	    ]
	   
   	} split /;/, $Genome;
	
	
	for (@C){
		if ($#$_ > 1) {
			unless ($#$_ % 2){	
				splice @$_, -1, 1
			}
	
		}
	
	
	}
	@C # @C[gene[codon[base,base,base]]]
}

sub wrapper{
	my $ptr = shift; #genome pointer
	my $dead_count = shift; #max iterations before death
	my $i = $dead_count + 1; #iterator for top level call() 


	while (1) {
		$ptr = call ($ptr, $i); 
			
		#ptr is changed to call()'s return value if we 
		#ever get to this point
	}
}

sub call{
	my $ptr = shift;
	my $i = shift;
	my $alt_ptr = -1;
	for (1 .. $i){

		deathcount(); #count down to process death
		my @g = map { [@$_] }@{$C[$ptr]}; #gene
		my $call = shift $g[0]; #1st base of 1st codon
		my $modcall = $call % 2;
		($call % 2)?($alt_ptr = MOV(\@g,$ptr)):(MOD(\@g));
		(return $alt_ptr) if ($alt_ptr >= 0);
		$ptr == $#C ? $ptr = 0 : $ptr++;#circular chromosome
	}
	
	return $alt_ptr;
	#if alt_ptr >= 0
	#alt_ptr is used to reset ptr permanently.
	#the recursive calls to call() are unwound in favor of alt_ptr
}

sub MOD{
	my $g = shift; #gene
	my ($loc,$reftype) = @{(shift @$g)};
	my @ops = qw/+ - * \/ ** %/;
	$loc = abs($loc);
	$loc = $R[$loc] if ($reftype%2);
	$loc = 0 unless $loc;
	$R[$loc] = expression_processor($g,\@ops);
}

sub MOV{
	my $g = shift;
	my $ptr = shift; #needed to check for infi-loop
	my @ops = qw/== > < >= <= != and or not xor/;
	my ($loc,$i) = @{(shift @$g)};
	$loc = abs $loc;
	$loc = 0 if $loc > $#C;
	$i = abs $i;
	
	if (expression_processor($g, \@ops)){
		(finish ("pointer collision")) if ($loc == $ptr);
		return $loc unless $i;
		return call($loc,$i);
	}
	return -1

}

sub filter_v_or_o{
	my ($v,$o,$total_bits,$orig) = @_;

	(return 0) if ($v-1 <= $o);
	(return 1) if ($v >= ($total_bits / 2));
	return ($orig % 2)


}

sub expression_processor{ #build a polish notation expression from triplets.
	
	my $g = shift; #gene
	my $ops = shift; #operators
	my ($v,$o) = 0; #init counting vars
	my $total_bits = $#$g;
	my @expression;
	while (@$g){
		my ($v_or_o, $data, $ref_type) = @{(shift @$g)};
		$v_or_o = filter_v_or_o($v,$o,$total_bits,$v_or_o);
		$ref_type = ($ref_type % 3);
		($data = $R[abs($data)]) if ($ref_type == 1);
		($data = $R[$R[abs($data)]]) if ($ref_type == 2);
		$data = 0 unless $data;
		($data = $ops->[$data % ($#$ops +1)]) if ($v_or_o);
		($v_or_o)?($o++):($v++);
		unshift @expression, $data;
	}
	return solve(\@expression)
}

sub solve{
	my $exp = shift;
	#print "this is the expression:";
	#print Dumper $exp;
	#sleep 1;
	my $a = shift @$exp;
	($a=~/\d/)?
	 (return $a) :
	 ($a = eval(solve($exp) . " $a " . solve($exp)));

	(finish("termination with n/0\n")) if ($@=~ /Illegal/);
	return $a;
  }