Another update from ingydotnet^djgoku
This commit is contained in:
Ingy döt Net
parent
91df62d461
commit
948b86eafa
7604 changed files with 108452 additions and 22726 deletions
40
Task/Death-Star/J/death-star.j
Normal file
40
Task/Death-Star/J/death-star.j
Normal file
|
|
@ -0,0 +1,40 @@
|
|||
load'graphics/viewmat'
|
||||
mag =: +/&.:*:"1
|
||||
norm=: %"1 0 mag
|
||||
dot =: +/@:*"1
|
||||
|
||||
NB. (pos;posr;neg;negr) getvec (x,y)
|
||||
getvec =: 4 :0 "1
|
||||
pt =. y
|
||||
'pos posr neg negr' =. x
|
||||
if. (dot~ pt-}:pos) > *:posr do.
|
||||
0 0 0
|
||||
else.
|
||||
zb =. ({:pos) (-,+) posr -&.:*: pt mag@:- }:pos
|
||||
if. (dot~ pt-}:neg) > *:negr do.
|
||||
(pt,{:zb) - pos
|
||||
else.
|
||||
zs =. ({:neg) (-,+) negr -&.:*: pt mag@:- }:neg
|
||||
if. zs >&{. zb do. (pt,{:zb) - pos
|
||||
elseif. zs >&{: zb do. 0 0 0
|
||||
elseif. ({.zs) < ({:zb) do. neg - (pt,{.zs)
|
||||
elseif. do. (pt,{.zb) - pos end.
|
||||
end.
|
||||
end.
|
||||
)
|
||||
|
||||
|
||||
NB. (k;ambient;light) draw_sphere (pos;posr;neg;negr)
|
||||
draw_sphere =: 4 :0
|
||||
'pos posr neg negr' =. y
|
||||
'k ambient light' =. x
|
||||
vec=. norm y getvec ,"0// (2{.pos) +/ i: 200 j.~ 0.5+posr
|
||||
|
||||
b=. (mag vec) * ambient + k * 0>. light dot vec
|
||||
)
|
||||
|
||||
togray =: 256#. 255 255 255 <.@*"1 0 (%>./@,)
|
||||
|
||||
env=.(2; 0.5; (norm _50 30 50))
|
||||
sph=. 20 20 0; 20; 1 1 _6; 20
|
||||
'rgb' viewmat togray env draw_sphere sph
|
||||
|
|
@ -33,7 +33,7 @@ sub MAIN ($outfile = 'deathstar-perl6.pgm') {
|
|||
my $out = open( $outfile, :w, :bin ) or die "$!\n";
|
||||
$out.say("P5\n$x $y\n$depth"); # .pgm header
|
||||
say 'Calculating row:';
|
||||
$out.print( draw_ds(3, .15)».chrs );
|
||||
$out.write( Blob.new( draw_ds(3, .15) ) );
|
||||
$out.close;
|
||||
}
|
||||
|
||||
|
|
@ -41,7 +41,7 @@ sub draw_ds ( $k, $ambient ) {
|
|||
my @pixels;
|
||||
my $bs = "\b" x 8;
|
||||
for ($pos.cy - $pos.r) .. ($pos.cy + $pos.r) -> $y {
|
||||
note $bs, $y, ' '; # monitor progress
|
||||
print $bs, $y, ' '; # monitor progress
|
||||
for ($pos.cx - $pos.r) .. ($pos.cx + $pos.r) -> $x {
|
||||
# black if we don't hit positive sphere, ignore negative sphere
|
||||
if not hit($pos, $x, $y, my $posz) {
|
||||
|
|
@ -69,10 +69,10 @@ sub draw_ds ( $k, $ambient ) {
|
|||
}
|
||||
|
||||
# normalize a vector
|
||||
sub normalize (@vec) { return @vec »/» ([+] @vec Z* @vec).sqrt }
|
||||
sub normalize (@vec) { return @vec »/» ([+] @vec »*« @vec).sqrt }
|
||||
|
||||
# dot product of two vectors
|
||||
sub dot (@x, @y) { return -([+] @x Z* @y) max 0 }
|
||||
sub dot (@x, @y) { return -([+] @x »*« @y) max 0 }
|
||||
|
||||
# are the coordinates within the radius of the sphere?
|
||||
sub hit ($sphere, $x is copy, $y is copy, $z is rw) {
|
||||
|
|
|
|||
|
|
@ -1,75 +1,58 @@
|
|||
/*REXX program to draw a "deathstar", a sphere with another subtracted. */
|
||||
signal on syntax; signal on noValue /*handle REXX program errors. */
|
||||
numeric digits 20 /*use a fair amount of precision.*/
|
||||
lightSource = norm('-50 30 50')
|
||||
call drawSphereM 2, .5, lightSource
|
||||
exit /*stick a fork in it, we're done.*/
|
||||
/*──────────────────────────────────DRAWSPHEREM subroutine──────────────*/
|
||||
drawSphereM: procedure; parse arg k,ambient,lightSource
|
||||
z1=0; z2=0
|
||||
parse var lightSource s1 s2 s3 /*break-apart the light source. */
|
||||
/*REXX pgm draws a sphere with another sphere subtracted where superimposed. */
|
||||
call deathStar 2, .5, v3('-50 30 50')
|
||||
exit /*stick a fork in it, we're all done. */
|
||||
/*──────────────────────────────────one─liner subroutines────────────────────────────────────────*/
|
||||
dot.: procedure; parse arg x,y; d=dot(x,y); if d<0 then return -d; return 0
|
||||
dot: procedure; parse arg x,y; s=0; do j=1 for words(x); s=s+word(x,j)*word(y,j); end; return s
|
||||
ceil: procedure; parse arg x; _=trunc(x); return _+(x>0)*(x\=_)
|
||||
floor: procedure; parse arg x; _=trunc(x); return _-(x<0)*(x\=_)
|
||||
v3: procedure; parse arg a b c; s=sqrt(a**2+b**2+c**2); return a/s b/s c/s
|
||||
/*──────────────────────────────────DEATHSTAR subroutine──────────────────────*/
|
||||
deathStar: procedure; parse arg k,ambient,sun /* [↓] draw deathstar*/
|
||||
parse var sun s1 s2 s3 /*identify the lightsource coördinates.*/
|
||||
|
||||
shading='·:!ºoe@░▒▓' /*shading chars for ASCI machines*/
|
||||
if 1=='f1'x then shading='.:!*oe&#%@' /*shading chars for EBCDIC machs.*/
|
||||
if 6=='f6'x then shading= '.:!*oe&#%@' /*shading characters for EBCDIC machine*/
|
||||
else shading= '·:!ºoe@░▒▓' /* " " " ASCII " */
|
||||
|
||||
shadesLength=length(shading)
|
||||
shades.=' '; do i=1 for shadesLength
|
||||
shades.i=substr(shading,i,1)
|
||||
end /*i*/
|
||||
shadesLen=length(shading)
|
||||
shades.=' '; do i=1 for shadesLen; shades.i=substr(shading,i,1); end /*i*/
|
||||
|
||||
ship= 20 20 0 20 ; parse var ship ship.cx ship.cy ship.cz ship.radius
|
||||
hole=' 1 1 -6 20'; parse var hole hole.cx hole.cy hole.cz hole.radius
|
||||
ship= 20 20 0 20 ; parse var ship ship.cx ship.cy ship.cz ship.radius
|
||||
hole=' 1 1 -6 20'; parse var hole hole.cx hole.cy hole.cz hole.radius
|
||||
|
||||
do i=floor(ship.cy-ship.radius) to ceil(ship.cy+ship.radius)+1; y=i+.5; aLine=
|
||||
do j=trunc(floor(ship.cx - 2*ship.radius) ) to ,
|
||||
trunc( ceil(ship.cx + 2*ship.radius) +1)
|
||||
x=.5*(j-ship.cx) + .5 + ship.cx; !bg=0; !pos=0; !neg=0; z1=0; z2=0
|
||||
?=hitSphere(ship, x, y); zb1=z1; zb2=z2
|
||||
do i=floor(ship.cy-ship.radius) to ceil(ship.cy+ship.radius) +1; y=i+.5; $=
|
||||
do j=trunc(floor(ship.cx-2*ship.radius)) to trunc(ceil(ship.cx+2*ship.radius) +1)
|
||||
x=.5*(j-ship.cx)+.5+ship.cx; !.=0
|
||||
?=hitSphere(ship, x, y); b1=!.z1; b2=!.z2 /*? is boolean, "true" indicates ray hits the sphere.*/
|
||||
|
||||
if \? then !bg=1 /*ray lands in blank space, draw the background. */
|
||||
else do
|
||||
?=hitsphere(hole, x, y); zs1=z1; zs2=z2
|
||||
if \? then !pos=1 /*ray hits ship but not the hole, draw ship surface. */
|
||||
else if zs1>zb1 then !pos=1 /*ray hits both, but ship front surface is closer. */
|
||||
else if zs2>zb2 then !bg=1 /*ship surface is inside hole, show background. */
|
||||
else if zs2>zb1 then !neg=1 /*back surface in hole is inside ship, the only place hole surface will be shown.*/
|
||||
else !pos=1
|
||||
if \? then !.bg=1 /*ray lands in blank space, so draw the background. */
|
||||
else do; ?=hitSphere(hole, x, y); s1=!.z1; s2=!.z2
|
||||
if \? then !.pos=1 /*ray hits ship but not the hole, so draw ship surface. */
|
||||
else if s1>b1 then !.pos=1 /*ray hits both, but ship front surface is closer. */
|
||||
else if s2>b2 then !.bg=1 /*ship surface is inside hole, so show the background. */
|
||||
else if s2>b1 then !.neg=1 /*hole back surface is inside ship; the only place hole surface will be shown.*/
|
||||
else !.pos=1
|
||||
end
|
||||
select
|
||||
when !bg then do; aLine=aLine' '; iterate j; end
|
||||
when !pos then vec_=V3(x-ship.cx y-ship.cy zb1-ship.cz)
|
||||
when !neg then vec_=V3(hole.cx-x hole.cy-y hole.cz-zs2)
|
||||
when !.bg then do; $=$' '; iterate j; end /*append a blank to the line to be displayed.*/
|
||||
when !.pos then vec_=v3(x-ship.cx y-ship.cy b1-ship.cz)
|
||||
when !.neg then vec_=v3(hole.cx-x hole.cy-y hole.cz-s2)
|
||||
end /*select*/
|
||||
|
||||
nvec=norm(vec_)
|
||||
b=dot.(lightSource,nvec)**k + ambient
|
||||
intensity=trunc((1-b) * shadesLength)
|
||||
intensity=min(shadesLength, max(0, intensity)) + 1
|
||||
aLine=aLine || shades.intensity
|
||||
end /*j*/
|
||||
b=1+min(shadesLen,max(0,trunc((1-(dot.(sun,v3(vec_))**k+ambient))*shadesLen)))
|
||||
$=$ || shades.b /*B is the ray's intensity│brightness*/
|
||||
end /*j*/ /* [↑] build line for showing sphere.*/
|
||||
|
||||
if aline\='' then say strip(aLine,'T')
|
||||
end /*i*/
|
||||
if $\='' then say strip($,'T') /*strip any trailing blanks from line.*/
|
||||
end /*i*/ /* [↑] show all lines for the sphere.*/
|
||||
|
||||
return
|
||||
/*──────────────────────────────────HITSPHERE subroutine────────────────*/
|
||||
hitSphere: procedure expose z1 z2; parse arg $.cx $.cy $.cz $.radius, x0, y0
|
||||
x=x0-$.cx
|
||||
y=y0-$.cy
|
||||
zsq=$.radius**2 - (x**2 + y**2); if zsq<0 then return 0
|
||||
_=sqrt(zsq)
|
||||
z1=$.cz-_
|
||||
z2=$.cz+_
|
||||
return 1
|
||||
/*──────────────────────────────────one─liner subroutines────────────────────────────────────────────────────────────────────────────────────────────────────────*/
|
||||
dot.: procedure; parse arg x,y; d=dot(x,y); if d<0 then return -d; return 0
|
||||
dot: procedure; parse arg x,y; s=0; do j=1 for words(x); s=s+word(x,j)*word(y,j); end; return s
|
||||
err: say; say; say center(' error! ',max(40,linesize()%2),"*"); say; do j=1 for arg(); say arg(j); say; end; say; exit 13
|
||||
ceil: procedure; parse arg x; _=trunc(x); return _ + (x>0) * (x\=_)
|
||||
floor: procedure; parse arg x; _=trunc(x); return _ - (x<0) * (x\=_)
|
||||
norm: parse arg _1 _2 _3; _=sqrt(_1**2+_2**2+_3**2); return _1/_ _2/_ _3/_
|
||||
noValue: syntax: call err 'REXX program' condition('C') "error", condition('D'),'REXX source statement (line' sigl"):",sourceline(sigl)
|
||||
sqrt: procedure; parse arg x; if x=0 then return 0; return .sqrt(x)/1
|
||||
.sqrt: d=digits();numeric digits 11;g=.sqrtG();do j=0 while p>9;m.j=p;p=p%2+1;end;do k=j+5 by -1 to 0;if m.k>11 then numeric digits m.k;g=.5*(g+x/g);end;return g
|
||||
.sqrtG: numeric form; m.=11; p=d+d%4+2; v=format(x,2,1,,0) 'E0'; parse var v g 'E' _ .; return g*.5'E'_%2
|
||||
V3: procedure; parse arg v; return norm(v)
|
||||
/*──────────────────────────────────HITSPHERE subroutine──────────────────────────*/
|
||||
hitSphere: procedure expose !.; parse arg xx yy zz r,x0,y0; x=x0-xx; y=y0-yy
|
||||
z=r**2-(x**2+y**2); if z<0 then return 0; _=sqrt(z); !.z1=zz-_; !.z2=zz+_; return 1
|
||||
/*──────────────────────────────────SQRT subroutine───────────────────────────*/
|
||||
sqrt: procedure; parse arg x; if x=0 then return 0; d=digits(); i=; m.=9
|
||||
numeric digits 9; numeric form; h=d+6; if x<0 then do; x=-x; i='i'; end
|
||||
parse value format(x,2,1,,0) 'E0' with g 'E' _ .; g=g*.5'e'_%2
|
||||
do j=0 while h>9; m.j=h; h=h%2+1; end /*j*/
|
||||
do k=j+5 to 0 by -1; numeric digits m.k; g=(g+x/g)*.5; end /*k*/
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue