#!/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, $zb),
# 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], 400));
	@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__