Ball and line collisions
#1
Code:
'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 Files Thumbnail(s)

B += x
Reply