File Coverage

blib/lib/Quantum/Entanglement.pm

Criterion	Covered	Total	%
statement	231	563	41.0
branch	30	102	29.4
condition	4	36	11.1
subroutine	31	75	41.3
pod	7	17	41.1
total	303	793	38.2

package Quantum::Entanglement;
use strict;
use warnings;
use Carp;

BEGIN {
  use Exporter   ();
  use Math::Complex;
  my @M_Complex = qw(i Re Im rho theta arg cplx cplxe);
  our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
  $VERSION     = 0.32;
  @ISA         = qw(Exporter);
  @EXPORT      = qw(&entangle &p_op &p_func &q_logic
		    &save_state &restore_state);
  %EXPORT_TAGS = (DEFAULT => [@EXPORT],
		  complex => [@M_Complex],
		  QFT => [qw(&QFT)],);
  @EXPORT_OK   = (@M_Complex, '&QFT');
}
our (@EXPORT_OK, @EXPORT);

$Quantum::Entanglement::destroy = 1; # true=> p(0) states stomped on
$Quantum::Entanglement::conform = 0; # true=> strives for truth when observing

## Contents:
# Constructors
# Utility Routines
# Overload table
# Overload routines
# parallel operators and functions
# methods for saving and restoring state
# pod

# =begin pretty pictures
#
# Things look a bit like this...
#
# $variable = [ref to var which itself refs to an annon array (the universe),
#	       offset of values of variable within universe,
#	       ref to var which itself refs to an annon array (the offsets)];
#
# $offsets =  [refs to all the offsets in a given universe, ...]
# $universe=  [ [prob1,val1,prob2,val2],
#	        [prob1,val1,prob2,val2], etc. ]
#
# =cut

# creates a new set of universes
sub _new {
  my $universe = [];
  my $offsets = [];
  my $var = [\$universe,1,\$offsets];
  $offsets->[0] = \ $var->[1];
  while (@_) {
    push @$universe, [shift,shift];
  }
  bless $var, 'Quantum::Entanglement';
  return $var;
}

# add a variable without adding values (ie. a derived value)
# returns the new variable
sub _add {
  my $current = $_[0];
  my $universe = ${ $current->[0]};
  my $offset = scalar(@{$universe->[0]}) + 1;
  my $var= [\$universe,$offset,\ ${$current->[2]}];
  push @{${$current->[2]}} , \$var->[1];
  bless $var, 'Quantum::Entanglement';
  return $var;
}

# joins together two previously unconnected universes
# takes two variables as args, gets the universes from those.
# should be used to modify objects in place.
sub _join {
  my ($uni1,$uni2) = (${$_[0]->[0]},${$_[1]->[0]});
  return () if $uni1 == $uni2;
  my $universe = [];
  foreach my $s2 (@$uni2) {
    foreach my $s1 (@$uni1) {
      push @$universe, [@$s1,@$s2];
    }
  }
  my $offsets1 = ${$_[0]->[2]};
  my $offsets2 = ${$_[1]->[2]};
  my $extra = scalar(@{$uni1->[0]});
  push @$offsets1, map {$$_+=$extra; $_} @$offsets2;
  ${$_[1]->[2]} = $offsets1;
  ${$_[0]->[0]} = $universe;
  ${$_[1]->[0]} = $universe;
  return (1);
}

# exported constructor
sub entangle {
  return _new(@_);
}

## Utility routines

# a view of global state space, might still show historical states which
# are no longer accessable, does not count as observation
sub show_states {
  my $rt;
  my $var = shift;
  my $universe = ${$var->[0]};
  if ($_[0]) {
    foreach (@$universe) { my $t;
      $rt .= (++$t % 2) ? "$_|" : overload::StrVal($_).">\t" foreach @$_;
      $rt .= "\n";
    }
  }
  else {
    my $os = $var->[1];
    $rt .= $_->[$os-1]."|".overload::StrVal($_->[$os]).">\t"
      foreach @$universe;
    substr($rt,-1,1,"\n");
  }
  return $rt;
}

# egads! (and don't tell anyone about the grep, it's a secret)
sub DESTROY {
  my ($universe, $offsets) = (${$_[0]->[0]}, ${$_[0]->[2]});
  my $os = $_[0]->[1];
  splice(@$_,$os-1,2) foreach @$universe;
  @$offsets = grep {if ($$_ != $os) {$$_ -= 2 if $$_ > $os;1;} else {0;}}
               @$offsets;
  _rationalise_states([\$universe])
          if $Quantum::Entanglement::destroy;
}

# takes two non normalised probabilities and returns true with prob(1/1+2)
sub _sel_output {
  my ($c, $d) = @_;
  $c = abs($c)**2;
  $d = abs($d)**2;
  return rand(1) < ($c/($c+$d)) ? 1 : 0;
}

# Gets a ref to a hash of complex probs, produces ref to hash of sequential
# probs and ref to array of ordering.
sub _normalise {
  my $hr = $_[0];
  my $h2 = {};
  my $muts = [keys %{$hr}];
  my $sum = 0;
  foreach (values %{$hr}) {
    $sum += abs($_)**2;
  }
  if ($sum <= 0) {
    croak "$0: Cannot behave probabilistically with -ve probs";
  }
  else {
    my $cum;
    @{$h2}{ @{$muts} } = map {$cum +=abs($_)**2;
			      $cum / $sum       } @{$hr}{ @{$muts} };
    return ($h2, $muts);
  }
}

# this builds up a multi-layered hash so as to find the unique sets of
# states, it then uses _unravel to get them back out of the hash
sub _rationalise_states {
  my $universe = ${$_[0]->[0]};
  my $len = scalar(@{$universe->[0]})/2;
  my @p_os = map {$_*2  } (0..$len-1);
  my @v_os = map {$_*2+1} (0..$len-1);
  my $foo = {};
  foreach my $state (@$universe) { # build an icky data structure
    my $tref = $foo;
    foreach (@v_os) {
      my $val = ref($state->[$_]) ? overload::StrVal($state->[$_])
	                          : $state->[$_];
      if ($_==2*$len-1) { # last level of the structure
	if (exists $tref->{$val}) {
	  my @temp = @{$state}[@p_os];
	  $_+=shift @temp foreach @{$tref->{$val}}[@p_os];
	}
	else {
	  $tref->{$val} = [@{$state}];
	}
      }
      else { # an intermediate level
	if (exists $tref->{$val}) {
	  $tref = $tref->{$val};
	}
	else {
	  $tref = $tref->{$val} = {};
	}
      }
    }
  }
  # do something with it...
  @$universe =();
  while (1) {
    my $aref = _unravel($foo);
    last unless $aref;
    push @$universe, $aref;
  }
  return $universe;
}

sub _unravel {
  my $tref = $_[0];
  return undef unless (scalar keys %$tref);
  my @hrs;
  my($last_ref, $val);
  do {
    $last_ref = $tref;
    ($val,$tref) = %$tref;
    unshift @hrs, $val, $last_ref;
  } until (ref($tref) eq 'ARRAY');
  delete ${$last_ref}{$val};
  splice @hrs, 0,2;
  while (@hrs) {
    my $val = shift @hrs;
    my $h = shift @hrs;
    delete ${$h}{$val} if scalar(keys %{${$h}{$val}}) < 1;
  }
  return $tref;
}


##
# Overloading.  Everything except for assignment operators
# are overloaded specifically.  Need to specifically overload a lot
# of stuff so that pruning of states can happen as soon as poss

use overload
  '+'  => sub { binop(@_, sub{$_[0] + $_[1]} ) },
  '*'  => sub { binop(@_, sub{$_[0] * $_[1]} ) },
  '-'  => sub { binop(@_, sub{$_[0] - $_[1]} ) },
  '/'  => sub { binop(@_, sub{$_[0] / $_[1]} ) },
  '**' => sub { binop(@_, sub{$_[0] **$_[1]} ) },
  '%'  => sub { binop(@_, sub{$_[0] % $_[1]} ) },
  'x'  => sub { binop(@_, sub{$_[0] x $_[1]} ) },
  '.'  => sub { binop(@_, sub{$_[0] . $_[1]} ) },
  '<<' => sub { binop(@_, sub{$_[0] <<$_[1]} ) },
  '>>' => sub { binop(@_, sub{$_[0] >>$_[1]} ) },
  '&'  => sub { binop(@_, sub{$_[0] & $_[1]} ) },
  '|'  => sub { binop(@_, sub{$_[0] | $_[1]} ) },
  '^'  => sub { binop(@_, sub{$_[0] ^ $_[1]} ) },
  '~'  => sub { unnop($_[0], sub { ~$_[0]} ) },
  'neg'=> sub { unnop($_[0], sub { -$_[0]} ) },
  '!'  => sub { unnop($_[0], sub { !$_[0]} ) },
  '++' => sub { mutop($_[0], sub {++$_[0]} ) },
  '--' => sub { mutop($_[0], sub {--$_[0]} ) },
  '<'  => sub { bioop(@_, sub{$_[0] <  $_[1]} ) },
  '>'  => sub { bioop(@_, sub{$_[0] >  $_[1]} ) },
  '<=' => sub { bioop(@_, sub{$_[0] <= $_[1]} ) },
  '>=' => sub { bioop(@_, sub{$_[0] >= $_[1]} ) },
  '==' => sub { bioop(@_, sub{$_[0] == $_[1]} ) },
  '!=' => sub { bioop(@_, sub{$_[0] != $_[1]} ) },
  'lt' => sub { bioop(@_, sub{$_[0] lt $_[1]} ) },
  'le' => sub { bioop(@_, sub{$_[0] le $_[1]} ) },
  'ge' => sub { bioop(@_, sub{$_[0] ge $_[1]} ) },
  'gt' => sub { bioop(@_, sub{$_[0] gt $_[1]} ) },
  'eq' => sub { bioop(@_, sub{$_[0] eq $_[1]} ) },
  'ne' => sub { bioop(@_, sub{$_[0] ne $_[1]} ) },
  '<=>'=> sub { binop(@_, sub{$_[0] <=>$_[1]} ) },
  'cmp'=> sub { binop(@_, sub{$_[0] cmp$_[1]} ) },
  'cos'=> sub { unnop($_[0], sub{ cos $_[0]} ) },
  'sin'=> sub { unnop($_[0], sub{ sin $_[0]} ) },
  'exp'=> sub { unnop($_[0], sub{ exp $_[0]} ) },
  'abs'=> sub { unnop($_[0], sub{ abs $_[0]} ) },
  'log'=> sub { unnop($_[0], sub{ log $_[0]} ) },
  'sqrt'=>sub { unnop($_[0], sub{ sqrt $_[0]}) },
  'atan2'=>sub{ binop(@_, sub{atan2($_[0], $_[1])} ) },
  '&{}'=> \&sub_ent,
  'bool'=> \&bool_ent, q{""}  => \&str_ent,  '0+' => \&num_ent,
  '='   => \©_ent,
  'fallback' => 1;

# copying (not observation, clones states, does not increase state space)
sub copy_ent {
  my $os = $_[0]->[1];
  my $val = $_[0]->_add;
  my $universe = ${$_[0]->[0]};
  push(@$_, $_->[$os-1], $_->[$os]) foreach @$universe;
  return $val;
}

# running entangled subroutines
sub sub_ent {
  my $obj = $_[0];
  my $os = $obj->[1];
  my $universe = ${$obj->[0]};
  return sub {
    my $var = $obj->_add;
    foreach my $state (@$universe) {
      push(@$state, $state->[$os-1],
	   scalar( $state->[$os]->(@_) ));
    }
    return $var;
  }
}

# stringification (observation)
sub str_ent {
  my $c = $_[0];
  my $os = $c->[1];
  my $universe = ${$c->[0]};
  my %str_vals;
  # work out which state we want to retain
  foreach my $state (@$universe) {
    $str_vals{$state->[$os]} = $state->[$os-1] + ($str_vals{$state->[$os]}||0);
  }

  my ($hr, $ar) = _normalise(\%str_vals);
  my $rand = rand(1);
  my $rt;
 LOOP: foreach (@$ar) {
    if ( $rand < ${$hr}{$_}) {
      $rt = $_;
      last LOOP;
    }
  }
  # retain only that state
  my @retains;
  for (0..(@$universe-1)) {
    my $state = $universe->[$_];
    my $foo = $state->[$os];
    push(@retains, $_) if ("$foo" eq $rt);
  }
  if ($Quantum::Entanglement::destroy) {
    @$universe = @$universe[@retains];
    return $rt;
  }

  # set all non retained states to zero probability, leave others alone
  my $next_retain = shift @retains;
 PURGE: foreach my $snum ( 0..(@$universe-1) ) {
    if ($snum == $next_retain) {
      $next_retain = shift(@retains) || -1;
      next PURGE;
    }
    my $state = ${$universe}[$snum];
    $$state[$_] = 0 foreach grep {!($_ % 2)} (0..(@$state-1))
  }
  return $rt;
}

# numification (have to coerce things into numbers then strings for
# probability hash purposes, ick) (observation)
sub num_ent {
  my $c = $_[0];
  my $os = $c->[1];
  my $universe = ${$c->[0]};
  my %str_vals;
  # work out which state we want to retain
  foreach my $state (@$universe) {
    $str_vals{+$state->[$os]} =
               $state->[$os-1] + ($str_vals{+$state->[$os]}||0);
  }
  my ($hr, $ar) = _normalise(\%str_vals);
  my $rand = rand(1);
  my $rt;
 LOOP: foreach (@$ar) {
    if ( $rand < ${$hr}{$_}) {
      $rt = +$_;
      last LOOP;
    }
  }
  # retain only that state
  my @retains;
  for (0..(@$universe-1)) {
    my $state = $universe->[$_];
    my $foo = +$state->[$os];
    push(@retains, $_) if ($foo == $rt);
  }

  if ($Quantum::Entanglement::destroy) {
    @$universe = @$universe[@retains];
    return $rt;
  }

  # set probabilty to zero for each state we know can't be so
  my $next_retain = shift @retains;
 PURGE: foreach my $snum ( 0..(@$universe-1) ) {
    if ($snum == $next_retain) {
      $next_retain = shift(@retains) || -1;
      next PURGE;
    }
    my $state = ${$universe}[$snum];
    $$state[$_] = 0 foreach grep {!($_ % 2)} ( 0..(@$state-1) )
  }
  return $rt;
}

# boolean context (observation)
sub bool_ent {
  my $c = $_[0];
  my $os = $c->[1];
  my $universe = ${$c->[0]};
  my ($rt,$ft,$p_true, $p_false) = (0,0,0,0);
  my (@true, @false);

  foreach (0..(@$universe-1)) {
    my $state = $universe->[$_];
    my $c2 = $state->[$os];
    if ($c2) {
      $rt++;
      push @true, $_;
      $p_true += $state->[$os-1];
    }
    else {
      $ft++;
      push @false, $_;
      $p_false += $state->[$os-1];
    }
  }

  return 0 unless $rt;   # no states are true, so must be false
  return $rt unless $ft; # no states are false, so must be true
  # if it can be true, decide if it will end up being true or not
  my @retains;
  if ( _sel_output( $p_true,$p_false)
       or $Quantum::Entanglement::conform) {
    @retains = @true;
    $rt = $rt;
  }
  else {
    @retains = @false;
    $rt = 0;
  }

  if ($Quantum::Entanglement::destroy) {
    @$universe = @$universe[@retains];
    return $rt;
  }

  my $next_retain = shift @retains;
 PURGE: foreach my $snum ( 0..(@$universe-1) ) {
    if ($snum == $next_retain) {
      $next_retain = shift(@retains) || -1;
      next PURGE;
    }
    my $state = ${$universe}[$snum];
    $$state[$_] = 0 foreach grep {!($_ % 2)} (0..(@$state-1))
  }
  return $rt;
}

### any BInary, Non-observational OPeration
sub binop {
  my ($c,$d,$r,$code) = @_;
  my $var;
  my $universe;
  if ( ref($d)
       && UNIVERSAL::isa($d, 'Quantum::Entanglement')) {
    _join($c,$d);
    my $od = $d->[1]; my $oc = $c->[1];
    $var = _add($c);
    $universe = ${$c->[0]};
    foreach my $state (@$universe) {
      push @$state, ($state->[$oc-1] * $state->[$od-1],
                     &$code($state->[$oc],$state->[$od]) );
    }
  }
  else {        # adding something to one state
    my $oc = $c->[1];
    $var = _add($c);
    $universe = ${$c->[0]};
    if ($r) {
      push(@$_, ($_->[$oc-1], &$code($d,$_->[$oc]))) foreach @$universe;
    }
    else {
      push(@$_, ($_->[$oc-1], &$code($_->[$oc],$d))) foreach @$universe;
    }
  }
  return $var;
}

# any BInary Observational OPeration
sub bioop {
  my ($c, $d, $reverse, $code) = @_;
  my $rt = 0;
  my $ft = 0;
  my (@true, @false);
  my ($p_true, $p_false) = (0,0);
  my $universe;
  if (ref($d) && UNIVERSAL::isa($d, 'Quantum::Entanglement')) {
    $c->_join($d);
    $universe = ${$c->[0]};
    foreach (0..(@$universe-1)) {
      my $state = $universe->[$_];
      my $oc = $c->[1]; my $od = $d->[1];
      my $d2 = $state->[$od];
      my $c2 = $state->[$oc];
      if (&$code($c2, $d2)) {
        $rt++;
        push @true, $_;
        $p_true += $state->[$oc-1]* $state->[$od-1];
      }
      else {
        $ft++;
        push @false, $_;
        $p_false += $state->[$oc-1]* $state->[$od-1];
      }
    }
  }
  else {
    $universe = ${$c->[0]};
    foreach (0..(@$universe-1)) {
      my $state = $universe->[$_];
      my $d2 = $d;
      my $os = $c->[1];
      my $c2 = $state->[$os];
      ($c2, $d2) = ($d2, $c2) if $reverse;
      if (&$code($c2,$d2)) {
        $rt++;
        push @true, $_;
        $p_true += $state->[$os-1];
      }
      else {
        $ft++;
        push @false, $_;
        $p_false += $state->[$os-1];
      }
    }
  }

  return 0 unless $rt; # no states are true, so must be false
  return $rt unless $ft; # no states are false, so must be true
  my @retains;
  # if it can be true, decide if it will end up being true or not
  if ( _sel_output( $p_true,$p_false)
       or $Quantum::Entanglement::conform) {
    @retains = @true;
    $rt = $rt;
  }
  else {
    @retains = @false;
    $rt = 0;
  }

  if ($Quantum::Entanglement::destroy) {
    @$universe = @$universe[@retains];
    return $rt;
  }

  my $next_retain = shift @retains;
 PURGE: foreach my $snum ( 0..(@$universe-1) ) {
    if ($snum == $next_retain) {
      $next_retain = shift(@retains) || -1;
      next PURGE;
    }
    my $state = ${$universe}[$snum];
    $$state[$_] = 0 foreach grep {!($_ % 2)} (0..(@$state-1))
  }
  return $rt;

}

# any MUTating OPerator
sub mutop {
  my $c = $_[0];
  my $code = $_[1];
  my $os = $c->[1];
  my $universe = ${$c->[0]};
  foreach my $state (@$universe) {
    $state->[$os] = &$code($state->[$os]);
  }
  return $c;
}

sub unnop {
  my $c = $_[0];
  my $code = $_[1];
  my $os = $c->[1];
  my $val = $c->_add; my $universe = ${$c->[0]};
  foreach my $state (@$universe) {
    push(@$state, $state->[$os-1], &$code($state->[$os]) );
  }
  return $val;
}

##
# performing a conditional in paralell on the states (ie. without looking)
# returns a new variable

sub p_op {
  my ($arg1, $op, $arg2, $true_cf, $false_cf) = @_;
  $true_cf  = ref($true_cf)  ? $true_cf  : sub {1};
  $false_cf = ref($false_cf) ? $false_cf : sub {0};
  my $r = 0;
  unless (ref($arg1) && UNIVERSAL::isa($arg1, 'Quantum::Entanglement')) {
    $r = 1;
    ($arg1, $arg2) = ($arg2, $arg1);
  }
  my $tcref;
  eval "
     \$tcref = sub {
       local \*QE::arg1 = \\\$_[0];
       local \*QE::arg2 = \\\$_[1];
       if (\$_[0] $op \$_[1]) {
         return \&\$true_cf;
       }
       else {
         return \&\$false_cf;
       }
     }
  "; croak "$0: something wrong in p_op $@" if $@;

  return binop($arg1, $arg2, $r, $tcref);
}

# allows for other functions to be performed accross states, can take
# as many entangled variables as you like...
# can take code ref, or "symbolic" function name (eg. p_func('substr', ..))
sub p_func {
  my $func = shift;
  my $package = (caller)[0];
  # build up the function call by shifting off
  # entangled variables until something isn't entangled
  my $foo = ref($func) ? "&\$func(" : "$func(";
  my @temp = @_;
  my $first = $temp[0];
  do {
    my $c = shift @temp;
    _join($first,$c);
  } while (ref($temp[0]) && UNIVERSAL::isa($temp[0],'Quantum::Entanglement'));
  my @p_codes = ();
  do {
    my $c = shift;
    $foo .= '$state->[' . $c->[1] . '],';
    push @p_codes, $c->[1]-1;
  } while ( ref($_[0]) && UNIVERSAL::isa($_[0], 'Quantum::Entanglement'));
  $foo .= scalar(@_)? '@args);' : ');';
  my @args = @_;
  # loop over states, evaluating function in caller's package
  my $var = $first->_add;
  my $p_code = join('*', map {"\$state->[$_]"} @p_codes);
  my $universe = ${$first->[0]};
  foreach my $state (@$universe) {
    my $new_prob = eval $p_code;
    push(@$state, $new_prob, eval "package $package; $foo");
    croak "Internal error: $@" if $@;
  }
  return $var;
}

# This allows the introduction of new states into the system, based
# on the current values and probability amplitudes of current states
# must be given a code ref, followed by a list of entangled vars whose
# states will be passed to the function.
sub q_logic {
  my $func = shift;
  my (@offsets);
  my $first = $_[0];
  _join($first,$_) foreach @_;
  @offsets = map {$_->[1]-1, $_->[1]} @_;
  my $var = $first->_add;
  my $universe = ${$first->[0]};
  my @resultant_space;
  foreach my $state (@$universe) {
    my @new_states = &$func(@{$state}[@offsets]);
    do {
      push @resultant_space, [@$state, splice(@new_states,0,2)];
    } while (@new_states);
  }
  @{$universe} = @resultant_space;
  return $var;
}

# takes ft of amplitudes of a var, creates new state with the
# transformed amplitudes and the values from the first state.
sub QFT {
  my $c = $_[0];
  my $var = $c->_add;
  my $os = $c->[1];
  my $universe = ${$c->[0]};
  my @inputs = map {$_->[$os-1]} @$universe; # get current probs
  my $num = scalar @inputs;
  foreach my $r (0..($num-1)) {
    my $prob = 0;
    foreach my $x (0..($num-1)) {
      $prob += cplxe(1,(-2*pi*$r*$x / $num)) * $inputs[$x];
    }
    push @{$universe->[$r]}, $prob, $universe->[$r]->[$os];
  }
  return $var;
}

sub save_state{
  my @os;
  my $stash = [];

  foreach (@_) {
    carp "Can only save state of Quantum::Entanglement variables"
      unless (ref($_) && UNIVERSAL::isa($_, 'Quantum::Entanglement'));
  }

  my $first = $_[0];
  _join($first, $_) foreach @_;
  push(@os, $_->[1]) foreach @_;
  my $universe = ${$_[0]->[0]};
  foreach my $state (@$universe) {
    push @$stash, [ @{$state}[map {$_-1,$_} @os] ];
  }
  return bless $stash, 'Quantum::Entanglement::State';
}

# completely clobbers current state with whatever was saved previously
sub restore_state {
  my $stash = shift;

  my $num_saved = scalar(@{$stash->[0]}) /2;
  carp "You don't have any states saved!" unless $num_saved;
  my @newvars;
  $newvars[0] = _new();
  ${$newvars[0]->[0]}->[0] = ['fake','fake']; # no hackery here, no.
  if ($num_saved > 1) {
    for (2..$num_saved) {
      push(@newvars, $newvars[0]->_add());
      push @{${$newvars[0]->[0]}->[0]}, qw(fake fake); # or here, never
    }
  }
  my $universe = ${$newvars[0]->[0]};
  shift @$universe;
  foreach (@$stash) {
    push @$universe, [@$_];
  }
  return wantarray ? @newvars : $newvars[0];
}

# this is needed for simplicity of exporting save_states
package Quantum::Entanglement::State;
@Quantum::Entanglement::State::ISA = qw(Quantum::Entanglement);
sub DESTROY {}

1;

__END__;