« previous next »
Pages: [1]   Go Down

Author Topic: I love basket...  (Read 3164 times)

0 Members and 1 Guest are viewing this topic.

Offline TempodiBasic

  • Forum Resident
  • Posts: 1792
    • View Profile
I love basket...
« on: January 07, 2020, 09:37:27 am »
Hi Guys
I love basket and I found in an old my notebook this one example program that uses smart colors

Code: QB64: [Select]
  1. ' Terry's Ball Jump With "Rotating" Ball   13-05-16
  2. SCREEN _NEWIMAGE(640, 480, 32) '                                               640x480 32bit screen
  3. _SCREENMOVE _MIDDLE '                                                          center on desktop
  4.  
  5. ' declaration  area ***************************************
  6. CONST pi = 3.14
  7. ' colors constant values
  8. CONST rosso~& = _RGB32(255, 0, 0)
  9. CONST rossoc~& = _RGB32(150, 0, 0)
  10. CONST verde~& = _RGB32(0, 255, 0)
  11. CONST bianco~& = _RGB32(255, 255, 255)
  12. CONST nero~& = _RGB32(0, 0, 0)
  13. CONST arancio~& = _RGB32(255, 150, 0)
  14.  
  15. DIM SHARED b&, bp&, cs& '            sound variables
  16. DIM SHARED suono%, suonoamb%
  17. DIM SHARED inlancio% '
  18. DIM SHARED vel_vel% '
  19. DIM Yvel! '                                                                    vertical velocity
  20. DIM Xvel! '                                                                    horizontal velocity
  21. DIM Yacc! '                                                                    vertical acceleration
  22. DIM x! '                                                                       circle horizontal center point
  23. DIM y! '                                                                       circle vertical center point
  24. DIM TimeElapsed# '                                                             elapsed time between frames
  25. DIM Bounciness! '                                                              amount of bounce in object
  26. DIM LineCount% '                                                               generic counter
  27. DIM sngPentagon!(4), sngPent!(4, 1, 1) '                                       Arrays to define corners of pentagon
  28. REDIM image(GETarraysize&(32, 50, 50, 150, 150)) AS _BYTE
  29. ' inizialization  area  ******************************
  30.  
  31. _TITLE "Basket"
  32. FOR bytN%% = 0 TO 4
  33.     sngPentagon!(bytN%%) = bytN%% * 2 * _PI / 5
  34. NEXT bytN%%
  35. sngTheta! = 0 '                                                                Angle of rotation
  36. x! = 20 '                                                                      x location of object
  37. y! = 459 '                                                                     y location of object
  38.  
  39. prova_test_SND ' file sound are here
  40.  
  41.  
  42. inlancio% = 0
  43. a$ = " "
  44. Yvel! = 0 '                                                                    no vertical velocity to start with
  45. Xvel! = 5 '                                                                    horizontal velocity
  46. Yacc! = 30 '                                                                   30 pixels per second acceleration
  47. TimeElapsed# = TIMER(.001) '                                                   get current timer value
  48. Bounciness! = .9 '                                                             0 = no bounce thru 1 = full bounce
  49.  
  50. ' main   ********************************
  51. guida_help
  52. '  cestino  /basket
  53. cesto_basket 50, 100, 100
  54. GET (50, 50)-(150, 150), image()
  55.  
  58.     ' area gestione logica degli oggetti/ area of logic managing of objects
  59.     _LIMIT 60 '                                                                frames per second
  60.     IF suonoamb% = 1 THEN
  61.         IF _SNDPLAYING(b&) = 0 THEN _SNDPLAY b& ELSE PRINT _SNDPLAYING(b&)
  62.     END IF
  63.     IF inlancio% = 2 THEN
  64.         Yvel! = 2.5 * vel_vel%
  65.         inlancio% = 1 ' la palla sta cadendo  ball is bouncing
  66.         vel_vel% = 0
  67.     END IF
  68.  
  69.     TimeElapsed# = TIMER(.001) - TimeElapsed# '                                get elapsed time
  70.     IF ABS(Yvel!) > 0 THEN '                                                   is there vertical velocity?
  71.         Yvel! = Yvel! - Yacc! * TimeElapsed# '                                 yes, compute new vertical velocity based on time
  72.         y! = y! - Yvel! '                                                      subtract velocity from object vertical center point
  73.     END IF
  74.     TimeElapsed# = TIMER(.001) '                                               get current timer value
  75.     IF y! > 459 THEN '                                                         is object still above base line?
  76.         y! = 459 '                                                             no, force object to base line
  77.         Yvel! = ABS(Yvel! * Bounciness!) '                                     set vertical velocity once again to bounce value
  78.         IF Yvel! < .25 THEN
  79.             Yvel! = 0 '                                        bouncing done, stop vertical motion
  80.             inlancio% = 0
  81.         END IF
  82.         IF suono% = 1 THEN _SNDPLAY cs&
  83.     END IF
  84.     x! = x! + Xvel! '                                                          at horizontal velocity
  85.     IF x! > 619 OR x! < 19 THEN
  86.         Xvel! = -Xvel! '                                                       reverse horizontal direction at screen edge
  87.     END IF
  88.  
  89.  
  90.     ' output grafico  / graphic output
  91.     CLS
  92.     PAINT (1, 1), verde~&, rossoc~& 'sfondo /background
  93.     ' barra velocit… /speed bar
  94.     LINE (2, 480 - (10 * vel_vel%))-(12, 480), rossoc~&, BF
  95.     LINE (6, 480 - (10 * vel_vel%))-(8, 480), rosso~&, BF
  96.     PUT (100, 100), image(), PRESET ' basket_cestino
  97.     FOR bytN%% = 0 TO 4 '                                                      extra code to calculate positions of ball seams
  98.         sngPent!(bytN%%, 0, 0) = 10 * COS(sngPentagon!(bytN%%) + sngTheta!) + x!
  99.         sngPent!(bytN%%, 0, 1) = 10 * SIN(sngPentagon!(bytN%%) + sngTheta!) + y!
  100.         sngPent!(bytN%%, 1, 0) = 20 * COS(sngPentagon!(bytN%%) + sngTheta!) + x!
  101.         sngPent!(bytN%%, 1, 1) = 20 * SIN(sngPentagon!(bytN%%) + sngTheta!) + y!
  102.     NEXT bytN%%
  103.  
  104.     intX% = CINT(x!): intY% = CINT(y!)
  105.     CIRCLE (intX%, intY%), 20, _RGB(255, 255, 0) '                             draw the object at current location
  106.     PAINT (intX%, intY% + 19), _RGB32(255, 255, 0), _RGB32(255, 255, 0)
  107.     CIRCLE (intX%, intY%), 20, _RGB(0, 0, 255) '                               extra code for ball seams
  108.     FOR bytN%% = 0 TO 3
  109.         LINE (sngPent!(bytN%%, 0, 0), sngPent!(bytN%%, 0, 1))-(sngPent!(bytN%% + 1, 0, 0), sngPent!(bytN%% + 1, 0, 1)), _RGB(0, 0, 255)
  110.     NEXT bytN%%
  111.     LINE (sngPent!(4, 0, 0), sngPent!(4, 0, 1))-(sngPent!(0, 0, 0), sngPent!(0, 0, 1)), _RGB(0, 0, 255)
  112.     FOR bytN%% = 0 TO 4
  113.         LINE (sngPent!(bytN%%, 0, 0), sngPent!(bytN%%, 0, 1))-(sngPent!(bytN%%, 1, 0), sngPent!(bytN%%, 1, 1)), _RGB(0, 0, 255)
  114.     NEXT bytN%%
  115.     sngTheta! = sngTheta! + Xvel! / (125 - (55 * ATN(458 - intY%))) '          Rotate Ball Seams - dependent upon X speed and Y height
  116.  
  117.     _DISPLAY '     update screen with results
  118.  
  119.     ' area input utente / user's area input
  120.     Utente_user
  121.  
  122.  
  123.  
  125.  
  126. END 'logical end of program
  127.  
  128. '***********************AREA SUB ****************
  129.  
  130.  
  131.  
  132. SUB cesto_basket (radius%, Xc%, Yc%)
  133. a = 0
  134. ' tabellone con rettangolo di tiro  / tablet with square to throw
  135. LINE (Xc% - radius%, Yc% - radius%)-(Xc% + radius%, Yc% + radius%), nero~&, BF
  136. LINE (Xc% - radius% + 2, Yc% - radius% + 2)-(Xc% + radius% - 2, Yc% + radius% - 2), bianco~&, BF
  137. LINE (Xc% - radius% * 2 / 3, Yc% - radius% * 2 / 3)-(Xc% + radius% * 2 / 3, Yc% + radius% * 1 / 4), nero~&, B
  138. ' rete  / web
  139. b = 0
  140. FOR a = (Xc% - radius% * 2 / 3) TO (Xc% + radius% * 2 / 3) STEP (Xc% / 5)
  141.     LINE (a, Yc% + radius% * 1 / 4)-(a + 10, Yc% + (radius% * 1 / 2)), arancio~&
  142.     LINE (a + 10, Yc% + (radius% * 1 / 4))-(a, Yc% + radius% * 1 / 2), arancio~&
  143.     b = b + 1
  144.     IF b < 4 THEN
  145.         LINE (a + 10, Yc% + radius% * 1 / 2)-(a + (Xc% / 5), Yc% + (radius% * 3 / 4)), arancio~&
  146.         LINE (a + (Xc% / 5), Yc% + (radius% * 1 / 2))-(a + 10, Yc% + radius% * 3 / 4), arancio~&
  147.     END IF
  149.  
  150. ' anello di ferro / ring of iron
  151. CIRCLE (Xc%, Yc% - radius% / 8), radius% * 3 / 4, rossoc~&, 1.1 * pi, 1.9 * pi, 1 / 2
  152. CIRCLE (Xc%, Yc% - radius% / 8), radius% * 3 / 4, rossoc~&, 1.1 * pi, 1.9 * pi, 1 / 3
  153. PAINT (Xc%, Yc% - 2 + radius% * 1 / 4), rosso~&, rossoc~&
  155.  
  156. SUB Utente_user
  157. ' ciclo rafforza input utente   / loop focusing on user's input
  158. a$ = " "
  160.     a$ = UCASE$(INKEY$)
  161.     IF a$ = "T" AND vel_vel% < 10 THEN vel_vel% = vel_vel% + 1
  162.     IF a$ = "R" AND vel_vel% > 0 THEN vel_vel% = vel_vel% - 1
  163.     IF a$ = "L" THEN IF inlancio% = 0 THEN inlancio% = 2
  164.     IF a$ = CHR$(27) THEN END
  165.     IF a$ = "S" THEN suono% = suono% * -1
  166.     IF a$ = "M" THEN
  167.         suonoamb% = suonoamb% * -1
  168.         IF _SNDPLAYING(b&) = -1 THEN _SNDSTOP b&
  169.     END IF
  170. LOOP UNTIL a$ = "" ' it waits that user release key_input
  172.  
  173.  
  174. SUB prova_test_SND
  175. ' sub testing files's being and working
  176. COLOR arancio~&, rosso~&
  177. PRINT "verifing sounds..."
  178. b& = _SNDOPEN("basket.mp3", "sync")
  179. bp& = _SNDOPEN("basketpalla.WAV", "sync")
  180. cs& = _SNDOPEN("colposecco.mp3", "sync")
  181.  
  182. IF b& <> 0 THEN _SNDPLAY b& ELSE BEEP
  183. PRINT "Basket.mp3"; b&
  185. IF bp& <> 0 THEN _SNDPLAY bp& ELSE BEEP
  186. PRINT "basketpalla.wav"; bp&
  188. IF cs& <> 0 THEN _SNDPLAY cs& ELSE BEEP
  189. PRINT "colposecco.mp3"; cs&
  192. ' if files's sound are ok then it sets soundflags variables
  193. suono% = 1
  194. suonoamb% = 1
  196.  
  197. SUB guida_help
  198. COLOR rosso~&, verde~&
  199. LOCATE 1, 7: PRINT "Press T/R to up/down velocity of throw and L to launch"
  200. LOCATE 2, 10: PRINT " S toggles sound  and M toggles background sound"
  201. LOCATE 6, 2: PRINT "Premi T/R per aumentare/ridurre la velocit… di lancio e L per lanciare"
  202. LOCATE 7, 10: PRINT " S interruttore suono e M interruttore suono di sfondo"
  203. LOCATE 22, 25: PRINT " Press any key / Premi un tasto "
  205. COLOR , rosso~&
  208.  
  209.  
  210.  
  211.  
  212.  
  213. FUNCTION GETarraysize& (screenmode&, x1&, y1&, x2&, y2&)
  214. bpp = 1: planes = 4
  215. SELECT CASE screenmode&
  216.     CASE 1
  217.         bpp = 2: planes = 1
  218.     CASE 2, 11
  219.         planes = 1
  220.     CASE 7, 8, 9, 12
  221.     CASE 10
  222.         planes = 2
  223.     CASE 13
  224.         bpp = 8: planes = 1
  225.     CASE 256
  226.         GETarraysize& = (x2& - x1& + 1) * (y2& - y1& + 1) + 3
  227.         EXIT FUNCTION
  228.     CASE 32
  229.         GETarraysize& = (x2& - x1& + 1) * (y2& - y1& + 1) * 4 + 3
  230.         EXIT FUNCTION
  231.     CASE ELSE
  232.         ERROR 5
  234. GETarraysize& = 4 + INT(((x2& - x1& + 1) * bpp + 7) / 8) * planes * (y2& - y1& + 1)
  236.  
  237.  
here attached the code plus the files for sound.
The code uses an algorythm posted by Terry Ritchie that liked to the .net forum so other coders made their MOD.
That's mine,  for now uncomplete.
Quote
Instructions:
Press T/R to up/down velocity of throw and L to launch
 S toggles sound  and M toggles background sound

In this program you can find the FUNCTION GETarraysize& (screenmode&, x1&, y1&, x2&, y2&) developed by me and Bert (so my memory says to me) in the sense that I have tossed an empiric formula for calculation for SCREEN 32 bit to use with GET image() and Bert had corrected my empiric formula to a math precision formula.
Code: QB64: [Select]
  1. FUNCTION GETarraysize& (screenmode&, x1&, y1&, x2&, y2&)
  2. bpp = 1: planes = 4
  3. SELECT CASE screenmode&
  4.     CASE 1
  5.         bpp = 2: planes = 1
  6.     CASE 2, 11
  7.         planes = 1
  8.     CASE 7, 8, 9, 12
  9.     CASE 10
  10.         planes = 2
  11.     CASE 13
  12.         bpp = 8: planes = 1
  13.     CASE 256
  14.         GETarraysize& = (x2& - x1& + 1) * (y2& - y1& + 1) + 3
  15.         EXIT FUNCTION
  16.     CASE 32
  17.         GETarraysize& = (x2& - x1& + 1) * (y2& - y1& + 1) * 4 + 3
  18.         EXIT FUNCTION
  19.     CASE ELSE
  20.         ERROR 5
  22. GETarraysize& = 4 + INT(((x2& - x1& + 1) * bpp + 7) / 8) * planes * (y2& - y1& + 1)
  24.  
PS GET image()  the QB45 keyword is deprecated versus the set of keywords of QB64 more flexible and powerful and automated, but if you are porting an old your code into QB64 you can use this function to correct the dimension of the array used for images and not recode whole your program if you turn it in 32bitmode.

Thanks to read
* basket_rimbalzo.rar (Filesize: 292.89 KB, Downloads: 142)
Logged
Programming isn't difficult, only it's  consuming time and coffee

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: I love basket...
« Reply #1 on: January 16, 2020, 04:14:55 pm »
Hi TempodiBasic,

Do you have .zip or .7z (if not too much trouble)?
Logged

Offline TempodiBasic

  • Forum Resident
  • Posts: 1792
    • View Profile
Re: I love basket...
« Reply #2 on: January 16, 2020, 04:28:58 pm »
Sure Sir
in attachment  a .ZIP made by 7.zip

Errata Corrige the formula for managing the size of array in 32bit  screen mode  has been posted in that old thread by JohnB.
Thanks to read

* basket_rimbalzo.zip (Filesize: 354.91 KB, Downloads: 121)
Logged
Programming isn't difficult, only it's  consuming time and coffee

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: I love basket...
« Reply #3 on: January 16, 2020, 04:30:50 pm »
Got it thank you!
Logged
Pages: [1]   Go Up
« previous next »