You are not logged in or registered. Please login or register to use the full functionality of this board...
SIGN IN Join Our Community For FREE


Ball and line collisions
09-13-2017, 04:53 PM
Post: #1
 (Print Post)
Ball and line collisions
Code Snippet: [Select]
'Rain Drain.bas started 2017-09-13
'translated from
'Rain Drain.bas  SmallBASIC 0.12.9 [B+=MGA] 2017-04-26

_DEFINE A-Z AS SINGLE
RANDOMIZE TIMER
CONST xmax = 1100
CONST ymax = 700

SCREEN _NEWIMAGE(xmax, ymax, 32)
_TITLE "Rain Drain by bplus,    spacebar for new arrangement,    esc to quit"

TYPE ball
   x AS INTEGER
   y AS INTEGER
   speed AS INTEGER
   r AS INTEGER
   c AS LONG
END TYPE

TYPE bLine
   x1 AS INTEGER
   y1 AS INTEGER
   x2 AS INTEGER
   y2 AS INTEGER
   a AS DOUBLE
END TYPE

WHILE 1
   balls = 150
   REDIM b(balls) AS ball
   FOR i = 1 TO balls
       b(i).x = rand%(0, xmax)
       b(i).y = rand%(0, ymax)
       b(i).speed = 1
       b(i).r = rand%(1, 6)
       b(i).c = _RGB(0, rand%(200, 255), rand%(200, 255))
   NEXT

   m = 10
   nbl = 25
   REDIM bl(nbl) AS bLine
   FOR i = 1 TO nbl
       d = rand%(50, 200)
       bl(i).x1 = rand%(m, xmax - d - m)
       bl(i).y1 = i * ymax / nbl - 10
       bl(i).a = RND * _PI(1 / 32) - _PI(1 / 64)
       bl(i).x2 = bl(i).x1 + d * COS(bl(i).a)
       bl(i).y2 = bl(i).y1 + d * SIN(bl(i).a)
   NEXT

   WHILE 1
       CLS
       IF 32 = _KEYHIT THEN
           EXIT WHILE
       ELSEIF 27 = _KEYHIT THEN
           END
       END IF
       FOR j = 1 TO balls
           IF b(j).y - b(j).r > ymax OR b(j).x + b(j).r < 0 OR b(j).x - b(j).r > xmax THEN
               b(j).x = rand%(0, xmax): b(j).y = 0
           END IF
           COLOR b(j).c
           fcirc b(j).x, b(j).y, b(j).r
           testx = b(j).x + b(j).speed * COS(_PI(.5))
           testy = b(j).y + b(j).speed * SIN(_PI(.5))
           cFlag = 0
           FOR i = 1 TO nbl
               COLOR _RGB(255, 0, 0)
               lien bl(i).x1, bl(i).y1, bl(i).x2, bl(i).y2
               IF cFlag = 0 THEN
                   IF hitLine(testx, testy, b(j).r, bl(i).x1, bl(i).y1, bl(i).x2, bl(i).y2) THEN
                       bx1 = b(j).x + b(j).speed * COS(bl(i).a)
                       bx2 = b(j).x + b(j).speed * COS(_PI(1) - bl(i).a)
                       by1 = yy(bx1, bl(i).x1, bl(i).y1, bl(i).x2, bl(i).y2) - b(j).r - 1
                       by2 = yy(bx2, bl(i).x1, bl(i).y1, bl(i).x2, bl(i).y2) - b(j).r - 1
                       IF by1 = (-9999 - b(j).r - 1) OR by2 = (-9999 - b(j).r - 1) THEN
                           cFlag = 0: EXIT FOR
                       END IF
                       IF by1 >= by2 THEN b(j).y = by1: b(j).x = bx1 ELSE b(j).y = by2: b(j).x = bx2
                       cFlag = 1
                   END IF
               END IF
           NEXT
           IF cFlag = 0 THEN b(j).x = testx: b(j).y = testy
       NEXT
       _DISPLAY
   WEND
WEND

SUB lien (x1, y1, x2, y2)
   LINE (x1, y1)-(x2, y2)
END SUB

FUNCTION hitLine (x, y, r, xx1, yy1, xx2, yy2)
   x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2
   IF x1 > x2 THEN SWAP x1, x2: SWAP y1, y2
   IF x < x1 OR x > x2 THEN hitLine = 0: EXIT SUB
   IF ((y2 - y1) / (x2 - x1)) * (x - x1) + y1 - r < y AND y < ((y2 - y1) / (x2 - x1)) * (x - x1) + y1 + r THEN
       hitLine = 1
   ELSE
       hitLine = 0
   END IF
END FUNCTION

FUNCTION yy (x, xx1, yy1, xx2, yy2)
   'copy parameters that are changed
   x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2
   IF x1 > x2 THEN SWAP x1, x2: SWAP y1, y2
   IF x1 <= x AND x <= x2 THEN
       yy = ((y2 - y1) / (x2 - x1)) * (x - x1) + y1
   ELSE
       yy = -9999
   END IF
END FUNCTION

FUNCTION rand% (lo%, hi%)
   rand% = (RND * (hi% - lo% + 1)) \ 1 + lo%
END FUNCTION

FUNCTION rdir% ()
   IF RND < .5 THEN rdir% = -1 ELSE rdir% = 1
END FUNCTION

'Steve McNeil's  copied from his forum   note: Radius is too common a name
SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG)
   DIM subRadius AS LONG, RadiusError AS LONG
   DIM X AS LONG, Y AS LONG

   subRadius = ABS(R)
   RadiusError = -subRadius
   X = subRadius
   Y = 0

   IF subRadius = 0 THEN PSET (CX, CY): EXIT SUB

   ' Draw the middle span here so we don't draw it twice in the main loop,
   ' which would be a problem with blending turned on.
   LINE (CX - X, CY)-(CX + X, CY), , BF

   WHILE X > Y
       RadiusError = RadiusError + Y * 2 + 1
       IF RadiusError >= 0 THEN
           IF X <> Y + 1 THEN
               LINE (CX - Y, CY - X)-(CX + Y, CY - X), , BF
               LINE (CX - Y, CY + X)-(CX + Y, CY + X), , BF
           END IF
           X = X - 1
           RadiusError = RadiusError - X * 2
       END IF
       Y = Y + 1
       LINE (CX - X, CY - Y)-(CX + X, CY - Y), , BF
       LINE (CX - X, CY + Y)-(CX + X, CY + Y), , BF
   WEND
END SUB


Attached File(s) Image(s)
   

B += _
Find all posts by this user
Like Post
The following 1 user Likes bplus's post:
KingAshish



Forum Jump:


User(s) browsing this thread: 1 Guest(s)




QB64 Member Project - Domain
QB64 Member Project - Rotating Background
QB64 Member Project - STxAxTIC 3D World
QB64 Member Project - Pivet version one
QB64 Member Project - Basic Dithering
QB64 Member Project - 9 Board
QB64 Member Project - Spiro Roses
QB64 Member Project - Sabotage
QB64 Member Project - ARB Checkers
QB64 Member Project - Algeria Weather
QB64 Member Project - Overboard
QB64 Member Project - OpenGL Triangles
QB64 Member Project - Dakapo
QB64 Member Project - Dreamy Clock
QB64 Member Project - Kings Valley verion one
QB64 Member Project - Touche
QB64 Member Project - Amazon
QB64 Member Project - Bowditch curve
QB64 Member Project - Kings Court
QB64 Member Project - Color Triangles
QB64 Member Project - Martin Fractals version one
QB64 Member Project - Qubic
QB64 Member Project - Rubix's Magic
QB64 Member Project - Swirl
QB64 Member Project - Splatter
QB64 Member Project - Isolation
QB64 Member Project - Foursight
QB64 Member Project - Quarto
QB64 Member Project - Color Rotating Text
QB64 Member Project - Blokus
QB64 Member Project - Exit
QB64 Member Project - Martin Fractals version three
QB64 Member Project - MAPTRIANGLE
QB64 Member Project - Othello
QB64 Member Project - Inside Moves
QB64 Member Project - Kings Vallery version two
QB64 Member Project - Martin Fractals version two
QB64 Member Project - Martin Fractals version four
QB64 Member Project - Kobolts Monopoly
QB64 Member Project - Spinning Color Wheel
QB64 Member Project - Full Color LED Sign
QB64 Member Project - RGB Color Wheel
QB64 Member Project - Red Scrolling LED Sign
QB64 Member Project - Score 4
QB64 Member Project - Point Blank
QB64 Member Project - Connect Four
QB64 Member Project - Input
QB64 Member Project - Pivot version two
QB64 Member Project - Line Thickness