add tests for QuaterControllers eg ArcCone

Author: mohawk2

Changes

@@ -1,3 +1,5 @@
+- non-trivial tests added
+
 2.100 2025-01-16
 - adjust MathGraph and Labels so Debian packaging is happy
 

MANIFEST

@@ -43,4 +43,5 @@ lib/PDL/Graphics/VRML/Protos.pm
 Makefile.PL
 MANIFEST			This list of files
 MANIFEST.SKIP
+t/arcball.t
 t/opengl.t

lib/PDL/Graphics/TriD/ArcBall.pm

@@ -12,6 +12,7 @@
 package PDL::Graphics::TriD::QuaterController;
 use strict;
 use warnings;
+use PDL::Graphics::TriD::Quaternion;
 use base qw(PDL::Graphics::TriD::ButtonControl);
 use fields qw /Inv Quat/;
 
@@ -67,7 +68,7 @@ sub normxy2qua {
 	my($this,$x,$y) = @_;
 	$x /= $this->{SC}; $y /= $this->{SC};
 	my $dist = sqrt ($x ** 2 + $y ** 2);
-	if($dist > 1.0) {$x /= $dist; $y /= $dist; $dist = 1.0;}
+	if ($dist > 1.0) {$x /= $dist; $y /= $dist; $dist = 1.0;}
 	my $z = sqrt(1-$dist**2);
 	return PDL::Graphics::TriD::Quaternion->new(0,$x,$y,$z);
 }
@@ -82,7 +83,7 @@ sub normxy2qua {
 	my($this,$x,$y) = @_;
 	$x /= $this->{SC}; $y /= $this->{SC};
 	my $dist = sqrt ($x ** 2 + $y ** 2);
-	if($dist > 1.0) {$x /= $dist; $y /= $dist; $dist = 1.0;}
+	if ($dist > 1.0) {$x /= $dist; $y /= $dist; $dist = 1.0;}
 	my $z = 1-$dist;
 	my $qua = PDL::Graphics::TriD::Quaternion->new(0,$x,$y,$z);
 	$qua->normalize_this();
@@ -99,7 +100,7 @@ sub normxy2qua {
 	my($this,$x,$y) = @_;
 	$x /= $this->{SC}; $y /= $this->{SC};
 	my $dist = sqrt ($x ** 2 + $y ** 2);
-	if($dist > 1.0) {$x /= $dist; $y /= $dist; $dist = 1.0;}
+	if ($dist > 1.0) {$x /= $dist; $y /= $dist; $dist = 1.0;}
 	my $z = cos($dist*3.142/2);
 	my $qua = PDL::Graphics::TriD::Quaternion->new(0,$x,$y,$z);
 	$qua->normalize_this();

t/arcball.t

@@ -0,0 +1,51 @@
+use strict;
+use warnings;
+use Test::More;
+
+use PDL::Graphics::TriD::ArcBall;
+use PDL::LiteF;
+use Test::PDL;
+{package FakeWindow; sub new {bless {}} sub add_resizecommand {} }
+
+sub is_qua {
+  local $Test::Builder::Level = $Test::Builder::Level + 1;
+  my ($got, $exp) = map PDL->pdl(@$_), @_;
+  is_pdl $got, $exp;
+}
+
+my $win = FakeWindow->new;
+
+my $arcball = PDL::Graphics::TriD::ArcBall->new($win);
+isa_ok $arcball, 'PDL::Graphics::TriD::ArcBall';
+$arcball->set_wh(100,100);
+is_qua $arcball->xy2qua(50,50), [0,0,0,1];
+is_qua $arcball->xy2qua(25,25), [0,-0.5,0.5,0.707106];
+is_qua $arcball->xy2qua(25,50), [0,-0.5,0,0.866025];
+is_qua $arcball->xy2qua(25,75), [0,-0.5,-0.5,0.707106];
+is_qua $arcball->xy2qua(75,25), [0,0.5,0.5,0.707106];
+is_qua $arcball->xy2qua(75,50), [0,0.5,0,0.866025];
+is_qua $arcball->xy2qua(75,75), [0,0.5,-0.5,0.707106];
+
+my $arccone = PDL::Graphics::TriD::ArcCone->new($win);
+isa_ok $arccone, 'PDL::Graphics::TriD::ArcCone';
+$arccone->set_wh(100,100);
+is_qua $arccone->xy2qua(50,50), [0,0,0,1];
+is_qua $arccone->xy2qua(25,25), [0,-0.653281,0.653281,0.382683];
+is_qua $arccone->xy2qua(25,50), [0,-0.707106,0,0.707106];
+is_qua $arccone->xy2qua(25,75), [0,-0.653281,-0.653281,0.382683];
+is_qua $arccone->xy2qua(75,25), [0,0.653281,0.653281,0.382683];
+is_qua $arccone->xy2qua(75,50), [0,0.707106,0,0.707106];
+is_qua $arccone->xy2qua(75,75), [0,0.653281,-0.653281,0.382683];
+
+my $arcbowl = PDL::Graphics::TriD::ArcBowl->new($win);
+isa_ok $arcbowl, 'PDL::Graphics::TriD::ArcBowl';
+$arcbowl->set_wh(100,100);
+is_qua $arcbowl->xy2qua(50,50), [0,0,0,1];
+is_qua $arcbowl->xy2qua(25,25), [0,-0.598883,0.598883,0.531673];
+is_qua $arcbowl->xy2qua(25,50), [0,-0.577389,0,0.816468];
+is_qua $arcbowl->xy2qua(25,75), [0,-0.598883,-0.598883,0.531673];
+is_qua $arcbowl->xy2qua(75,25), [0,0.598883,0.598883,0.531673];
+is_qua $arcbowl->xy2qua(75,50), [0,0.577389,0,0.816468];
+is_qua $arcbowl->xy2qua(75,75), [0,0.598883,-0.598883,0.531673];
+
+done_testing;