The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
##############################################
#
# Quaternions... inefficiently.
#
# Should probably use PDL and C... ?
#
# Stored as [c,x,y,z].
#
# XXX REMEMBER!!!! First component = cos(angle*2), *NOT* cos(angle)

package PDL::Graphics::TriD::Quaternion;

sub new {
	my($type,$c,$x,$y,$z) = @_;
	my $this;

   if(ref($type)){
	  $this = $type;
	}else{
	  $this = bless [$c,$x,$y,$z],$type;
	}
	return $this;
}

sub copy {
	return new PDL::Graphics::TriD::Quaternion(@{$_[0]});
}

sub new_vrmlrot {
	my($type,$x,$y,$z,$a) = @_;
	my $l = sqrt($x**2+$y**2+$z**2);
	my $this = bless [cos($a/2),map {sin($a/2)*$_/$l} $x,$y,$z],$type;
	$this->normalize_this();
	return $this;
}

sub to_vrmlrot {
	my($this) = @_;
	my $d = POSIX::acos($this->[0]);
	if(abs($d) < 0.0000001) {
		return [0,0,1,0];
	}
	return [(map {$_/sin($d)} @{$this}[1..3]),2*$d];
}

# Yuck
sub multiply {
	my($this,$with) = @_;
	return PDL::Graphics::TriD::Quaternion->new(
		$this->[0] * $with->[0] -
		$this->[1] * $with->[1] -
		$this->[2] * $with->[2] -
		$this->[3] * $with->[3],
			$this->[2] * $with->[3] -
			$this->[3] * $with->[2] +
			$this->[0] * $with->[1] +
			$this->[1] * $with->[0],
		$this->[3] * $with->[1] -
		$this->[1] * $with->[3] +
		$this->[0] * $with->[2] +
		$this->[2] * $with->[0],
			$this->[1] * $with->[2] -
			$this->[2] * $with->[1] +
			$this->[0] * $with->[3] +
			$this->[3] * $with->[0],
	);
}

sub multiply_scalar {
	my($this,$scalar) = @_;
	my $ang = POSIX::acos($this->[0]);
	my $d = sin($ang);
	if(abs($d) < 0.0000001) {
		return new PDL::Graphics::TriD::Quaternion(1,0,0,0);
	}
	$ang *= $scalar;
	my $d2 = sin($ang);
	return new PDL::Graphics::TriD::Quaternion(
		cos($ang), map {$_*$d2/$d} @{$this}[1..3]
	);
}

sub set {
	my($this,$new) = @_;
	@$this = @$new;
}

sub add {
	my($this,$with) = @_;
	return PDL::Graphics::TriD::Quaternion->new(
		$this->[0] * $with->[0],
		$this->[1] * $with->[1],
		$this->[2] * $with->[2],
		$this->[3] * $with->[3]);
}

sub abssq {
	my($this) = @_;
	return  $this->[0] ** 2 +
		$this->[1] ** 2 +
		$this->[2] ** 2 +
		$this->[3] ** 2 ;
}

sub invert {
	my($this) = @_;
	my $abssq = $this->abssq();
	return PDL::Graphics::TriD::Quaternion->new(
		 1/$abssq * $this->[0] ,
		-1/$abssq * $this->[1] ,
		-1/$abssq * $this->[2] ,
		-1/$abssq * $this->[3] );
}

sub invert_rotation_this {
	my($this) = @_;
	$this->[0] = - $this->[0];
}

sub normalize_this {
	my($this) = @_;
	my $abs = sqrt($this->abssq());
	@$this = map {$_/$abs} @$this;
}

sub rotate {
  my($this,$vec) = @_;
  my $q = (PDL::Graphics::TriD::Quaternion)->new(0,@$vec);
  my $m = $this->multiply($q->multiply($this->invert));
  return [@$m[1..3]];
}

sub rotate_foo {
  my ($this,$vec) = @_;
#  print "CP: ",(join ',',@$this)," and ",(join ',',@$vec),"\n";
  return $vec if $this->[0] == 1 or $this->[0] == -1;
# 1. cross product of my vector and rotated vector
# XXX I'm not sure of any signs!
  my @u = @$this[1..3];
  my @v = @$vec;
  my $tl = sqrt($u[0]**2 + $u[1]**2 + $u[2]**2);
  my $up = sqrt($v[0]**2 + $v[1]**2 + $v[2]**2);
  my @cp = (
  	$u[1] * $v[2] - $u[2] * $v[1],
  	$u[0] * $v[2] - $u[2] * $v[0],
  	$u[0] * $v[1] - $u[1] * $v[0],
  );
# Cross product of this and my vector
  my @cp2 = (
  	$u[1] * $cp[2] - $u[2] * $cp[1],
  	$u[0] * $cp[2] - $u[2] * $cp[0],
  	$u[0] * $cp[1] - $u[1] * $cp[0],
  );
  my $cpl = 0.00000001 + sqrt($cp[0]**2 + $cp[1]**2 + $cp[2]**2);
  my $cp2l = 0.0000001 + sqrt($cp2[0]**2 + $cp2[1]**2 + $cp2[2]**2);
  for(@cp) {$_ /= $cpl}
  for(@cp2) {$_ /= $cp2l}
  my $mult1 = $up * sqrt(1-$this->[0]**2);
  # my $mult1 = $up * sqrt(1-$this->[0]**2);
  my $mult2 = $up * $this->[0];
  print "ME: ",(join '    ',@u),"\n";
  print "VEC: ",(join '    ',@v),"\n";
  print "CP: ",(join '    ',@cp),"\n";
  print "CP2: ",(join '    ',@cp2),"\n";
  print "MULT1: $mult1, MULT2: $mult2\n";
  print "CPL: ",$cpl, " TL: $tl  CPLTL: ",$cpl/$tl,"\n";
  my $res = [map {
  	$v[$_] + $mult1 * $cp[$_] + ($mult2 - $cpl/$tl)* $cp2[$_]
  } 0..2];
#  print "RES: ",(join ',',@$res),"\n";
  return $res;
}

1;