#!/usr/bin/env perl
#
# tri -- manipulation of triangles
# Copyright (C) Zsban Ambrus, 2003 
#
#
#


use strict; use warnings;

use POSIX; use IO::Handle;


# --------------------------------------------------------- Triangle
{ package Triangle;

# random triangle
sub prand {
    my (@a, $n, $x, $s, $m);
    $m= @_>0 ? $_[1] : exp(1);
    @a= map rand(), 0..8;
    $s= 1/(1+rand($m));
    $_*= $s for @a;
    for $n (0..2) {
        $x= rand (1-$s);
        $a[$_*3+$n]+= $x for 0..2;
        }
    $_[0]->init3 (@a);
    }

# color handling (rgb)
our $default_color= "0.8 0.8 0.8";
sub setcolor {    
    ${$_[0]}{col}= $_[1];
    }
sub color {
    ${$_[0]}{col};
    }

sub shade {
    my (%t, @e, $a);
    %t= %{$_[0]};
    @e= (
        ($t{y2}-$t{y1})*($t{z3}-$t{z1})-($t{z2}-$t{z1})*($t{y3}-$t{y1}
+),
        ($t{z2}-$t{z1})*($t{x3}-$t{x1})-($t{x2}-$t{x1})*($t{z3}-$t{z1}
+),
        ($t{x2}-$t{x1})*($t{y3}-$t{y1})-($t{y2}-$t{y1})*($t{x3}-$t{x1}
+),
        );
    $a= $e[2]/$e[1];
    $_[0]{col}= "<---- CONT";
    }

# triangle constructor
sub init3 {
    @_==10 or die qq{internal error: Triangle init nargs=}.(0+@_);
    my %x= (
        "x1", $_[1], "y1", $_[2], "z1", $_[3],
        "x2", $_[4], "y2", $_[5], "z2", $_[6],
        "x3", $_[7], "y3", $_[8], "z3", $_[9],
        "col", ref($_[0]) ? ${$_[0]}{col} : $default_color,
        );
    bless {%x}, ref ($_[0]) || $_[0]; 
    }

# transforming triangles
sub transf {
    my (%a, $t);
    $_[1]->isa("Transf") or die "error: Triangle::transf arg1 type";
    %a= %{$_[0]};
    $t= $_[1];
    return $_[0]->init3 (
        $t->call (@a{"x1","y1","z1"}),
        $t->call (@a{"x2","y2","z2"}),
        $t->call (@a{"x3","y3","z3"}),
        );
    }


}


# ------------------------------------------------------- Transf
# represents a projective collination transformation or whatever
{
package Transf;

sub init {
    @_==17 or die "internal error: Transf::init nargs";
    ref ($_[0]) and die "internal error: Transf::init aint objmethod!"
+;
    bless [@_[1..16]], $_[0];
    }

sub call {
    @_==4 or die "error: Transf::call nargs";
    my @a= @{$_[0]};
    my $d= $_[1]*$a[0xc]+$_[2]*$a[0xd]+$_[3]*$a[0xe]+$a[0xf];
    return (
        ($_[1]*$a[0x0]+$_[2]*$a[0x1]+$_[3]*$a[0x2]+$a[0x3])/$d,
        ($_[1]*$a[0x4]+$_[2]*$a[0x5]+$_[3]*$a[0x6]+$a[0x7])/$d,
        ($_[1]*$a[0x8]+$_[2]*$a[0x9]+$_[3]*$a[0xa]+$a[0xb])/$d,
        );
    }

# mátrixszorzás: call(compose(a,b),p) === call(a,call(b,p))
sub compose {
    my (@a, @b, @r, $i, $j, $k);
    @a= @{$_[0]};
    @b= @{$_[1]};
    @r= ((0)x4)x4;
    for $i (0..3) { for $j (0..3) { for $k (0..3) {
        $r[$i+$k*4]+= $a[$i+$j*4] * $b[$j+$k*4];
        }}}
    return bless [@r], ref($_[0]);
    }

sub perspective {
    my (undef, $d)= @_;
    $_[0]->init (
        1,  0,  0,   0,
        0,  1,  0,   0,
        0,  0,  1,   0,
        0,  0, 1/$d, 1,
        );
    }

sub turnx {
    my (undef, $d)= @_;
    $_[0]->init (
        1,     0,       0,    0,
        0,  cos($d), sin($d), 0,
        0, -sin($d), cos($d), 0,
        0,     0,       0,    1,
        );
    }

sub turny {
    my (undef, $d)= @_;
    $_[0]->init (
         cos($d), 0, sin($d), 0,
            0,    1,    0,    0,
        -sin($d), 0, cos($d), 0,
            0,    0,    0,    1,
        );
    }

sub translate {
    my (undef, $x, $y, $z)= @_;
    $_[0]->init (
        1,  0,  0, $x,
        0,  1,  0, $y,
        0,  0,  1, $z,
        0,  0,  0,  1,
        );
    }

sub scale {
    my (undef, $x, $y, $z)= @_;
    $_[0]->init (
        $x,  0,  0,  0,
         0, $y,  0,  0,
         0,  0, $z,  0,
         0,  0,  0,  1,
        );
    }


}


# -------------------------------------------------------------- Zbuf

{
package Zbuf;

our $bgcolor= chr(255)x3;
our $INF= 1e1000;
our $default_pixel= [$bgcolor, $INF];

# uj kepet hoz letre, argumentumok: szelesseg, hosszusag (pixel)
sub new {
    my ($w, $h);
    (undef, $w, $h)= @_;
    $w>=1 && $h>=1 or die "error: Zbuf::new args";
    bless [map [($default_pixel)x$w], 0..$h-1], $_[0];
    }

sub ins1;

# ins rajzol egy haromszoget

# dr rajzol egy trapezt, amelynek ket oldala vizszintes, parameterei
# ($ym, $yM, $xmym, $xMym, $dxm, $dxM, $zxmym, $dzxm, $dzdy,  $col, $z
+b),
# ahol, m=minimum, M=maximum, dF jelentese dF/dy, 
# dFdG jelentese dF/dG, FGm jelentese F amikor G=Gm

sub dr {
    my ($ym, $yM, $xmym, $xMym, $dxm, $dxM, $zxmym, $dzxm, $dzdy,
        $col, $zb)= @_;
    my ($x, $xm, $xM, $xL, $y, $yL, $z, $zxm, $u);
    $u= $ym>0 ? POSIX::floor($ym)-$ym : -$ym;
    ($y, $xm, $xM, $zxm)= 
        ($ym+$u, $xmym+$u*$dxm, $xMym+$u*$dxM, $zxmym+$u*$dzxm);
    $yL= $yM<@$zb ? $yM : @$zb;
    while ($y<$yL) {
        $u= $xm<0 ? -$xm : POSIX::floor($xm)-$xm;
        ($x, $z)= ($xm+$u, $zxm+$u*$dzxm);
        $xL= $xM<@{$$zb[0]}?$xM:@{$$zb[0]};
        while ($x<$xL) {
            $$zb[$y][$x]= [$col, $z] if
                $z<=$$zb[$y][$x][1];
            ($x, $z)= ($x+1, $z+$dzdy);
            }
        ($y, $xm, $xM, $zxm)= 
            ($y+1, $xm+$dxm, $xM+$dxM, $zxm+$dzxm);
        }
    };

# drr ugyanaz mint dr, csak fejjel lefelé, vagyis (x,y,z)|->(x,H-y,z)

sub drr {
    my ($ym, $yM, $xmym, $xMym, $dxm, $dxM, $zxmym, $dzxm, $dzdy,
        $col, $zb)= @_;
    my ($x, $xm, $xM, $xL, $y, $yL, $z, $zxm, $u);
    $u= $ym>0 ? POSIX::floor($ym)-$ym : -$ym;
    ($y, $xm, $xM, $zxm)= 
        ($ym+$u, $xmym+$u*$dxm, $xMym+$u*$dxM, $zxmym+$u*$dzxm);
    $yL= $yM<@$zb ? $yM : @$zb;
    while ($y<$yL) {
        $u= $xm<0 ? -$xm : POSIX::floor($xm)-$xm;
        ($x, $z)= ($xm+$u, $zxm+$u*$dzxm);
        $xL= $xM<@{$$zb[0]}?$xM:@{$$zb[0]};
        while ($x<$xL) {
            $$zb[@$zb-1-$y][$x]= [$col, $z] if
                $z<=$$zb[@$zb-1-$y][$x][1];
            ($x, $z)= ($x+1, $z+$dzdy);
            }
        ($y, $xm, $xM, $zxm)= 
            ($y+1, $xm+$dxm, $xM+$dxM, $zxm+$dzxm);
        }
    };


sub ins {
    my (@p, $t, $u, $v, $D, $zb, $col); 
    ($zb, $t)= @_;
    $$t{col}=~m/([\d.]+)\s+([\d.]+)\s+([\d.]+)/ or
        warn "warning: wrong color, substing grey";
    $col= pack ("C3", defined($1)?($1*255,$2*255,$3*255):(128,128,128)
+);
    @p= sort {$$a[1]<=>$$b[1]} 
        [@$t{"x1","y1","z1"}],
        [@$t{"x2","y2","z2"}],
        [@$t{"x3","y3","z3"}];
    $u= ($p[2][1]-$p[1][1])/($p[2][1]-$p[0][1]);
    $v= ($p[1][1]-$p[0][1])/($p[2][1]-$p[0][1]);
    $p[3]= [$p[0][0]*$u+$p[2][0]*$v, $p[1][1], $p[0][2]*$u+$p[2][2]*$v
+];
    $p[3][0]<$p[1][0] or ($p[1], $p[3])= ($p[3], $p[1]);
    eval {
    dr ( #(x, xm, xM, xL, y, yL, z, zxm, u)          # -+----------->x
        $p[0][1], $p[3][1], $p[0][0], $p[0][0],   #  | 0      0
        ($p[3][0]-$p[0][0])/($p[3][1]-$p[0][1]),  #  |/ \ or / \
        ($p[1][0]-$p[0][0])/($p[1][1]-$p[0][1]),  #  3 _-1  3-_ 1
        $p[0][2],                  # 2+~        ~-2
        ($p[3][2]-$p[0][2])/($p[3][1]-$p[0][1]),  #  v y
        ($p[1][2]-$p[3][2])/($p[1][0]-$p[3][0]),
        $col, $zb
        );
    }; $@ and do {
    $@=~m/division by zero/ or die $@;
    };
    eval {
    drr (
        @$zb-1-$p[2][1], @$zb-1-$p[3][1],
        $p[2][0], $p[2][0],
        -($p[3][0]-$p[2][0])/($p[3][1]-$p[2][1]),
        -($p[1][0]-$p[2][0])/($p[1][1]-$p[2][1]),
        $p[2][2],
        -($p[3][2]-$p[2][2])/($p[3][1]-$p[2][1]),
        ($p[1][2]-$p[3][2])/($p[1][0]-$p[3][0]),
        $col, $zb
        );
    }; $@ and do {
    $@=~m/division by zero/ or die $@;
    };
    }


# kiirja a kepet ppm formatumban
sub print {
    my ($w, $h, $x, $y, $a);
    ($a)= @_;
    $h= @$a; $w= @{$$a[0]};
    warn "writing image w=".$w." h=".$h;
    print "P6 ".$w." ".$h." 255\n";
    for $y (0..$h-1) {
        for $x (0..$w-1) {
            print $$a[$y][$x][0];
            }
        }
    flush STDOUT;
    warn "image written";
    }
    

}


# ------------------------------------------------------------ main

{

my (@t, $persp, @color);

warn "creating objects";

$persp= Transf->perspective (2);

@t= (
    Triangle->init3 (0.1, 0.5, 0.5, 0.5, 0.1, 0.5, 0.5, 0.5, 0.1),
    Triangle->init3 (0.1, 0.5, 0.5, 0.5, 0.1, 0.5, 0.5, 0.5, 0.9),
    Triangle->init3 (0.1, 0.5, 0.5, 0.5, 0.9, 0.5, 0.5, 0.5, 0.1),
    Triangle->init3 (0.1, 0.5, 0.5, 0.5, 0.9, 0.5, 0.5, 0.5, 0.9),
    Triangle->init3 (0.9, 0.5, 0.5, 0.5, 0.1, 0.5, 0.5, 0.5, 0.1),
    Triangle->init3 (0.9, 0.5, 0.5, 0.5, 0.1, 0.5, 0.5, 0.5, 0.9),
    Triangle->init3 (0.9, 0.5, 0.5, 0.5, 0.9, 0.5, 0.5, 0.5, 0.1),
    Triangle->init3 (0.9, 0.5, 0.5, 0.5, 0.9, 0.5, 0.5, 0.5, 0.9),
    );
push @t, Triangle->init3 (0.5, 0.8, 0.2, 0.2, 0.8, 0.6, 0.6, 0.2, 0.8)
+;

sub paral {
    Triangle->init3 (@_[0..8]),
        Triangle->init3 (@_[3..8],
        $_[3]+$_[6]-$_[0], $_[4]+$_[7]-$_[1], $_[5]+$_[8]-$_[2]);
    }

@t= (
    paral (0.1, 0.1, 0.1, 0.1, 0.1, 0.9, 0.1, 0.9, 0.1),
    paral (0.9, 0.1, 0.1, 0.9, 0.1, 0.9, 0.9, 0.9, 0.1),
    paral (0.1, 0.1, 0.1, 0.1, 0.9, 0.1, 0.9, 0.1, 0.1),
    paral (0.1, 0.1, 0.9, 0.1, 0.9, 0.9, 0.9, 0.1, 0.9),
    paral (0.1, 0.1, 0.1, 0.1, 0.1, 0.9, 0.9, 0.1, 0.1),
    paral (0.1, 0.9, 0.1, 0.1, 0.9, 0.9, 0.9, 0.9, 0.1),
    );

sub pill {
    paral ($_[0], $_[1], $_[2], $_[0]+$_[3], $_[1]+$_[4], $_[2]+$_[5],
+ 
        $_[0]+$_[9], $_[1]+$_[10], $_[2]+$_[11]),
    paral ($_[0], $_[1], $_[2], $_[0]+$_[6], $_[1]+$_[7], $_[2]+$_[8],
+ 
        $_[0]+$_[9], $_[1]+$_[10], $_[2]+$_[11]),
    paral ($_[0]+$_[6], $_[1]+$_[7], $_[2]+$_[8], $_[0]+$_[6]+$_[3], 
        $_[1]+$_[7]+$_[4], $_[2]+$_[8]+$_[5], $_[0]+$_[6]+$_[9], 
        $_[1]+$_[7]+$_[10], $_[2]+$_[8]+$_[11]),
    paral ($_[0]+$_[3], $_[1]+$_[4], $_[2]+$_[5], $_[0]+$_[3]+$_[6], 
        $_[1]+$_[4]+$_[7], $_[2]+$_[5]+$_[8], $_[0]+$_[3]+$_[9], 
        $_[1]+$_[4]+$_[10], $_[2]+$_[5]+$_[11]);
    }

=for noone
@t= (    #    |        |        |        |       |
    pill (1, 1, 1, 2, 0, 0, 0, 2, 0, 0, 0, 8),
    pill (7, 1, 1, 2, 0, 0, 0, 2, 0, 0, 0, 8),
    pill (1, 7, 1, 2, 0, 0, 0, 2, 0, 0, 0, 8),
    pill (7, 7, 1, 2, 0, 0, 0, 2, 0, 0, 0, 8),
    pill (1, 1, 1, 0, 2, 0, 0, 0, 2, 8, 0, 0),
    pill (1, 7, 1, 0, 2, 0, 0, 0, 2, 8, 0, 0),
    pill (1, 1, 7, 0, 2, 0, 0, 0, 2, 8, 0, 0),
    pill (1, 7, 7, 0, 2, 0, 0, 0, 2, 8, 0, 0),
    pill (1, 1, 1, 0, 0, 2, 2, 0, 0, 0, 8, 0),
    pill (1, 1, 7, 0, 0, 2, 2, 0, 0, 0, 8, 0),
    pill (7, 1, 1, 0, 0, 2, 2, 0, 0, 0, 8, 0),
    pill (7, 1, 7, 0, 0, 2, 2, 0, 0, 0, 8, 0),
    );

=cut

@t= (    #    |        |        |        |       |
    pill (1, 1, 1, 1, 0, 0, 0, 1, 0, 0, 0, 8),
    pill (8, 1, 1, 1, 0, 0, 0, 1, 0, 0, 0, 8),
    pill (1, 8, 1, 1, 0, 0, 0, 1, 0, 0, 0, 8),
    pill (8, 8, 1, 1, 0, 0, 0, 1, 0, 0, 0, 8),
    pill (1, 1, 1, 0, 1, 0, 0, 0, 1, 8, 0, 0),
    pill (1, 8, 1, 0, 1, 0, 0, 0, 1, 8, 0, 0),
    pill (1, 1, 8, 0, 1, 0, 0, 0, 1, 8, 0, 0),
    pill (1, 8, 8, 0, 1, 0, 0, 0, 1, 8, 0, 0),
    pill (1, 1, 1, 0, 0, 1, 1, 0, 0, 0, 8, 0),
    pill (1, 1, 8, 0, 0, 1, 1, 0, 0, 0, 8, 0),
    pill (8, 1, 1, 0, 0, 1, 1, 0, 0, 0, 8, 0),
    pill (8, 1, 8, 0, 0, 1, 1, 0, 0, 0, 8, 0),
    Triangle->init3 (0, 2, 5, 1, 5, 0, 3, 0, 2),
    );

        
=for noone
@t= (
    Triangle->init3 (0.9, 0.5, 0.5, 0.1, 0.5, 0.5, 0.5, 0.9, 0.5),
    Triangle->init3 (0.9, 0.5, 0.5, 0.1, 0.5, 0.5, 0.5, 0.1, 0.5),
    Triangle->init3 (0.5, 0.9, 0.5, 0.5, 0.1, 0.5, 0.5, 0.5, 0.9),
    Triangle->init3 (0.5, 0.9, 0.5, 0.5, 0.1, 0.5, 0.5, 0.5, 0.1),
    Triangle->init3 (0.5, 0.5, 0.9, 0.5, 0.5, 0.1, 0.9, 0.5, 0.5),
    Triangle->init3 (0.5, 0.5, 0.9, 0.5, 0.5, 0.1, 0.1, 0.5, 0.5),
    #
    Triangle->init3 (0.9, 0.5, 0.5, 0.5, 0.9, 0.5, 0.5, 0.5, 0.9),
    Triangle->init3 (0.1, 0.5, 0.5, 0.5, 0.1, 0.5, 0.5, 0.5, 0.9),
    Triangle->init3 (0.1, 0.5, 0.5, 0.5, 0.9, 0.5, 0.5, 0.5, 0.1),
    Triangle->init3 (0.9, 0.5, 0.5, 0.5, 0.1, 0.5, 0.5, 0.5, 0.1),
    );

=cut


#push @t, Triangle->prand (2);

# |perl -we 'use List::Util; print List::Util::shuffle(<STDIN>);'|
@color= (
    "0.5 0.5 1.0",
    "0.8 0.5 1.0",
    "0.5 1.0 0.5",
    "1.0 0.5 0.8",
    "0.5 1.0 0.8",
    "1.0 0.8 0.5",
    "1.0 0.5 0.5",
    "1.0 1.0 0.5",
    "0.8 0.8 0.2",
    );


#$t[$_]->setcolor ($color[$_/2%@color]) for 0..$#t;
$t[$_]->setcolor ($color[rand(@color)]) for 0..$#t;

sub PI () { 2* atan2 (1, 0); }

my ($zb, $i, $j, $rox, $roy);

$zb= Zbuf->new (1000, 720);

$rox= rand ();
$roy= rand ();

sub draw {
    my (@a, @b, $p);
    print STDERR ":";
    $p= Transf->scale (0.1, 0.1, 0.1);
    $p= $p->compose (Transf->translate (-0.5, -0.5, -0.5));
    $p= $p->compose (Transf->turnx (($_[1]+$rox)*PI/5));
    $p= $p->compose (Transf->turny (($_[0]-$roy)*2*PI/5));
    $p= $p->compose ($persp);
    $p= $p->compose (Transf->scale (140, 140, 140));
    $p= $p->compose (Transf->translate (100+200*$_[0], 40+200*$_[1], 4
+00));
    @a= map {$_->transf ($p)} @t;
    $zb->ins ($_) for @a;
    }
    

warn "rendering image";

for $i (0..4) {
    for $j (0..3) {
        draw ($i, $j);
        }
    }

print STDERR "\n";

$zb->print ();


}



__END__
[download]