view release on metacpan or  search on metacpan

lib/Graphics/Penplotter/GcodeXY/Anamorphic.pm  view on Meta::CPAN

    return () if $iw < 1e-12 || $ih < 1e-12;

    # Normalise to [-0.5, +0.5]: s = horizontal (right +), t = vertical (down +)
    my $s = ($u - $u0) / $iw - 0.5;
    my $t = ($v - $v0) / $ih - 0.5;

    # Map to viewing angles from the observer.
    # phi: azimuth of the viewing ray. Right side of image (s > 0) means the
    # observer looks more counterclockwise (toward their left).
    my $phi  = $cfg{phi_fwd} + $s * $cfg{ang_rad};

    # beta: elevation angle below horizontal.  Image bottom (t > 0 in SVG)
    # maps to looking further downward.
    my $beta = $cfg{beta0} + $t * $cfg{elev_rad};

    # Unit viewing direction from observer toward the mirror
    my $cos_b = cos($beta);
    my $dx    = $cos_b * cos($phi);
    my $dy    = $cos_b * sin($phi);
    my $dz    = -sin($beta);              # negative z = downward toward paper

    # Intersect the viewing ray with the cylinder surface
    my $t_cyl = _ana_ray_cylinder(
        $cfg{ex}, $cfg{ey}, $cfg{ez},
        $dx, $dy, $dz,
        $cfg{cx}, $cfg{cy}, $cfg{R},
    );
    return () unless defined $t_cyl;

    # Mirror surface point M
    my $mx = $cfg{ex} + $t_cyl * $dx;
    my $my = $cfg{ey} + $t_cyl * $dy;
    my $mz = $cfg{ez} + $t_cyl * $dz;

    # The cylinder hit must be at or above the paper (z >= 0)
    return () if $mz < -1e-9;

    # Outward unit normal at M (horizontal, pointing away from cylinder axis)
    my $nx = ($mx - $cfg{cx}) / $cfg{R};
    my $ny = ($my - $cfg{cy}) / $cfg{R};

    # Reflect the incident ray off the cylinder surface (nz = 0 for a vertical
    # cylinder, so the z component of the reflected ray is unchanged)
    my ($rx, $ry, $rz) = _ana_reflect($dx, $dy, $dz, $nx, $ny, 0.0);

    # The reflected ray must travel downward (rz < 0) to reach the paper
    return () if $rz >= -1e-9;

    # Intersect the reflected ray with the paper plane (z = 0)
    my $t_paper = -$mz / $rz;
    return () if $t_paper < 0;

    my $px = $mx + $t_paper * $rx;
    my $py = $my + $t_paper * $ry;
    return ($px, $py);
}

# ---------------------------------------------------------------------------
# _ana_resample_segment
#
# Given endpoints (x0,y0) and (x1,y1) in image space, return a list of
# [ x, y ] sample-point arrayrefs spaced at most $step apart.  The start
# point is NOT included (the caller holds it); the end point IS included.
# ---------------------------------------------------------------------------
sub _ana_resample_segment {
    my ($x0, $y0, $x1, $y1, $step) = @_;
    my $ddx  = $x1 - $x0;
    my $ddy  = $y1 - $y0;
    my $dist = sqrt($ddx*$ddx + $ddy*$ddy);
    if ($dist < 1e-12) { return ([$x1, $y1]) }
    my $n = ceil($dist / $step);
    $n = 1 if $n < 1;
    my @pts;
    for my $i (1 .. $n) {
        my $f = $i / $n;
        push @pts, [$x0 + $f*$ddx, $y0 + $f*$ddy];
    }
    return @pts;
}

# ===========================================================================
# PUBLIC ENTRY POINT
# ===========================================================================



# ---------------------------------------------------------------------------
# anamorphic
#
# Transform the current segment path through the cylindrical mirror model.
#
# Usage:
#     $g->anamorphic( $cx, $cy, $R, %opts );
#
# $cx, $cy  Centre of the cylindrical mirror in drawing coordinates.
# $R        Radius of the cylindrical mirror in the same units.
# %opts     Optional parameters (see POD / _ana_build_config).
#
# The method reads the existing psegments, uses their bounding box as the
# image extent, projects every sample point through the mirror model, writes
# the transformed segments back into psegments, then calls stroke() to flush.
# ---------------------------------------------------------------------------
sub anamorphic {
    my ($self, $cx, $cy, $R, %opts) = @_;

    $self->_croak('anamorphic: cylinder radius R must be > 0') unless $R > 0;

    my $step = delete $opts{step} // 1.0;

    # ------------------------------------------------------------------
    # Collect all drawable segment endpoints and compute the image bbox.
    # ------------------------------------------------------------------
    my @segs = @{ $self->{psegments} };

    my (@xs, @ys);
    for my $s (@segs) {
        my $k = $s->{key} // '';
        next unless $k eq 'm' || $k eq 'l';
        push @xs, $s->{sx}, $s->{dx};
        push @ys, $s->{sy}, $s->{dy};
    }
    $self->_croak('anamorphic: segment path is empty') unless @xs;

    my ($u0, $v0) = (min(@xs), min(@ys));
    my ($u1, $v1) = (max(@xs), max(@ys));

    $self->_croak('anamorphic: segment path has zero width or height')
        if $u1 - $u0 < 1e-12 || $v1 - $v0 < 1e-12;

    # ------------------------------------------------------------------
    # Build observer / image-mapping configuration.
    # ------------------------------------------------------------------
    my %cfg = _ana_build_config($cx, $cy, $R, %opts);

    # ------------------------------------------------------------------
    # Extract polylines from the segment path.
    # Each 'm' entry starts a new polyline; 'l' entries continue it,
    # resampled at most $step apart so the non-linear transform stays
    # accurate along longer segments.
    # ------------------------------------------------------------------
    my @polylines;
    my @cur;
    for my $s (@segs) {
        my $k = $s->{key} // '';
        if ($k eq 'm') {
            push @polylines, [@cur] if @cur > 1;
            @cur = ([$s->{dx}, $s->{dy}]);
        }
        elsif ($k eq 'l') {
            push @cur,
                _ana_resample_segment($s->{sx}, $s->{sy},
                                      $s->{dx}, $s->{dy}, $step);
        }
        # penup / pendown / comment entries are ignored
    }
    push @polylines, [@cur] if @cur > 1;

    $self->_croak('anamorphic: segment path contains no drawable segments')
        unless @polylines;

    # ------------------------------------------------------------------
    # Replace the segment path with the transformed version, then flush.
    # ------------------------------------------------------------------
    @{ $self->{psegments} } = ();

    for my $poly (@polylines) {
        my $pen_is_down = 0;
        my ($prev_px, $prev_py);

        for my $pt (@$poly) {
            my ($px, $py) = _ana_transform_point(