Mouse school of critters
#1
Practice for Boid Watching

Code:
_TITLE "Mouse school of critters - Click to toggle Mouse as Predator or Prey    by bplus 2018-04-27"
'QB64 version 2017 1106/82 (the day before they switched to version 1.2)
'from: Mouse school critters separated.txt for JB 2.0 B+ 2018-04-24
'2018-04-27 update for Predator / Prey Toggle with Click

CONST xmax = 1200
CONST ymax = 700
SCREEN _NEWIMAGE(xmax, ymax, 32)
_SCREENMOVE 100, 40
RANDOMIZE TIMER
DIM SHARED qb(15)
qb(0) = &HFF000000
qb(1) = &HFF000088
qb(2) = &HFF008800
qb(3) = &HFF008888
qb(4) = &HFF880000
qb(5) = &HFF880088
qb(6) = &HFF888800
qb(7) = &HFFCCCCCC
qb(8) = &HFF888888
qb(9) = &HFF0000FF
qb(10) = &HFF00FF00
qb(11) = &HFF00FFFF
qb(12) = &HFFFF0000
qb(13) = &HFFFF00FF
qb(14) = &HFFFFFF00
qb(15) = &HFFFFFFFF

na = 50
DIM SHARED x(na), y(na), v(na), r(na), c(na), predator
FOR i = 1 TO na
    x(i) = rand(0, xmax)
    y(i) = rand(0, ymax)
    rr = INT(RND * 15)
    v(i) = rr * 1
    r(i) = rand(10, 30)
    c(i) = qb(rr)
NEXT

WHILE 1
    CLS
    IF INKEY$ = "q" THEN END
    FOR i = 1 TO na
        m = _MOUSEINPUT: mb = _MOUSEBUTTON(1): mx = _MOUSEX: my = _MOUSEY
        IF mb THEN
            WHILE mb
                m = _MOUSEINPUT: mb = _MOUSEBUTTON(1): mx = _MOUSEX: my = _MOUSEY
                _LIMIT 200
            WEND
            IF predator THEN predator = 0 ELSE predator = 1
        END IF

        'radian angle to mouse
        ra = _ATAN2(my - y(i), mx - x(i)) '  + pi kind of interesting too
        'draw it
        critter i, ra

        'separate critters for next frame and further down i line
        FOR j = i + 1 TO na

            ' The following is STATIC's adjustment of ball positions if overlapping
            ' before calcultion of new positions from collision
            ' Displacement vector and its magnitude.  Thanks STxAxTIC !
            nx = x(j) - x(i)
            ny = y(j) - y(i)
            nm = SQR(nx ^ 2 + ny ^ 2)
            IF nm < 10 + r(i) + r(j) THEN
                nx = nx / nm
                ny = ny / nm

                ' Regardless of momentum exchange, separate the balls along the lone connecting them.
                WHILE nm < 10 + r(i) + r(j)

                    flub = 10 '  massively increased for JB to speed up code

                    x(j) = x(j) + flub * nx
                    y(j) = y(j) + flub * ny

                    x(i) = x(i) - flub * nx
                    y(i) = y(i) - flub * ny

                    nx = x(j) - x(i)
                    ny = y(j) - y(i)
                    nm = SQR(nx ^ 2 + ny ^ 2)
                    nx = nx / nm
                    ny = ny / nm
                WEND
            END IF
        NEXT
        IF predator THEN
            x(i) = x(i) + v(i) * COS(ra + _PI)
            y(i) = y(i) + v(i) * SIN(ra + _PI)
        ELSE
            x(i) = x(i) + v(i) * COS(ra)
            y(i) = y(i) + v(i) * SIN(ra)
        END IF
    NEXT
    _DISPLAY
    _LIMIT 20
WEND

SUB critter (i, ra)
    COLOR c(i)
    fcirc x(i), y(i), r(i)
    IF predator THEN
        x1 = x(i) + .75 * r(i) * COS(ra - _PI(1 / 9) + _PI)
        y1 = y(i) + .75 * r(i) * SIN(ra - _PI(1 / 9) + _PI)
        x2 = x(i) + .75 * r(i) * COS(ra + _PI(1 / 9) + _PI)
        y2 = y(i) + .75 * r(i) * SIN(ra + _PI(1 / 9) + _PI)
    ELSE
        x1 = x(i) + .75 * r(i) * COS(ra - _PI(1 / 9))
        y1 = y(i) + .75 * r(i) * SIN(ra - _PI(1 / 9))
        x2 = x(i) + .75 * r(i) * COS(ra + _PI(1 / 9))
        y2 = y(i) + .75 * r(i) * SIN(ra + _PI(1 / 9))
    END IF
    COLOR qb(15)
    fcirc x1, y1, .25 * r(i)
    fcirc x2, y2, .25 * r(i)
    IF predator THEN
        x3 = x1 + .125 * r(i) * COS(ra + _PI)
        y3 = y1 + .125 * r(i) * SIN(ra + _PI)
        x4 = x2 + .125 * r(i) * COS(ra + _PI)
        y4 = y2 + .125 * r(i) * SIN(ra + _PI)
    ELSE
        x3 = x1 + .125 * r(i) * COS(ra)
        y3 = y1 + .125 * r(i) * SIN(ra)
        x4 = x2 + .125 * r(i) * COS(ra)
        y4 = y2 + .125 * r(i) * SIN(ra)
    END IF
    COLOR qb(0)
    fcirc x3, y3, .125 * r(i)
    fcirc x4, y4, .125 * r(i)
END SUB

'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

FUNCTION rand% (lo%, hi%)
    rand% = INT(RND * (hi% - lo% + 1)) + lo%
END FUNCTION
B += x
Reply