Galton box animation: Difference between revisions
→{{header|Phix}}
(→{{header|Haskell}}: Added solution using GLOSS) |
|||
Line 1,674:
simulate($coins);
}</lang>
=={{header|Phix}}==
First, a console version:
<lang Phix>constant balls = 80
clear_screen()
sequence screen = repeat(repeat(' ',23),12)
& repeat(join(repeat(':',12)),12)
& {repeat('.',23)},
Pxy = repeat({12,1},balls)
for peg=1 to 10 do
screen[peg+2][13-peg..11+peg] = join(repeat('.',peg))
end for
puts(1,join(screen,"\n"))
text_color(BRIGHT_RED)
bool moved = true
integer top = ' ' -- (new drop every other iteration)
while moved or top!=' ' do
moved = false
for i=1 to balls do
integer {Px,Py} = Pxy[i]
if Py!=1 or top=' ' then
integer Dx = 0, Dy = 0
if screen[Py+1,Px]=' ' then -- can vertical?
Dy = 1
else
Dx = {-1,+1}[rand(2)] -- try l;r or r;l
if screen[Py+1,Px+Dx]!=' ' then Dx = -Dx end if
if screen[Py+1,Px+Dx]==' ' then
Dy = 1
end if
end if
if Dy then
position(Py,Px) puts(1," ") screen[Py,Px] = ' '
Px += Dx
Py += Dy
position(Py,Px) puts(1,"o") screen[Py,Px] = 'o'
Pxy[i] = {Px,Py}
moved = true
if Py=2 then top = 'o' end if
end if
end if
end for
position(26,1)
sleep(0.2)
if get_key()!=-1 then exit end if
top = screen[2][12]
end while</lang>
{{out}}
<pre>
.o
. .
.o. .
. . . .
. .o. . .
. . . . . .
. . . . .o. .
. . . . . . . .
. . . . .o. . . .
. . . . . . . . . .
: : : : :o: : : : : : :
: : : : : : : : : : : :
: : : : : : : : :o: : :
: : : : : : : : : : : :
: : : : : : : :o: : : :
: : : : : : : : : : : :
: : : : :o:o:o: : : : :
: : : : :o:o:o: : : : :
: : :o: :o:o:o: : : : :
: : : : :o:o:o:o: : : :
: : : :o:o:o:o:o: : : :
: : :o:o:o:o:o:o: : : :
.......................
</pre>
Also, here is a slightly nicer and resize-able gui version:
<lang Phix>--
-- demo\rosetta\GaltonBox.exw
-- ==========================
--
constant TITLE = "Galton Box"
include pGUI.e
Ihandle dlg, canvas, timershow
cdCanvas cddbuffer, cdcanvas
integer brem = 80
sequence balls = {{0,1,0}}
sequence bins = repeat(0,8)
function redraw_cb(Ihandle /*ih*/, integer /*posx*/, integer /*posy*/)
integer {w, h} = IupGetIntInt(canvas, "DRAWSIZE"), x, y
atom xx, yy
cdCanvasActivate(cddbuffer)
cdCanvasClear(cddbuffer)
-- draw the pins, then balls, then bins
cdCanvasSetForeground(cddbuffer, CD_DARK_GREEN)
integer pinsize = min(floor(h/40),floor(w/50))
for y=4 to 16 by 2 do
for x=-(y-4) to (y-4) by 4 do
xx = w/2 + x*w/32
yy = h -y*h/32
cdCanvasSector(cddbuffer, xx, yy, pinsize, pinsize, 0, 360)
end for
end for
cdCanvasSetForeground(cddbuffer, CD_INDIGO)
for i=1 to length(balls) do
{x, y} = balls[i]
xx = w/2 + x*w/32
yy = h -y*h/32
cdCanvasSector(cddbuffer, xx, yy, pinsize*4, pinsize*4, 0, 360)
end for
cdCanvasLineWidth(cddbuffer,w/9)
for i=1 to length(bins) do
xx = w/2+(i*4-18)*w/32
yy = bins[i]*h/64+10
cdCanvasLine(cddbuffer,xx,10,xx,yy)
end for
cdCanvasFlush(cddbuffer)
return IUP_DEFAULT
end function
function timer_cb(Ihandle ih)
integer x, y=9, dx
if length(balls) then
{x,y,dx} = balls[1]
if y>20 then
bins[(x+18)/4] += 1
balls = balls[2..$]
end if
end if
for i=1 to length(balls) do
{x,y,dx} = balls[i]
if y>15 then
dx = 0
elsif and_bits(y,1)=0 then
dx = {-1,+1}[rand(2)]
end if
balls[i] = {x+dx,y+1,dx}
end for
if y>4 and brem!=0 then
brem -= 1
balls = append(balls,{0,1,0})
end if
if brem=0 and length(balls)=0 then
IupSetAttribute(timershow,"RUN","NO")
end if
IupUpdate(canvas)
return IUP_IGNORE
end function
function map_cb(Ihandle ih)
cdcanvas = cdCreateCanvas(CD_IUP, ih)
cddbuffer = cdCreateCanvas(CD_DBUFFER, cdcanvas)
cdCanvasSetBackground(cddbuffer, CD_GREY)
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", "640x380")
IupSetCallback(canvas, "MAP_CB", Icallback("map_cb"))
IupSetCallback(canvas, "ACTION", Icallback("redraw_cb"))
timershow = IupTimer(Icallback("timer_cb"), 80)
dlg = IupDialog(canvas)
IupSetAttribute(dlg, "TITLE", TITLE)
IupSetCallback(dlg, "K_ANY", Icallback("esc_close"))
IupShow(dlg)
IupSetAttribute(canvas, "RASTERSIZE", NULL)
IupMainLoop()
IupClose()
end procedure
main()</lang>
=={{header|PicoLisp}}==
| |||