view release on metacpan or  search on metacpan

t/14-hatch.t  view on Meta::CPAN

    draw_square( $g, 1, 3, 5, 7 );    # (1,3)-(5,7)
    my ( $minx, $miny, $maxx, $maxy ) = $g->_get_bbox();
    ok( near( $minx, 1 ), "_get_bbox asymmetric minx ≈ 1" );
    ok( near( $miny, 3 ), "_get_bbox asymmetric miny ≈ 3" );
    ok( near( $maxx, 5 ), "_get_bbox asymmetric maxx ≈ 5" );
    ok( near( $maxy, 7 ), "_get_bbox asymmetric maxy ≈ 7" );
}


# ===========================================================================
# 7. Horizontal hatch geometry  (angle = 0)
# ===========================================================================
#
# Strategy: call _dohatching directly; inspect hsegments.
# _dohatching populates hsegments, calls _flushHsegments (writes to
# currentpage) but does NOT clear hsegments.  Only newpath clears them.
#
# For angle=0, every 'l' segment must be horizontal: sy == dy.

note('--- 7. horizontal hatch (angle=0) ---');

{
    my $g = new_g( hatchsep => 0.25, hatchangle => 0 );
    draw_square($g);
    $g->_dohatching();

    my @lines = hatch_lines($g);
    ok( scalar @lines > 0, 'angle=0: at least one hatch line generated' );

    my $all_horizontal = 1;
    for my $seg (@lines) {
        unless ( near( $seg->{sy}, $seg->{dy} ) ) {
            $all_horizontal = 0;
            last;
        }
    }
    ok( $all_horizontal,
        'angle=0: all hatch segments are horizontal (sy == dy)' );
}

# Travel ('m') segments must always exist alongside hatch lines
{
    my $g = new_g( hatchsep => 0.25, hatchangle => 0 );
    draw_square($g);
    $g->_dohatching();

    my @travels = hatch_travels($g);
    ok( scalar @travels > 0, 'angle=0: travel moves accompany hatch lines' );
}

# Each travel move should position to the start of the following hatch line
{
    my $g = new_g( hatchsep => 0.5, hatchangle => 0 );
    draw_square($g);
    $g->_dohatching();

    my @segs  = @{ $g->{hsegments} };
    my $pairs = 0;
    for my $i ( 0 .. $#segs - 1 ) {
        if ( $segs[$i]{key} eq 'm' && $segs[ $i + 1 ]{key} eq 'l' ) {
            # Travel endpoint should be the start of the hatch line
            ok( near( $segs[$i]{dx},  $segs[ $i + 1 ]{sx} ) &&
                near( $segs[$i]{dy},  $segs[ $i + 1 ]{sy} ),
                "angle=0: travel[$i] endpoint = hatch[${\($i+1)}] start" );
            $pairs++;
        }
    }
    ok( $pairs > 0, 'angle=0: found at least one travel+hatch pair' );
}


# ===========================================================================
# 8. Vertical hatch geometry  (angle = 90)
# ===========================================================================
#
# For angle=90, each hatch line runs vertically: sx == dx.

note('--- 8. vertical hatch (angle=90) ---');

{
    my $g = new_g( hatchsep => 0.25, hatchangle => 90 );
    draw_square($g);
    $g->_dohatching();

    my @lines = hatch_lines($g);
    ok( scalar @lines > 0, 'angle=90: at least one hatch line generated' );

    my $all_vertical = 1;
    for my $seg (@lines) {
        unless ( near( $seg->{sx}, $seg->{dx} ) ) {
            $all_vertical = 0;
            last;
        }
    }
    ok( $all_vertical,
        'angle=90: all hatch segments are vertical (sx == dx)' );
}

# Vertical hatch should produce the same number of lines as horizontal
# for a square (the shape is symmetric)
{
    my $g0 = new_g( hatchsep => 0.25, hatchangle => 0 );
    draw_square($g0);
    $g0->_dohatching();

    my $g90 = new_g( hatchsep => 0.25, hatchangle => 90 );
    draw_square($g90);
    $g90->_dohatching();

    is( scalar hatch_lines($g0), scalar hatch_lines($g90),
        'angle=90 vs angle=0: square produces the same number of hatch lines' );
}


# ===========================================================================
# 9. Diagonal hatch geometry  (angle = 45)
# ===========================================================================
#
# For angle=45: cos(45°) = sin(45°), so the direction vector is (1,1)/√2.
# Each hatch segment must satisfy: dx - sx == dy - sy   (unit slope).

note('--- 9. diagonal hatch (angle=45) ---');

{