Mess with #physics... and make pretty patterns

The particles are attracted to your mouse by gravity and make pretty patterns as shown below.

What's new:

• change gravity;
• add walls;
• alter wall elasticity (bounciness);
• see trails for all particles;
• change particle size;
• pause and slow motion mode;
• change the laws of Physics.

BB4W source code and Windows executable available for download (version 1.0.0.4 out now!)  or you will find the source code below.

Source code:

     REM Particles
     REM version 1.0.0.4
     REM!Resource @dir$+"part004.res"
     _VERSION$ = "1.0.0.4"
     REM T Street
     REM 2015-11-08
     REM Particles acting under gravity
     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 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,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)


     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 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%  * ((x - particle{(i%)}.x) / d^Universe) )
         particle{(i%)}.dy += (GravityConstant%  * ((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
       PROCinetcleanup
       ERROR 100, "Couldn't open "+url$
     ENDIF

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

     REPEAT
       SYS `InternetReadFile`, hreq%, buffer%, 512, ^nbr% TO ok%
       IF ok% = 0 THEN
         PROCinetcleanup
         ERROR 100, "Couldn't read from "+url$
       ENDIF
       SYS "WriteFile", @hfile%(file%), buffer%, nbr%, ^nbw%, 0 TO ok%
       IF ok% = 0 THEN
         PROCinetcleanup
         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$

BB4W source code and Windows executable available for download

Share this

Share on FacebookPlus on Google+