view release on metacpan or  search on metacpan

t/16-ana.t  view on Meta::CPAN

# Centre of image (s=0, t=0): looking at phi=pi, beta=pi/4
#   Ray from (5,0,5) in dir (-cos45,0,-cos45) = (-s2,0,-s2)
#   Cylinder hit at t=4*sqrt2: M=(1,0,1)
#   Normal at M = (1,0,0)
#   Reflected: (-s2,0,-s2) -> (s2,0,-s2)  [z unchanged for vertical cylinder]
#   Paper hit: t_paper = -1/(-s2) = sqrt2; P=(1+1,0,0) = (2,0)
{
    my %cfg = ana('_ana_build_config', 0,0, 1);

    # Image bounding box 0..100 x 0..100; centre maps to (s=0,t=0)
    my ($px, $py) = ana('_ana_transform_point',
                        50, 50,        # image point at centre
                        0, 0, 100, 100,
                        %cfg);

    ok defined $px,                         'transform: centre of image returns defined px';
    ok defined $py,                         'transform: centre of image returns defined py';
    ok abs($px - 2.0) < 1e-6,              'transform: image centre maps to px=2';
    ok abs($py - 0.0) < 1e-6,              'transform: image centre maps to py=0';

    # Different horizontal positions give symmetric (same px, opposite py) results
    my ($px_l, $py_l) = ana('_ana_transform_point',
                             25, 50, 0,0,100,100, %cfg);   # left quarter
    my ($px_r, $py_r) = ana('_ana_transform_point',
                             75, 50, 0,0,100,100, %cfg);   # right quarter
    ok defined $px_l && defined $px_r,     'transform: off-centre points return values';
    ok abs($py_l + $py_r) < 1e-6,         'transform: left/right image points antisymmetric in y';

    # The centre point (px=2,py=0) is beyond the cylinder surface (R=1), so
    # the reflected ray travelled outward -- verify px > R
    ok $px > 1.0,                          'transform: paper point is beyond cylinder surface';

    # A point at top of image (v=0 => t=-0.5) looks more upward => may still hit
    my ($px_top) = ana('_ana_transform_point',
                       50, 0, 0,0,100,100, %cfg);
    ok defined $px_top,                    'transform: top of image maps to valid point';

    # Degenerate bbox: should return ()
    my @nil = ana('_ana_transform_point', 5,5, 0,0,0,0, %cfg);
    ok !@nil,                              'transform: zero-size bbox returns empty list';

    # Very wide angle (s = 10) should miss the cylinder
    # Build a config with very large ang_rad so s=0.5 points sideways
    my %cfg_wide = ana('_ana_build_config', 0,0, 1, angle_range => 360);
    my @far = ana('_ana_transform_point', 95, 50, 0,0,100,100, %cfg_wide);
    # With 360 degree range and s=0.45 the ray goes nearly sideways -- may or
    # may not hit depending on geometry; just confirm the function doesn't die
    ok 1,                                  'transform: extreme angle handled without error';

    # Reflected ray going upward: cylinder directly above observer?  Hard to
    # trigger naturally, but we at least confirm return-type consistency.
    my @result = ana('_ana_transform_point', 50, 50, 0,0,100,100, %cfg);
    ok scalar(@result) == 0 || scalar(@result) == 2,
                                           'transform: return is always 0 or 2 values';
}

# ==========================================================================
# SECTION 5: _ana_resample_segment
# ==========================================================================
{
    # Trivial: identical points returns the endpoint
    my @r0 = ana('_ana_resample_segment', 5,5, 5,5, 1.0);
    is scalar @r0, 1,                       'resample: zero-length returns 1 point';
    ok abs($r0[0][0] - 5) < 1e-9,          'resample: zero-length point x=5';

    # Segment (0,0)-(10,0) step=3: ceil(10/3)=4 intervals => 4 points
    my @r1 = ana('_ana_resample_segment', 0,0, 10,0, 3);
    is scalar @r1, 4,                       'resample: 10/step=3 gives 4 pts';
    ok abs($r1[-1][0] - 10) < 1e-9,        'resample: last point is endpoint';
    ok abs($r1[0][0] - 2.5) < 1e-9,        'resample: first sample at 10/4=2.5';

    # Step larger than segment => 1 point (just the endpoint)
    my @r2 = ana('_ana_resample_segment', 0,0, 3,4, 100);
    is scalar @r2, 1,                       'resample: step>length gives 1 point';
    ok abs($r2[0][0] - 3) < 1e-9,          'resample: endpoint x=3';
    ok abs($r2[0][1] - 4) < 1e-9,          'resample: endpoint y=4';

    # Diagonal: length=5, step=1 => 5 points, all on the line y=x*(4/3)
    my @r3 = ana('_ana_resample_segment', 0,0, 3,4, 1);
    is scalar @r3, 5,                       'resample: diagonal 5 pts at step=1';
    for my $pt (@r3) {
        # Each point should satisfy y = (4/3)*x (the line from (0,0) to (3,4))
        my $expected_y = ($pt->[0] / 3.0) * 4.0;
        ok abs($pt->[1] - $expected_y) < 1e-9,
                                            'resample: diagonal pt on line';
    }
}

# ==========================================================================
# SECTION 6: anamorphic() integration
# ==========================================================================
{
    # ------------------------------------------------------------------
    # Build a diagonal path from (0,0) to (100,50), giving a well-defined
    # 100x50 bounding box.  Two 'l' segments so resampling is exercised.
    # ------------------------------------------------------------------
    my $g = MockPlotter->new;
    $g->_addpath('m',  0,  0,  0,  0);
    $g->_addpath('l',  0,  0, 50, 25);
    $g->_addpath('l', 50, 25,100, 50);

    $g->log_clear;
    my $ret = $g->anamorphic(0, 0, 1, obs_dist => 10, obs_height => 10, step => 10);
    is $ret, 1,                              'anamorphic: returns 1 on success';

    my @log = $g->log_get;
    ok grep({ $_ eq 'STROKE' } @log),       'anamorphic: calls stroke';

    # After stroke() the mock does not clear psegments (no real newpath),
    # so we can inspect what anamorphic() wrote back before stroke() emptied it.
    # We capture via a stroke override during the call instead -- but that is
    # complex.  Instead we verify structural output via a spy on psegments
    # written inside anamorphic BEFORE stroke() is called, by using a
    # subclassed mock that captures the snapshot.

    # Simpler: since MockPlotter::stroke just logs 'STROKE' and does NOT clear
    # psegments (no newpath call), psegments still holds the transformed path
    # after the method returns.
    my @ns = @{ $g->{psegments} };
    ok @ns >= 1,                             'anamorphic: produces transformed segments';
    ok grep({ $_->{key} eq 'm' } @ns),      'anamorphic: output contains a moveto segment';
    ok grep({ $_->{key} eq 'l' } @ns),      'anamorphic: output contains line segments';

    # All transformed coordinates must be finite numbers
    my $all_finite = 1;
    for my $s (@ns) {
        for my $k (qw(sx sy dx dy)) {
            unless (defined $s->{$k} && $s->{$k} == $s->{$k}) {
                $all_finite = 0; last;
            }
        }
        last unless $all_finite;
    }
    ok $all_finite,                          'anamorphic: all output coords are finite';

    # ------------------------------------------------------------------