I found a perl program I wrote ages ago. This renders three-dimensional vector graphics (hollow cubes made of triangles) by hand using a z-buffer.
Redirect the output to a file. It's a ppm image. View it with an image viewer.
The rendering is not perfect, you can see some ugly horizontal stripes where two triangles are coplanar and overlapping. (Perlmonks suggests that "If something looked unlike you expected it to you might need to check out Writeup Formatting Tips" but that page doesn't help. Yes, I previewed the image again and again, but I have no idea how to fix it. So someone tell me how to fix it and improve the autosuggest system of this site.)
#!/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__
In reply to Old 3-d cubes rendering code by ambrus
| For: | Use: | ||
| & | & | ||
| < | < | ||
| > | > | ||
| [ | [ | ||
| ] | ] |