Particles - now with reverse gravity

Introducing an update to the particles program that now features a reverse gravity feature.  Have fun repelling particles from your mouse as well as attracting them.

Follow this link to download the Windows executable and source code.  Source code copied below...

Here particles are repelled from your mouse.  The closer they are, the stronger the repulsion.


BB4Win Source code:

     _VERSION$ = "1.0.0.5"
     REM T Street
     REM 2015-11-08
     REM Particles acting under gravity
     REM 2015-11-24
     REM repulsion mode added
     
INSTALL @lib$+"XMLLIB"
     INSTALL @lib$ +"datelib"

     ON ERROR ERROR 0, "Oh dear! A fatal error has occured."
     OSCLI "float 64"
     OSCLI "escape off"
     MODE 12 : OFF : PROC_preventResize
     PROC_setWindowTitle("Particles version "+_VERSION$)
     COLOUR 4, 100,100,100 :REM grey
     
COLOUR 3, 230,230,230 :REM white
     
COLOUR 2, 0, 230, 0   :REM green
     
X_POS% = 14 : REM used by input routine

     
BYDEFAULT_PARTICLES% = 100
     BYDEFAULT_GRAVITY% = 50
     BYDEFAULT_SIZE% = 8
     BYDEFAULT_WALLSON$ = "Y"
     BYDEFAULT_ELASTICITY% = 30
     BYDEFAULT_UNIVERSE = 2
     BYDEFAULT_TRAILS$ = "N"

     REM slo mo
     
NUMBER_OF_STEPS% = 20
     DELAY% = 50
     StepMode% = 0

     REM repulsion mode
     
Repulse% = 1

     REM colours
     
GREEN$ = CHR$(17)+CHR$(2)
     WHITE$ = CHR$(17)+CHR$(3)
     GREY$  = CHR$(17)+CHR$(4)

     REM check for updates
     
Message$ = FN_getUpdateMessage
     PROC_showTitleScreen
     OSCLI "font Courier New, 20"
     PRINTTAB(17,10)WHITE$"Press "GREEN$"<ANY KEY>"WHITE$" to start."
     PRINTTAB(17,11)WHITE$"Press "GREEN$"<ENTER>"WHITE$" for set up."
     PRINTTAB(17,12)"Other controls:"
     PRINTTAB(17,13)GREEN$"<ESC>"WHITE$" start again"
     PRINTTAB(17,14)GREEN$"<P>"WHITE$" pause"
     PRINTTAB(17,15)GREEN$"<S>"WHITE$" slow motion"
     PRINTTAB(17,16)GREEN$"<F>"WHITE$" cancel slow motion"
     PRINTTAB(17,17)GREEN$"<R>"WHITE$" toggle repulsion"
     PRINTTAB(17,21)"www.superdecadegames.com"
     PRINTTAB(1,22)GREY$Message$
     g% = GET
     IF
g% = 13 THEN
       CLS
       PROC
_showTitleScreen
       OSCLI "font Courier New, 20"
       REM get the initial conditions
       
NumParticles% = INT(FN_getNum( "Number of particles (1-999): ", 1, 999, BYDEFAULT_PARTICLES%, 8) )-1
       GravityConstant% = INT(FN_getNum( "Gravity strength (1-100): ", 1, 100, BYDEFAULT_GRAVITY%, 9) ) *10
       ParticleSize% = INT(FN_getNum("Particle size (1-30): ", 1, 30, BYDEFAULT_SIZE%, 10) )*2 +2
       wallsOn% = FN_yesNo( "Walls? (Y/N): " , BYDEFAULT_WALLSON$, 11)
       IF wallsOn% THEN
         
BounceFactor = FN_getNum("Wall elasticity (1-100): ", 1, 100, BYDEFAULT_ELASTICITY%, 12 ) / 100
       ENDIF
       
Universe = FN_getNum("Which universe? (1.0-3.0): ", 1, 3,  BYDEFAULT_UNIVERSE , 13 )
       showTrails% = FN_yesNo("Show trails (Y/N): ", BYDEFAULT_TRAILS$, 14)
       IF FN_yesNo("Repulsion on? (Y/N): ", "N", 15) THEN
         
Repulse% = -1
       ENDIF


     ELSE
       
REM default global constants
       
NumParticles% = BYDEFAULT_PARTICLES% : REM increase if you have a fast machine
       
GravityConstant% = BYDEFAULT_GRAVITY% * 10 : REM increase for stronger gravity
       
ParticleSize% = BYDEFAULT_SIZE% * 2 + 2 : REM size of each particle
       
BounceFactor = BYDEFAULT_ELASTICITY% / 100
       Universe = BYDEFAULT_UNIVERSE
       showTrails% = FALSE
       
wallsOn% = TRUE
     ENDIF

     
REM set up the initial positions of particles
     
DIM part{(NumParticles%) x, y, dx, dy, red%, green%, blue% }
     PROC_randomPositions( part{()}, NumParticles%)
     PROC_randomColours( part{()}, NumParticles%)
     CLS
     MOUSE ON
3
     REM main loop
     
REPEAT
       OSCLI
"refresh off"
       IF NOTshowTrails% CLS
       PROC
_showParticles( part{()}, NumParticles%)
       MOUSE x, y, click : REM get current position of the mouse
       
PROC_moveParticles( part{()}, NumParticles%, x, y )
       OSCLI "refresh on"
       OSCLI "refresh"
       REM wait one centisecond for user input
       
g = INKEY(1)
       REM escape
       
IF g = 27 RUN
       
REM pause  <p>
       
IF g = 112 OR g = 80 THEN
         REPEAT
           WAIT
50
           g = GET
         UNTIL
g = 112 OR g = 80
       ENDIF
       
REM slow motion  <s>
       
IF g = 115 OR g=83 THEN
         
StepMode% = NUMBER_OF_STEPS%
       ENDIF
       
REM cancel slow motion <f>
       
IF g = 102 OR g=70 THEN
         
StepMode% = 0
       ENDIF
       
REM repulse mode
       
IF g = 114 OR g=82 THEN
         
Repulse% *= -1
       ENDIF

       
REM if in slow motion, this lasts for
       REM a short predetermined time
       
IF StepMode%>0 THEN
         
StepMode% -=1
         WAIT DELAY%
       ENDIF
     UNTIL FALSE




     
DEFFN_getNum( prompt$, min, max, bydefault, ypos%)
     REM gets a number from the user
     REM must be between the min and max inclusive
     REM if enter pressed, return the default
     REM ypos is the line position to display
     
LOCAL in
     REPEAT
       OSCLI
"refresh off"
       COLOUR 3
       PRINTTAB(0,ypos%)STRING$(60," ") : REM clear line
       
PRINTTAB(X_POS%,ypos%)prompt$
       COLOUR 2
       OSCLI "refresh on"
       OSCLI "refresh"
       INPUT TAB(X_POS%+LEN(prompt$)+1,ypos%) "" in
       IF in = 0 THEN
         OSCLI
"refresh off"
         in = bydefault
         COLOUR 3
         PRINTTAB(0, ypos%)STRING$(60," ") : REM clear line
         
PRINTTAB(X_POS%,ypos%)prompt$
         COLOUR 2
         PRINTTAB(X_POS%+LEN(prompt$)+1,ypos%)STR$in
         OSCLI "refresh on"
         OSCLI "refresh"
       ENDIF
     UNTIL
in >= min AND in<=max
     = in



     DEFFN_yesNo( prompt$, bydefault$, ypos%)
     REM asks a yes no question
     REM returns true for yes and false for no
     
LOCAL in$, answer%
     COLOUR 3
     REPEAT
       OSCLI
"refresh off"
       PRINTTAB(0, ypos%)STRING$(60," ") : REM clear line
       
PRINTTAB(X_POS%,ypos%)prompt$
       OSCLI "refresh on"
       OSCLI "refresh"
       in$ = GET$
     UNTIL INSTR(
"YyNn"+CHR$(13), in$)<>0
     IF in$=CHR$(13) in$ = bydefault$
     IF in$ = "y" in$ = "Y"
     IF in$ = "n" in$ = "N"
     answer% = SGN(INSTR("Yy", in$))*-1
     COLOUR 2
     PRINTTAB(X_POS%+LEN(prompt$)+1,ypos%)in$
     = answer%


     DEFPROC_showTitleScreen
     OSCLI "font Courier New, 50b"
     COLOUR 3
     PRINTTAB(7,1)"Particles"
     OSCLI "font Courier New, 20"
     COLOUR 4
     PRINTTAB(21,5)"version "_VERSION$
     ENDPROC

     
DEFPROC_moveParticles( particle{()}, n%, x, y )
     REM find the current distance from the mouse
     REM and apply effect on motion of particle
     
LOCAL i%
     LOCAL d : REM distance
     
FOR i% = 0 TO n%
       REM find distance from mouse
       
d = SQR( ((particle{(i%)}.x - x )^2) +  ((particle{(i%)}.y - y )^2) )
       IF d<>0 THEN
         
REM add new velocity
         
particle{(i%)}.dx += (GravityConstant%  * Repulse%* ((x - particle{(i%)}.x) / d^Universe) )
         particle{(i%)}.dy += (GravityConstant%  * Repulse%* ((y - particle{(i%)}.y) / d^Universe) )
       ENDIF
       
REM change particle's position by speed factor

       
particle{(i%)}.x += (particle{(i%)}.dx )
       particle{(i%)}.y += (particle{(i%)}.dy )
       REM bounce off walls
       
IF wallsOn% THEN
         IF
particle{(i%)}.x <= 0 OR particle{(i%)}.x >= 1920 THEN
           
particle{(i%)}.x -= (particle{(i%)}.dx )
           particle{(i%)}.dx = particle{(i%)}.dx *-BounceFactor
         ENDIF

         IF
particle{(i%)}.y <= 0 OR particle{(i%)}.y >= 1536 THEN
           
particle{(i%)}.y -= (particle{(i%)}.dy )
           particle{(i%)}.dy = particle{(i%)}.dy *-BounceFactor
         ENDIF
       ENDIF

     NEXT
     ENDPROC


     
DEFPROC_showParticles( particle{()}, n% )
     REM show particles on screen
     
LOCAL i%
     FOR i% = 0 TO n%
       COLOUR 1, particle{(i%)}.red%, particle{(i%)}.green%, particle{(i%)}.blue%
       GCOL 0,1
       CIRCLE FILL particle{(i%)}.x, particle{(i%)}.y, ParticleSize%
     NEXT
     ENDPROC



     
DEFPROC_randomPositions( particle{()}, n% )
     REM assign a new position to the particles at random
     
LOCAL i%
     FOR i% = 0 TO n%
       particle{(i%)}.x  = RND(1920)
       particle{(i%)}.y  = RND(1536)
     NEXT
     ENDPROC


     
DEFPROC_randomColours( particle{()}, n% )
     REM assign a new position to the particles at random
     REM (blue not used)
     
LOCAL i%
     FOR i% = 0 TO n%
       particle{(i%)}.red% = RND(255)
       particle{(i%)}.green% = RND(255)
       particle{(i%)}.blue% = RND(255)
     NEXT
     ENDPROC


     
DEF PROC_preventResize
     REM prevent user resizing window
     
PRIVATE ws%
     SYS "GetWindowLong", @hwnd%, -16 TO ws%
     REM prevent user maximising window
     
SYS "SetWindowLong", @hwnd%, -16, ws% AND NOT &50000
     ENDPROC


     
DEF PROC_setWindowTitle(title$)
     REM sets the Window Title (normally the program filename) to the value of title$
     
SYS "SetWindowText", @hwnd%, title$
     ENDPROC


     
DEF FN_getUpdateMessage
     ON ERROR LOCAL =" Could not find updates. Check your internet connection."
     LOCAL url$, XMLfile$, a$, parts%, version$, year$, month$, day$, daysAgo%, arr$()
     LOCAL message$
     url$ = "http://www.superdecadegames.com/particles/update.dat"
     XMLfile$ = @tmp$+"update.dat"
     PROCurldownload(url$, XMLfile$)

     REMprint XMLfile$

     
DIM arr$(1)

     a$ = ""

     file% = OPENIN(XMLfile$)
     WHILE NOT(EOF#file%)
       a$ = a$ + CHR$BGET#file%
     ENDWHILE
     CLOSE
#file%
     OSCLI "DEL "+XMLfile$

     a$ = FN_removeCRLF(a$)

     parts% = FN_split(a$, "/", arr$())
     version$ = arr$(0)
     year$ = arr$(1)
     month$ = arr$(2)
     day$ = arr$(3)

     daysAgo% = FN_today - FN_mjd(VAL(day$),VAL(month$),VAL(year$))

     IF _VERSION$ = version$ THEN
       
message$ = " Congratulations, you are using the most recent version,"+CHR$(13)+CHR$(10)+STRING$(14," ")+"which was released "+STR$(daysAgo%)+" days ago."
     ELSE
       
message$ ="      A new version is available: version "+version$+CHR$(13)+CHR$(10)+STRING$(14," ")+"which was released "+STR$(daysAgo%)+" days ago."+CHR$(13)+CHR$(10)+"      See "+GREEN$+"www.superdecade.blogspot.co.uk"+GREY$+" for details."
     ENDIF

     
= message$





     DEF PROCurldownload(url$, file$)
     ON ERROR LOCAL ENDPROC
     LOCAL
wininet%, buffer%, hinet%, hreq%, file%, nbr%, nbw%, ok%
     DIM buffer% LOCAL 511

     _INTERNET_OPEN_TYPE_PRECONFIG = 0
     _INTERNET_FLAG_RELOAD = &80000000

     SYS "LoadLibrary", "WININET.DLL" TO wininet%
     SYS "GetProcAddress", wininet%, "InternetOpenA"       TO `InternetOpen`
     SYS "GetProcAddress", wininet%, "InternetOpenUrlA"    TO `InternetOpenUrl`
     SYS "GetProcAddress", wininet%, "InternetReadFile"    TO `InternetReadFile`
     SYS "GetProcAddress", wininet%, "InternetCloseHandle" TO `InternetCloseHandle`

     SYS `InternetOpen`, "BB4W", _INTERNET_OPEN_TYPE_PRECONFIG, 0, 0, 0 TO hinet%
     IF hinet% = 0 ERROR 100, "Couldn't open internet services"

     SYS `InternetOpenUrl`, hinet%, url$, "", 0, _INTERNET_FLAG_RELOAD, 0 TO hreq%
     IF hreq% = 0 THEN
       PROC
inetcleanup
       ERROR 100, "Couldn't open "+url$
     ENDIF

     
file% = OPENOUT(file$)
     IF file% = 0 THEN
       PROC
inetcleanup
       ERROR 100, "Couldn't create "+file$
     ENDIF

     REPEAT
       SYS
`InternetReadFile`, hreq%, buffer%, 512, ^nbr% TO ok%
       IF ok% = 0 THEN
         PROC
inetcleanup
         ERROR 100, "Couldn't read from "+url$
       ENDIF
       SYS
"WriteFile", @hfile%(file%), buffer%, nbr%, ^nbw%, 0 TO ok%
       IF ok% = 0 THEN
         PROC
inetcleanup
         ERROR 100, "Couldn't write "+file$
       ENDIF
     UNTIL
nbr% = 0

     CLOSE #file%

     PROCinetcleanup
     ENDPROC

     
DEF PROCinetcleanup
     ON ERROR LOCAL ENDPROC
     
hreq% += 0  : IF hreq%  SYS `InternetCloseHandle`, hreq%  : hreq% = 0
     hinet% += 0 : IF hinet% SYS `InternetCloseHandle`, hinet% : hinet% = 0
     wininet% += 0 : IF wininet% SYS "FreeLibrary", wininet% : wininet% = 0
     ENDPROC

     
DEFFN_removeCRLF(t$)
     REM returns the text passed with carriage returns and line feeds removed
     
LOCAL dummy%
     dummy% = FN_findreplace(t$,CHR$(13),"",0)
     dummy% = FN_findreplace(t$,CHR$(10),"",0)
     = t$


     REM Replace all occurrences of O$ with N$ starting at I%:
     REM The returned value is the number of replacements made
     
DEF FN_findreplace(RETURN A$,O$,N$,I%)
     LOCAL C%
     REPEAT
       
I% = INSTR(A$,O$,I%)
       IF I% THEN
         
A$ = LEFT$(A$,I%-1)+N$+MID$(A$,I%+LEN(O$))
         I% += LEN(N$)
         C% += 1
       ENDIF
     UNTIL
I% = 0
     = C%


     REM Split a string at specified delimiter:
     REM A$ is the string to be split
     REM d$ is the delimiter at which to split
     REM a$() is an array to receive the parts (created if necessary)
     REM The returned value is the number of array elements written
     
DEF FN_split(A$, d$, RETURN a$())
     LOCAL C%, I%, N%, P%, Q%, R%
     IF !^a$() N% = DIM(a$(),1)+1
     FOR P% = 0 TO 1
       I% = 0
       R% = 0
       REPEAT
         
Q% = R%
         REPEAT
           
C% = INSTR(A$, d$, Q%+1)
           Q% = INSTR(A$, """", Q%+1)
           IF Q% IF C% > Q% THEN
             
Q% = INSTR(A$, """", Q%+1)
             IF Q%=0 ERROR 100, "Mismatched quotes"
           ELSE
             
Q% = 0
           ENDIF
         UNTIL
Q% = 0
         IF C% = 0 THEN C% = LEN(A$)+1
         IF P% a$(I%) = MID$(A$, R%+1, C%-R%-1)
         R% = C%+LEN(d$)-1
         I% += 1
       UNTIL R% >= LEN(A$)
       IF P% = 0 IF N% < I% THEN
         IF
N% a$() = ""
         !^a$() = 0
         DIM a$(I%-1)
       ENDIF
     NEXT
P%
     = I%
     ;
     REM Join array elements using specified delimiter:
     
DEF FN_join(a$(), d$, N%)
     LOCAL I%,A$
     FOR I% = 0 TO N%-1
       IF I%=N%-1 d$=""
       A$ += a$(I%) + d$
     NEXT
     
= A$

Related Posts