Rosetta Code task: Galton Box

[David Drake]

I created the code below for the Rosetta Code task: Galton box animation (rosettacode.org/wiki/Galton_box_animation).  The concept of the Galton box is detailed at the top of the link.  The task is "For the purpose of this task the box should have at least 5 pins on the bottom row. Your solution can use graphics or ASCII animation. Provide a sample of the output/display such as a screenshot.  Your solution can have either one or more balls in flight at the same time. If multiple balls are in flight, ensure they don't interfere with each other.  Your solution should allow users to specify the number of balls or it should run until full  or a preset limit. Optionally, display the number of balls. " 

I enjoyed this one because I created a less sophisticated version for a statistics class.

You will need to download these linked sprites: ball.bmp, pin.bmp

As always, before I post to Rosetta Code, I welcome the community's feedback and comments.



nomainwin
WindowWidth=400
WindowHeight=450
UpperLeftX=1
UpperLeftY=1
textbox #1.tb, 10, 350,370,25
open "Galton Machine" for graphics_nf_nsb as #1
loadbmp "ball","ball.bmp"
loadbmp "pin","pin.bmp"
#1 "trapclose [q];down;fill black;flush"
#1 "getbmp bg 1 1 400 600"
#1 "background bg"
#1 "addsprite ball ball;spriteround ball"

for pinCount = 1 to 28
   #1 "addsprite pin";pinCount;" pin;spriteround pin";pinCount
next pinCount

for y = 1 to 7
   for x = 1 to y
       pin=pin+1
       xp=200-x*50+y*25
       yp=y*35
       #1 "spritexy pin";pin;" ";xp;" ";yp
       #1 "drawsprites"
   next x
next y

prompt "Number of cycles to run: ";cycleMax

[reset]
#1 "spritexy ball 174 1"
#1 "spritemovexy ball 0 5"
timer 1, [move]
wait

[move]
#1 "drawsprites"
#1 "spritecollides ball hits$"
if hits$<>"" then
   direction = rnd(1)
   if direction >0.4999999 then #1 "spritemovexy ball 1 0" else #1 "spritemovexy ball -1 0"
   for a = 1 to 25:#1 "drawsprites":next a
   #1 "spritemovexy ball 0 5"
end if

#1 "spritexy? ball x y"
if y > 280 then
   timer 0
   select case
       case x<49
           slot(1)=slot(1)+1
       case x=49
           slot(2)=slot(2)+1
       case x=99
           slot(3)=slot(3)+1
       case x=149
           slot(4)=slot(4)+1
       case x=199
           slot(5)=slot(5)+1
       case x=249
           slot(6)=slot(6)+1
       case x=299
           slot(7)=slot(7)+1
       case x>299
           slot(8)=slot(8)+1
   end select
   #1.tb, slot(1);"      ";slot(2);"     ";slot(3);"     ";slot(4);"     ";slot(5);"     ";slot(6);"     ";slot(7);"     ";slot(8);" (";cycles+1;")"
   for a = x to 380 step 2
       #1 "spritexy ball ";a;" 280;drawsprites"
   next a
   for b = 300 to 1 step -2
       #1 "spritexy ball 380 ";b;";drawsprites"
   next b
   for c = 380 to 174 step -2
       #1 "spritexy ball ";c;" 1;drawsprites"
   next c
   cycles = cycles + 1
   if cycles >= cycleMax then
       timer 0
       notice "Complete"
       wait
   end if
   goto [reset]
end if

wait

[q]
close #1
unloadbmp "pin"
unloadbmp "ball"
unloadbmp "bg"
end


[Rod]

Nice, one thing, the score line did not line up on my PC because I am not using the same font/size as you. If you specify the font for #1.tb and use a fixed width font the scores will line up for whoever runs the code.

#1.tb "!font courier_new 12" for example, you may need to adjust the spacing when you print the scores.

[tsh73]

I really think bitmaps sprites should be generated on the fly so program could be run as is, without external downloads.
(I may be try to do that, but not before tomorrow)

[David Drake]

Feb 21, 2020 7:58:12 GMT -5 Rod said:

Nice, one thing, the score line did not line up on my PC because I am not using the same font/size as you. If you specify the font for #1.tb and use a fixed width font the scores will line up for whoever runs the code.

#1.tb "!font courier_new 12" for example, you may need to adjust the spacing when you print the scores.

I will try to come up with a better solution.  Thanks for the feedback.

[David Drake]

Feb 21, 2020 9:23:50 GMT -5 tsh73 said:

I really think bitmaps sprites should be generated on the fly so program could be run as is, without external downloads.
(I may be try to do that, but not before tomorrow)

I think I can do that.  I'd thought about it but using what I already had in "inventory" was quicker.  Thanks for your suggestion.

[David Drake]

Updated the code to do several things, including making the counts fit on screen regardless of native font, self-generating sprites and having seven balls falling simultaneously. Also added comments.

[setup]
   nomainwin

   speed=50

   prompt "Number of balls to drop: ";cycleMax
   cycleMax=abs(int(cycleMax))

'create window
   WindowWidth=400
   WindowHeight=470
   UpperLeftX=1
   UpperLeftY=1
   graphicbox #1.gb, 10, 410,370,25
   open "Galton Machine" for graphics_nf_nsb as #1
   #1 "trapclose [q];down;fill black;flush"
   #1.gb "font courier_new 12"

'Create graphical sprites
   #1 "getbmp bg 1 1 400 600"
   #1 "place 0 0; color white;backcolor white;boxfilled 17 17;place 8 8;color black;backcolor black;circlefilled 8;"
   #1 "place 8 25;color white;backcolor white;circlefilled 8;"
   #1 "getbmp ball 0 0 17 34"
   #1 "place 8 25;color red;backcolor red;circlefilled 8;"
   #1 "getbmp pin 0 0 17 34"
   #1 "background bg"

'add sprites to program
   for pinCount = 1 to 28
       #1 "addsprite pin";pinCount;" pin;spriteround pin";pinCount
   next pinCount

   for ballCount = 1 to 7
       #1 "addsprite ball";ballCount;" ball;spriteround ball";ballCount
   next ballCount

'place pins on page
   for y = 1 to 7
       for x = 1 to y
           pin=pin+1
           xp=200-x*50+y*25
           yp=y*35+100
           #1 "spritexy pin";pin;" ";xp;" ";yp
           #1 "drawsprites"
       next x
   next y

'set balls in motion
   for a = 1 to 7
       #1 "spritexy ball";a;" 174 ";a*60-350
       #1 "spritemovexy ball";a;" 0 5"
   next a


[start] 'update every 50ms - lower number means faster updates
   timer speed, [move]
   wait

[move] 'cycle through the sprites to check for contact with pins or dropping off board
   #1 "drawsprites"
   for ballNum = 1 to 7
       gosub [checkCollide]
   next ballNum
   timer speed, [move]
   wait


[checkCollide] 'check for contact with pins or dropping off board
   timer 0
   #1 "spritexy? ball";ballNum;" x y" 'get current ball position
   #1 "spritecollides ball";ballNum;" hits$" 'collect any collisions
   if hits$<>"" then 'any collisions? if so...
       direction = rnd(1)
       'randomly bounce either left or right
       if direction >0.4999999 then #1 "spritexy ball";ballNum;" ";x+25;" ";y else #1 "spritexy ball";ballNum;" ";x-25;" ";y
       #1 "spritemovexy ball";ballNum;" 0 5"'set ball in motion again
   end if
   #1 "spritexy? ball";ballNum;" x y" 'get current ball position
   if y > 400 then 'if ball has dropped off board, then...
       select case 'figure out which slot it has landed in and increment the counter for that slot
           case x<49
               slot(1)=slot(1)+1
           case x=49
               slot(2)=slot(2)+1
           case x=99
               slot(3)=slot(3)+1
           case x=149
               slot(4)=slot(4)+1
           case x=199
               slot(5)=slot(5)+1
           case x=249
               slot(6)=slot(6)+1
           case x=299
               slot(7)=slot(7)+1
           case x>299
               slot(8)=slot(8)+1
       end select
       for a = 1 to 8 'write the slot counts in the small graphic box
           update$="place "+str$((a-1)*48+1)+" 20;\"+str$(slot(a))
           #1.gb, update$
       next a
       #1 "spritexy ball";ballNum;" 174 ";0-10 'reposition the sprite just off the top of the screen
       #1 "spritemovexy ball";ballNum;" 0 5" 'set the ball in motion again
       cycles = cycles + 1 'increment the fallen ball count
       if cycles >= cycleMax then
           timer 0 'stop animation
           'make the visible balls go away
           for a = 1 to 7
               #1 "spritexy ball";a;" 174 700"
               #1 "spritemovexy ball";a;" 0 0"
           next a
           #1 "drawsprites"
           notice "Complete"
           wait
       end if
   end if
return

[q]
   close #1
   'It is IMPORTANT to unload the bitmaps and clear memory
   unloadbmp "pin"
   unloadbmp "ball"
   unloadbmp "bg"
   end


[Rod]

Not had time to compare but your last graphics looked really cool almost as if the balls bounced on the way down, now its a little left right but I may have had my other glasses on when I last looked. Now the scores line up so job well done as far as I am concerned.

[David Drake]

Feb 24, 2020 14:46:42 GMT -5 Rod said:

Not had time to compare but your last graphics looked really cool almost as if the balls bounced on the way down, now its a little left right but I may have had my other glasses on when I last looked. Now the scores line up so job well done as far as I am concerned.

Yeah, in order to do the multiple balls I did away with the smooth side animation.  I felt that, for purposes of the demonstration, multiple balls were more important (other implementations had multiple balls falling).

[David Drake]

This one has gone quiet. If no one has suggestions, I plan to post to Rosetta Code later today.