September 2017 Update
This commit is contained in:
Ingy döt Net
parent
bba7bfd280
commit
ba8067c3b7
14570 changed files with 153136 additions and 63871 deletions
|
|
@ -3,7 +3,7 @@
|
|||
{{omit from|ML/I}}
|
||||
{{omit from|Retro}}
|
||||
|
||||
[[File:Deathstar-tcl.gif|300px|thumb]]
|
||||
[[File:Deathstar-tcl.gif|400px|thumb]]
|
||||
|
||||
;Task:
|
||||
Display a region that consists of a large sphere with part of a smaller sphere removed from it as a result of geometric subtraction.
|
||||
|
|
|
|||
|
|
@ -1,39 +0,0 @@
|
|||
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
|
||||
|
|
@ -1,54 +0,0 @@
|
|||
load'graphics/viewmat'
|
||||
|
||||
resolution=: 8
|
||||
spheres=: 3 1 #"1 ] 0 1,_1 1,:0.3 0.6 NB. spheres x y z r
|
||||
|
||||
|
||||
coordinates=: (% <:)~ (,"1 0~"0 3 ,"0"1 0~)@:i:
|
||||
length=: +/ &.: *:
|
||||
centers=: _ 3&{.
|
||||
radii=: _ _1&{.
|
||||
|
||||
NB. resolution SlicePittedSphere spheres generates a binary array, 1 in the geometric object
|
||||
SlicePittedSphere=: (0 { {. > [: +./ }.)@:(radii@[ >:"0 3 ((length@:-"1"_ 1 centers)~ coordinates))~
|
||||
|
||||
spanTo=: conjunction def '(m<:y)*.y<:n' NB. algebraic similarity, m <= y <= n
|
||||
|
||||
tessellate=: ] ];._3"3~ 3 # [ NB. All cubical edge length x subarrays of array y
|
||||
|
||||
NB. Define "faces" as those points with 9 to 18 inclusive "solid" neighbors.
|
||||
detectFace=: (9 spanTo 18) @: (+/@:,"3) @: (3&tessellate)
|
||||
|
||||
NB. arrange faces in ANSYS brick face order
|
||||
ThickFaces=: ((|:"3 , (, |:"2))(,: |."1)3 3 3$2j1#1) /: 'SENWDU' i. 'DUEWSN'
|
||||
ThinFaces=: ((|:"3 , (, |:"2))(,: |."1)3 3 3$1j2#1) /: 'SENWDU' i. 'DUEWSN'
|
||||
|
||||
FACES=:ThickFaces NB. 6 below comes from #Faces
|
||||
|
||||
NORMALS=: 2 tessellate FACES
|
||||
|
||||
matchNormals=: [: +/@,"6 NORMALS ="6"6 _ (2 tessellate 3 tessellate ])
|
||||
|
||||
bestFit=: (i.>./)"1&.|:
|
||||
|
||||
topFace=: detectFace i:"1 1:
|
||||
|
||||
choose=: 4 : 'x}y'
|
||||
|
||||
viewmat resolution (topFace choose (,&(#FACES))@:bestFit@matchNormals)@SlicePittedSphere spheres
|
||||
|
||||
|
||||
<"_1 ThickFaces NB. display the 6 cubes with reference faces
|
||||
┌─────┬─────┬─────┬─────┬─────┬─────┐
|
||||
│1 1 1│1 1 0│0 0 0│0 1 1│1 1 1│0 0 0│
|
||||
│1 1 1│1 1 0│1 1 1│0 1 1│1 1 1│0 0 0│
|
||||
│0 0 0│1 1 0│1 1 1│0 1 1│1 1 1│0 0 0│
|
||||
│ │ │ │ │ │ │
|
||||
│1 1 1│1 1 0│0 0 0│0 1 1│1 1 1│1 1 1│
|
||||
│1 1 1│1 1 0│1 1 1│0 1 1│1 1 1│1 1 1│
|
||||
│0 0 0│1 1 0│1 1 1│0 1 1│1 1 1│1 1 1│
|
||||
│ │ │ │ │ │ │
|
||||
│1 1 1│1 1 0│0 0 0│0 1 1│0 0 0│1 1 1│
|
||||
│1 1 1│1 1 0│1 1 1│0 1 1│0 0 0│1 1 1│
|
||||
│0 0 0│1 1 0│1 1 1│0 1 1│0 0 0│1 1 1│
|
||||
└─────┴─────┴─────┴─────┴─────┴─────┘
|
||||
|
|
@ -30,8 +30,8 @@ my $neg = sphere.new(
|
|||
);
|
||||
|
||||
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
|
||||
spurt $outfile, ("P5\n$x $y\n$depth"); # .pgm header
|
||||
my $out = open( $outfile, :a, :bin ) or die "$!\n";
|
||||
say 'Calculating row:';
|
||||
$out.write( Blob.new( draw_ds(3, .15) ) );
|
||||
$out.close;
|
||||
|
|
|
|||
103
Task/Death-Star/Phix/death-star.phix
Normal file
103
Task/Death-Star/Phix/death-star.phix
Normal file
|
|
@ -0,0 +1,103 @@
|
|||
--
|
||||
-- demo\rosetta\DeathStar.exw
|
||||
--
|
||||
include pGUI.e
|
||||
|
||||
Ihandle dlg, canvas
|
||||
cdCanvas cddbuffer, cdcanvas
|
||||
|
||||
function dot(sequence x, sequence y)
|
||||
return sum(sq_mul(x,y))
|
||||
end function
|
||||
|
||||
function normalize(sequence v)
|
||||
atom len = sqrt(dot(v, v))
|
||||
if len=0 then return {0,0,0} end if
|
||||
return sq_mul(v,1/len)
|
||||
end function
|
||||
|
||||
enum X,Y,Z
|
||||
|
||||
function hit(sequence s, atom x, y, atom r)
|
||||
x -= s[X]
|
||||
y -= s[Y]
|
||||
atom zsq := r*r - (x*x + y*y)
|
||||
if zsq >= 0 then
|
||||
atom zsqrt := sqrt(zsq)
|
||||
return {s[Z] - zsqrt, s[Z] + zsqrt, true}
|
||||
end if
|
||||
return {0, 0, false}
|
||||
end function
|
||||
|
||||
procedure deathStar(integer width, height, atom k, atom amb, sequence direction)
|
||||
integer lum
|
||||
sequence vec
|
||||
integer r = floor((min(width,height)-40)/2)
|
||||
integer cx = floor(width/2)
|
||||
integer cy = floor(height/2)
|
||||
sequence pos = {0,0,0},
|
||||
neg = {r*-3/4,r*-3/4,r*-1/4}
|
||||
|
||||
for y = pos[Y]-r to pos[Y]+r do
|
||||
for x = pos[X]-r to pos[X]+r do
|
||||
atom {zb1, zb2, hit1} := hit(pos, x, y, r)
|
||||
if hit1 then
|
||||
atom {zs1, zs2, hit2} := hit(neg, x, y, r/2)
|
||||
if not hit2 or zs2<=zb2 then
|
||||
if hit2 and zs1<=zb1 then
|
||||
vec = {neg[X] - x, neg[Y] - y, neg[Z] - zs2}
|
||||
else
|
||||
vec = {x - pos[X], y - pos[Y], zb1 - pos[Z]}
|
||||
-- vec = {x, y, zb1}
|
||||
end if
|
||||
atom s = dot(direction, normalize(vec))
|
||||
lum = and_bits(#FF,255*(iff(s<0?0:power(s,k))+amb)/(1+amb))
|
||||
lum += lum*#100+lum*#10000
|
||||
cdCanvasPixel(cddbuffer, cx+x, cy-y, lum)
|
||||
end if
|
||||
end if
|
||||
end for
|
||||
end for
|
||||
end procedure
|
||||
|
||||
function redraw_cb(Ihandle /*ih*/, integer /*posx*/, integer /*posy*/)
|
||||
integer {width, height} = IupGetIntInt(canvas, "DRAWSIZE")
|
||||
cdCanvasActivate(cddbuffer)
|
||||
cdCanvasClear(cddbuffer)
|
||||
deathStar(width, height, 1.5, 0.2, normalize({20, -40, -10}))
|
||||
cdCanvasFlush(cddbuffer)
|
||||
return IUP_DEFAULT
|
||||
end function
|
||||
|
||||
function map_cb(Ihandle ih)
|
||||
cdcanvas = cdCreateCanvas(CD_IUP, ih)
|
||||
cddbuffer = cdCreateCanvas(CD_DBUFFER, cdcanvas)
|
||||
cdCanvasSetBackground(cddbuffer, CD_BLACK)
|
||||
return IUP_DEFAULT
|
||||
end function
|
||||
|
||||
function esc_close(Ihandle /*ih*/, atom c)
|
||||
if c=K_ESC then return IUP_CLOSE end if
|
||||
return IUP_CONTINUE
|
||||
end function
|
||||
|
||||
procedure main()
|
||||
IupOpen()
|
||||
|
||||
canvas = IupCanvas(NULL)
|
||||
IupSetAttribute(canvas, "RASTERSIZE", "340x340") -- initial size
|
||||
IupSetCallback(canvas, "MAP_CB", Icallback("map_cb"))
|
||||
|
||||
dlg = IupDialog(canvas)
|
||||
IupSetAttribute(dlg, "TITLE", "Draw a sphere")
|
||||
IupSetCallback(dlg, "K_ANY", Icallback("esc_close"))
|
||||
IupSetCallback(canvas, "ACTION", Icallback("redraw_cb"))
|
||||
|
||||
IupMap(dlg)
|
||||
IupSetAttribute(canvas, "RASTERSIZE", NULL) -- release the minimum limitation
|
||||
IupShowXY(dlg,IUP_CENTER,IUP_CENTER)
|
||||
IupMainLoop()
|
||||
IupClose()
|
||||
end procedure
|
||||
|
||||
main()
|
||||
|
|
@ -2,38 +2,38 @@
|
|||
call deathStar 2, .5, v3('-50 30 50')
|
||||
exit /*stick a fork in it, we're all done. */
|
||||
/*──────────────────────────────────────────────────────────────────────────────────────*/
|
||||
dot: #=0; do j=1 for words(x); #=# + word(x,j)*word(y,j); end; return #
|
||||
dot.: procedure; parse arg x,y; d=dot(x,y); if d<0 then return -d; return 0
|
||||
dot: #=0; do j=1 for words(x); #=#+word(x,j)*word(y,j); end; return #
|
||||
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; #=sqrt(a**2 + b**2 + c**2); return a/# b/# c/#
|
||||
v3: procedure; parse arg a b c; #=sqrt(a**2 + b**2 + c**2); return a/# b/# c/#
|
||||
/*──────────────────────────────────────────────────────────────────────────────────────*/
|
||||
sqrt: procedure; parse arg x; if x=0 then return 0; d=digits(); m.=9; numeric digits
|
||||
numeric form; parse value format(x,2,1,,0) 'E0' with g 'E' _ .; g=g * .5'e'_ % 2
|
||||
numeric form; parse value format(x,2,1,,0) 'E0' with g 'E' _ .; g=g * .5'e'_ % 2
|
||||
h=d+6; 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*/
|
||||
numeric digits d; return (g/1)
|
||||
numeric digits d; return g/1
|
||||
/*──────────────────────────────────────────────────────────────────────────────────────*/
|
||||
hitSphere: procedure expose !.; parse arg xx yy zz r,x0,y0; x=x0-xx; y=y0-yy
|
||||
z=r*r-x*x-+y*y; if z<0 then return 0; _=sqrt(z); !.z1=zz-_; !.z2=zz+_; return 1
|
||||
hitSphere: procedure expose !.; parse arg xx yy zz r,x0,y0; z=r*r-(x0-xx)**2-(y0-yy)**2
|
||||
if z<0 then return 0; _=sqrt(z); !.z1=zz-_; !.z2=zz+_; return 1
|
||||
/*──────────────────────────────────────────────────────────────────────────────────────*/
|
||||
deathStar: procedure; parse arg k,ambient,sun /* [↓] display the deathstar to screen*/
|
||||
parse var sun s1 s2 s3 /*identify the light source coördinates*/
|
||||
if 6=='f6'x then shading= '.:!*oe&#%@' /*shading characters for EBCDIC machine*/
|
||||
if 6=="f6"x then shading= '.:!*oe&#%@' /*shading characters for EBCDIC machine*/
|
||||
else shading= '·:!ºoe@░▒▓' /* " " " ASCII " */
|
||||
shadingL=length(shading)
|
||||
shades.=' '; do i=1 for shadingL; shades.i=substr(shading,i,1); end /*i*/
|
||||
shades.=' '; do i=1 for shadingL; shades.i=substr(shading, i, 1); end /*i*/
|
||||
|
||||
ship= 20 20 0 20 ; parse var ship shipX shipY shipZ shipR
|
||||
hole= ' 1 1 -6 20'; parse var hole holeX holeY holeZ .
|
||||
ship= 20 20 0 20 ; parse var ship shipX shipY shipZ shipR
|
||||
hole= ' 1 1 -6 20' ; parse var hole holeX holeY holeZ .
|
||||
|
||||
do i=floor(shipY-shipR) to ceil(shipY+shipR) +1; y=i+.5; @= /*@ is a single line of the deathstar to be displayed.*/
|
||||
do j=floor(shipX-shipR*2) to ceil(shipX+shipR*2)+1
|
||||
x=.5*(j-shipX)+.5+shipX; !.=0; $bg=0; $pos=0; $neg=0 /*$BG, $POS, and $NEG are boolean values. */
|
||||
?=hitSphere(ship, x, y); b1=!.z1; b2=!.z2 /*? is boolean, "true" indicates ray hits the sphere.*/
|
||||
do i=floor(shipY-shipR ) to ceil(shipY+shipR )+1; y=i+.5; @= /*@ is a single line of the deathstar to be displayed.*/
|
||||
do j=floor(shipX-shipR*2) to ceil(shipX+shipR*2)+1; !.=0
|
||||
x=.5 * (j-shipX+1) + shipX; $bg=0; $pos=0; $neg=0 /*$BG, $POS, and $NEG are boolean values. */
|
||||
?=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, so draw the background. */
|
||||
else do; ?=hitSphere(hole, x, y); s1=!.z1; s2=!.z2
|
||||
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. */
|
||||
|
|
@ -41,15 +41,15 @@ hole= ' 1 1 -6 20'; parse var hole holeX holeY holeZ .
|
|||
else $pos=1 /*························· hole surface will be shown.*/
|
||||
end
|
||||
select
|
||||
when $bg then do; @=@' '; iterate j; end /*append a blank character to the line to be displayed. */
|
||||
when $pos then vec_=v3(x-shipX y-shipY b1-shipZ)
|
||||
when $neg then vec_=v3(holeX-x holeY-y holeZ-s2)
|
||||
when $bg then do; @=@' '; iterate j; end /*append a blank character to the line to be displayed. */
|
||||
when $pos then vec_= v3(x-shipX y-shipY b1-shipZ)
|
||||
when $neg then vec_= v3(holeX-x holeY-y holeZ-s2)
|
||||
end /*select*/
|
||||
|
||||
b=1 +min(shadingL, max(0, trunc((1 - (dot.(sun, v3(vec_))**k + ambient)) * shadingL)))
|
||||
@=@ || shades.b /*B the ray's intensity│brightness*/
|
||||
end /*j*/ /* [↑] build a line for the sphere.*/
|
||||
|
||||
if @\='' then say strip(@,'T') /*strip trailing blanks from line. */
|
||||
if @\='' then say strip(@, 'T') /*strip trailing blanks from line. */
|
||||
end /*i*/ /* [↑] show all lines for sphere. */
|
||||
return
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue