(phixonline)-->
--
-- demo\rosetta\Draw_a_sphere.exw
-- ==============================
--
with javascript_semantics
include pGUI.e
constant title = "Draw a sphere"
Ihandle dlg, canvas
cdCanvas cddbuffer, cdcanvas
function dot(sequence x, y)
return sum(sq_mul(x,y))
end function
function normalize(sequence v)
atom len = sqrt(dot(v, v))
return iff(len=0?{0,0,0}:sq_mul(v,1/len))
end function
procedure drawSphere(integer width, height, atom k, amb, sequence direction)
atom t0 = time()+1, t1 = t0,
lmul = 255/(1+amb)
integer r = floor((min(width,height)-20)/2),
cx = floor(width/2),
cy = floor(height/2)
for x=-r to r do
if time()>t1 then
-- Let the user know we aren't completely dead just yet
IupSetStrAttribute(dlg,"TITLE","%s - drawing (%d%%)",{title,100*(x+r)/(2*r)})
t1 = time()+1
-- (as per DeathStar.exw, prevent "(Not Responding)" nonsense)
if platform()!=JS then
if IupLoopStep()=IUP_CLOSE then
IupExitLoop()
exit
end if
end if
end if
for y=-r to r do
integer z = r*r-(x*x+y*y)
if z>=0 then
atom s = dot(direction, normalize({x,y,sqrt(z)})),
l = iff(s<=0?0:power(s,k))
integer lum = and_bits(#FF,lmul*(l+amb))
cdCanvasPixel(cddbuffer, x+cx, y+cy, lum*#10101)
end if
end for
end for
if t1!=t0 then
IupSetStrAttribute(dlg,"TITLE",title)
end if
end procedure
function redraw_cb(Ihandle /*ih*/, integer /*posx*/, /*posy*/)
integer {width, height} = IupGetIntInt(canvas, "DRAWSIZE")
cdCanvasActivate(cddbuffer)
cdCanvasClear(cddbuffer)
drawSphere(width,height,1.5,0.2,normalize({-30,-30,50}))
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
procedure main()
IupOpen()
canvas = IupCanvas("RASTERSIZE=340x340")
IupSetCallbacks(canvas, {"MAP_CB", Icallback("map_cb"),
"ACTION", Icallback("redraw_cb")})
dlg = IupDialog(canvas,`TITLE="%s"`,{title})
IupShow(dlg)
IupSetAttribute(canvas, "RASTERSIZE", NULL) -- release the minimum limitation
if platform()!=JS then
IupMainLoop()
IupClose()
end if
end procedure
main()