| Welcome, Guest |
You have to register before you can post on our site.
|
| Latest Threads |
Audio storage, stereo swi...
Forum: Programs
Last Post: VikRam025
10 hours ago
» Replies: 3
» Views: 286
|
Who wants to PLAY?
Forum: QBJS, BAM, and Other BASICs
Last Post: a740g
Today, 12:09 AM
» Replies: 5
» Views: 111
|
Most efficient way to bui...
Forum: General Discussion
Last Post: ahenry3068
Yesterday, 11:36 PM
» Replies: 9
» Views: 128
|
QBJS - ANSI Draw
Forum: QBJS, BAM, and Other BASICs
Last Post: madscijr
Yesterday, 11:24 PM
» Replies: 4
» Views: 125
|
_CONSOLEINPUT is blocking
Forum: General Discussion
Last Post: mdijkens
Yesterday, 06:26 PM
» Replies: 6
» Views: 97
|
Fun with Ray Casting
Forum: a740g
Last Post: a740g
Yesterday, 05:50 AM
» Replies: 10
» Views: 235
|
Very basic key mapping de...
Forum: SMcNeill
Last Post: a740g
Yesterday, 02:33 AM
» Replies: 1
» Views: 53
|
Methods in types
Forum: General Discussion
Last Post: bobalooie
Yesterday, 01:02 AM
» Replies: 0
» Views: 60
|
Cautionary tale of open, ...
Forum: General Discussion
Last Post: doppler
01-16-2025, 10:23 AM
» Replies: 3
» Views: 120
|
Extended KotD #23 and #24...
Forum: Keyword of the Day!
Last Post: SMcNeill
01-16-2025, 09:51 AM
» Replies: 0
» Views: 56
|
|
|
| Life Experiments |
|
Posted by: bplus - 08-18-2022, 05:27 PM - Forum: bplus
- Replies (5)
|
 |
I suspect I am on a private quest with Conway's "Game" of Life so I will continue updates here in this little corner of forum from here:
https://qb64phoenix.com/forum/showthread...09#pid5509
I sort of accomplished something already finding the 3X8 block seed that cycles through 15 patterns, immortal life if undisturbed like blinkers and gliders (if they don't run into borders out on the edge of the universe or anything else). I suspect if 2 gliders collide just the right way they will create instead of cancel each other out. I might have found the 3X8 block seed quicker trying triple line lengths so that is probably next experiment then 4 and 5 line stacks maybe.
I have updated all previous code with a Fade (f) or Traditional Black and White Off/On (t) screen toggles. I like fade because the old alive cells fade away and blinkers look almost like stationary plusses ie you can easily tell the run is done with stationary debris or nothing left in the screen.
Here is single line experiments increasing line length to 70 width of screen in cells, now with f/t toggles:
Code: (Select All) Option _Explicit ' by bplus 2019-09-20 mod to Life Line Seed Experiment 2022-08-17
_Title "Life Line Seed Experiment: f for fade look, t for traditioanal look, press spacebar when stabilized, esc to quit"
DefLng A-Z
Const xmax = 700, ymax = 700, n = 140, s = 5
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 360, 0
Dim g, x, y, r, nc, wait$, Fade 'nc is neighbor count
Dim a(0 To n + 1, 0 To n + 1), ng(0 To n + 1, 0 To n + 1) ' a() is Life array, ng() is next generation
Color &HFFFFFF00, &HFF080021: r = 35
Do 'seed for Conway's Life Classic
' Using lines of different lengths if line is odd symmetric results, even maybe not top and bottom differ
Cls
g = 0: r = r - 1: If r = 1 Then r = 68
For y = 0 To n + 1
For x = 0 To n + 1 'for symmetric line blocks
If y = n / 2 And x > r And x < (n + 1 - r) Then a(x, y) = 1 Else a(x, y) = 0
If a(x, y) = 1 Then
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), &HFFFFFFFF, BF
Else
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), &HFF000000, BF
End If
Next
Next
' Sleep refuses to cooperate with _KeyClear! So a full stop Input statement.
Locate 1, 1: Input "This is the line seed. Press enter to continue..."; wait$
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
' Run through the generations use any key to stop run and reseed with new line length.
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
While InKey$ <> " " And _KeyDown(27) = 0 'run life until spacebar detected
For x = 1 To n
For y = 1 To n
nc = a(x - 1, y - 1) + a(x - 1, y) + a(x - 1, y + 1) + a(x, y - 1) + a(x, y + 1) + a(x + 1, y - 1) + a(x + 1, y) + a(x + 1, y + 1)
If a(x, y) Then ' a is alive Classic Conway's Life Rules for survival
If nc = 2 Or nc = 3 Then ng(x, y) = 1 Else ng(x, y) = 0
Else 'birth?
If nc = 3 Then ng(x, y) = 1 Else ng(x, y) = 0
End If
Next
Next
If _KeyDown(Asc("t")) Then Fade = 0
If _KeyDown(Asc("f")) Then Fade = -1
If Fade Then Line (0, 0)-Step(xmax, ymax), &H30080021, BF Else Line (0, 0)-Step(xmax, ymax), &HFF080021, BF
For y = 1 To n
For x = 1 To n
If a(x, y) Then 'this separates into individual cells for Classic look
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), &HFFFFFFFF, BF
End If
Next
Next
Locate 1, 1: Print "Seed:"; r; " Gen:"; g
_Display
LngArrCopy ng(), a() ' good! looks like mem copy works
g = g + 1
_Display
_Limit 30
Wend
Loop Until _KeyDown(27)
Cls: End
Sub LngArrCopy (A&(), copyB&())
'ReDim copyB&(LBound(A&) To UBound(A&)) 'container for _memget is ready
Dim m As _MEM
m = _Mem(A&())
_MemGet m, m.OFFSET, copyB&()
_MemFree m '<<<<<<<<<<<<<<<<<<<<<<<<<< like freeimage very important
End Sub
Double line, which starts small and really short runs but gets more interesting as lines get longer:
Code: (Select All) Option _Explicit ' by bplus 2019-09-20 mod to Life Line Seed Experiment 2022-08-17
_Title "Life Double Line Seed Experiment: f for fade look, t for traditioanal look, press spacebar when stabilized, esc to quit"
DefLng A-Z
Const xmax = 700, ymax = 700, n = 140, s = 5
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 360, 0
Dim g, x, y, r, nc, wait$, Fade 'nc is neighbor count
Dim a(0 To n + 1, 0 To n + 1), ng(0 To n + 1, 0 To n + 1) ' a() is Life array, ng() is next generation
Color &HFFFFFF00, &HFF080021: r = 70
Do 'seed for Conway's Life Classic
' Using lines of different lengths if line is odd symmetric results, even maybe not top and bottom differ
Cls
g = 0: r = r - 1: If r = 1 Then r = 70
For y = 0 To n + 1
For x = 0 To n + 1 'for symmetric line blocks
If (y = n / 2 Or y = (n / 2 + 1)) And x > r And x < (n + 1 - r) Then a(x, y) = 1 Else a(x, y) = 0
If a(x, y) = 1 Then
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), &HFFFFFFFF, BF
Else
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), &HFF000000, BF
End If
Next
Next
' Sleep refuses to cooperate with _KeyClear! So a full stop Input statement.
Locate 1, 1: Input "This is the line seed. Press enter to continue..."; wait$
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
' Run through the generations use any key to stop run and reseed with new line length.
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
While InKey$ <> " " And _KeyDown(27) = 0 'run life until spacebar detected
For x = 1 To n
For y = 1 To n
nc = a(x - 1, y - 1) + a(x - 1, y) + a(x - 1, y + 1) + a(x, y - 1) + a(x, y + 1) + a(x + 1, y - 1) + a(x + 1, y) + a(x + 1, y + 1)
If a(x, y) Then ' a is alive Classic Conway's Life Rules for survival
If nc = 2 Or nc = 3 Then ng(x, y) = 1 Else ng(x, y) = 0
Else 'birth?
If nc = 3 Then ng(x, y) = 1 Else ng(x, y) = 0
End If
Next
Next
If _KeyDown(Asc("t")) Then Fade = 0
If _KeyDown(Asc("f")) Then Fade = -1
If Fade Then Line (0, 0)-Step(xmax, ymax), &H30080021, BF Else Line (0, 0)-Step(xmax, ymax), &HFF080021, BF
For y = 1 To n
For x = 1 To n
If a(x, y) Then 'this separates into individual cells for Classic look
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), &HFFFFFFFF, BF
End If
Next
Next
Locate 1, 1: Print "Seed:"; r; " Gen:"; g
_Display
LngArrCopy ng(), a() ' good! looks like mem copy works
g = g + 1
_Display
_Limit 30
Wend
Loop Until _KeyDown(27)
Cls: End
Sub LngArrCopy (A&(), copyB&())
'ReDim copyB&(LBound(A&) To UBound(A&)) 'container for _memget is ready
Dim m As _MEM
m = _Mem(A&())
_MemGet m, m.OFFSET, copyB&()
_MemFree m '<<<<<<<<<<<<<<<<<<<<<<<<<< like freeimage very important
End Sub
I call it a Square Seed but it is more like a TicTacToe Grid that shrinks the central square down to a Double Line. My first try towards Grids that I suspect might be really interesting seed.
Code: (Select All) Option _Explicit ' by bplus 2019-09-20 mod to Life Line Seed Experiment 2022-08-17
_Title "Life Square Seed: f for fade look, t for traditioanal look, press spacebar when stabilized, esc to quit"
DefLng A-Z
Const xmax = 700, ymax = 700, n = 140, s = 5
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 360, 0
Dim g, x, y, r, nc, wait$, Fade 'nc is neighbor count
Dim a(0 To n + 1, 0 To n + 1), ng(0 To n + 1, 0 To n + 1) ' a() is Life array, ng() is next generation
Color &HFFFFFF00, &HFF080021: r = 68
Do 'seed for Conway's Life Classic
' Using lines of different lengths if line is odd symmetric results, even maybe not top and bottom differ
Cls
g = 0: r = r + 1: If r = 70 Then r = 0
For y = 0 To n + 1
For x = 0 To n + 1 'for symmetric line blocks
'If y = n / 2 And x > r And x < (n + 1 - r) Then a(x, y) = 1 Else a(x, y) = 0
If y = 1 + r Or y = n - r Or x = 1 + r Or x = n - r Then a(x, y) = 1 Else a(x, y) = 0
If a(x, y) = 1 Then
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), &HFFFFFFFF, BF
Else
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), &HFF000000, BF
End If
Next
Next
' Sleep refuses to cooperate with _KeyClear! So a full stop Input statement.
Locate 1, 1: Input "This is the line seed. Press enter to continue..."; wait$
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
' Run through the generations use any key to stop run and reseed with new line length.
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
While InKey$ <> " " And _KeyDown(27) = 0 'run life until spacebar detected
For x = 1 To n
For y = 1 To n
nc = a(x - 1, y - 1) + a(x - 1, y) + a(x - 1, y + 1) + a(x, y - 1) + a(x, y + 1) + a(x + 1, y - 1) + a(x + 1, y) + a(x + 1, y + 1)
If a(x, y) Then ' a is alive Classic Conway's Life Rules for survival
If nc = 2 Or nc = 3 Then ng(x, y) = 1 Else ng(x, y) = 0
Else 'birth?
If nc = 3 Then ng(x, y) = 1 Else ng(x, y) = 0
End If
Next
Next
If _KeyDown(Asc("t")) Then Fade = 0
If _KeyDown(Asc("f")) Then Fade = -1
If Fade Then Line (0, 0)-Step(xmax, ymax), &H30080021, BF Else Line (0, 0)-Step(xmax, ymax), &HFF080021, BF
For y = 1 To n
For x = 1 To n
If a(x, y) Then 'this separates into individual cells for Classic look
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), &HFFFFFFFF, BF
End If
Next
Next
Locate 1, 1: Print "Seed:"; r; " Gen:"; g
_Display
LngArrCopy ng(), a() ' good! looks like mem copy works
g = g + 1
_Display
_Limit 30
Wend
Loop Until _KeyDown(27)
Cls: End
Sub LngArrCopy (A&(), copyB&())
'ReDim copyB&(LBound(A&) To UBound(A&)) 'container for _memget is ready
Dim m As _MEM
m = _Mem(A&())
_MemGet m, m.OFFSET, copyB&()
_MemFree m '<<<<<<<<<<<<<<<<<<<<<<<<<< like freeimage very important
End Sub
The above is the one where I discovered the 3x8 seed that Persists by cycling through 15 patterns (I have it set to show that in first run of code) and here "Persist" isolated from above. I like this pattern because it looks like an alien space ship!
Code: (Select All) Option _Explicit ' by bplus 2019-09-20 mod to Life Line Seed Experiment 2022-08-17
_Title "Life Persist Seed: f for fade look, t for traditioanal look, press spacebar for next state, esc to quit"
DefLng A-Z
Const xmax = 700, ymax = 700, n = 140, s = 5
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 360, 0
Dim g, x, y, r, nc, wait$, Fade 'nc is neighbor count
Dim a(0 To n + 1, 0 To n + 1), ng(0 To n + 1, 0 To n + 1) ' a() is Life array, ng() is next generation
Color &HFFFFFF00, &HFF080021: r = 68
'Do 'seed for Conway's Life Classic
' Using lines of different lengths if line is odd symmetric results, even maybe not top and bottom differ
Cls
g = 0: r = r + 1: If r = 70 Then r = 0
For y = 0 To n + 1
For x = 0 To n + 1 'for symmetric line blocks
'If y = n / 2 And x > r And x < (n + 1 - r) Then a(x, y) = 1 Else a(x, y) = 0
If y >= n / 2 - 1 And y <= n / 2 + 1 Then
If x >= n / 2 - 4 And x <= n / 2 + 3 Then
a(x, y) = 1
End If
End If
If a(x, y) = 1 Then
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), &HFFFFFFFF, BF
Else
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), &HFF000000, BF
End If
Next
Next
' Sleep refuses to cooperate with _KeyClear! So a full stop Input statement.
Locate 1, 1: Input "This is the line seed. Press enter to continue..."; wait$
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
' Run through the generations use any key to stop run and reseed with new line length.
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
While _KeyDown(27) = 0 'run life until spacebar detected
For x = 1 To n
For y = 1 To n
nc = a(x - 1, y - 1) + a(x - 1, y) + a(x - 1, y + 1) + a(x, y - 1) + a(x, y + 1) + a(x + 1, y - 1) + a(x + 1, y) + a(x + 1, y + 1)
If a(x, y) Then ' a is alive Classic Conway's Life Rules for survival
If nc = 2 Or nc = 3 Then ng(x, y) = 1 Else ng(x, y) = 0
Else 'birth?
If nc = 3 Then ng(x, y) = 1 Else ng(x, y) = 0
End If
Next
Next
If _KeyDown(Asc("t")) Then Fade = 0
If _KeyDown(Asc("f")) Then Fade = -1
If Fade Then Line (0, 0)-Step(xmax, ymax), &H30080021, BF Else Line (0, 0)-Step(xmax, ymax), &HFF080021, BF
For y = 1 To n
For x = 1 To n
If a(x, y) Then 'this separates into individual cells for Classic look
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), &HFFFFFFFF, BF
End If
Next
Next
Locate 1, 1: Print "Seed:"; r; " Gen:"; g
_Display
LngArrCopy ng(), a() ' good! looks like mem copy works
g = g + 1
If g Mod 15 = 0 Then _PrintString (334, 390), Str$(15) Else _PrintString (334, 390), Str$(g Mod 15)
_Display
Sleep
Wend
'Loop Until _KeyDown(27)
Cls: End
Sub LngArrCopy (A&(), copyB&())
'ReDim copyB&(LBound(A&) To UBound(A&)) 'container for _memget is ready
Dim m As _MEM
m = _Mem(A&())
_MemGet m, m.OFFSET, copyB&()
_MemFree m '<<<<<<<<<<<<<<<<<<<<<<<<<< like freeimage very important
End Sub
Put it in Fade mode and hold down the spacebar!
|
|
|
| Almost the ultimate QB64 challenge: build a custom desktop environment ! |
|
Posted by: madscijr - 08-18-2022, 12:15 PM - Forum: General Discussion
- Replies (5)
|
 |
[edited to use the correct term "desktop environment" instead of "shell", although making a shell could also be part of the challenge]
All this talk of Linux distros had me curious - has anybody ever tried making an operating system in QB64 or QuickBasic? I assume not, as most OSes have to be coded in a low level language like assembly or C that gives sufficient control and speed that other applications can run on top of. And then we have to worry about device drivers and all of that. Probably a non-starter! But that would probably be the ultimate challenge for any language, especially QB64.
HOWEVER, what about a custom desktop environment that runs on top of an OS? Linux has desktops like Gnome, Microsoft Windows upto version 3.1 and NT4 that ran on top of DOS, etc. I'm curious if anyone has attempted this in QB64? Being that QB64 runs on Windows, Mac, and Linux, it could be an interesting project to make a front end that runs on all 3, making them look and behave identically...
|
|
|
|
| Eye of the Tiger song using PLAY commands |
|
Posted by: SierraKen - 08-17-2022, 11:41 PM - Forum: Programs
- Replies (7)
|
 |
Eye of the Tiger - by Survivor, using PLAY. Personally, I only recognize the last stanza, so it's not perfect. lol
Code: (Select All) 'Notes from: https://noobnotes.net/eye-of-the-tiger-survivor/
Play "MB v50g6,b6g6f6d#6g6f6,d#6"
Play "MB F6F6F6F6G6F6,D#6"
Play "MB G6Bb6C6,G6"
Play "MB F6D#6G6F6F6D#6"
Play "MB C6D#6F6F6D#6F6F6D#6,G6"
Play "MB G6G6,B6G6D#6F6D#6G6F6,D#6"
Play "MB F6F6F6F6F6G6F6,D#6"
Play "MB G6G6B6C6"
Play "MB F6D#6G6F6F6D#6"
Play "MB C6D#6F6F6D#6F6F6D#6,G6"
Play "MB F6G6G#6G#6G#6G#6,G6"
Play "MB F6D#6D#6F6G6F6"
Play "MB F6,G6G#6G#6G#6G#6G6F6D#6G6,F6"
Play "MB F6G6G#6G#6G#6,G#6,G6"
Play "MB F6D#6D#6F6G6F6"
Play "MB F6G6G#6,G6G#6B6G#6B6C6"
Play "MB F6D#6F6D#6"
Print "Song: Eye of the Tiger"
Print "Band: Survivor"
Print
Print "Risin' up, back on the street"
Print "Did my time, took my chances"
Print "Went the distance"
Print "Now I'm back on my feet"
Print "Just a man and his will to survive.."
Print
Print "So many times, it happens too fast"
Print "You trade your passion for glory"
Print "Don't lose your grip"
Print "On the dreams of the past"
Print "You must fight just to keep them alive..."
Print
Print "It's the eye of the tiger,"
Print "It's the thrill of the fight"
Print "Risin' up to the challenge of our rival"
Print "And the last known survivor"
Print "Stalks his prey in the night"
Print "And he's watchin' us all with the eye"
Print "Of the tiger!"
|
|
|
|
| Life Experiments |
|
Posted by: bplus - 08-17-2022, 09:05 PM - Forum: Programs
- Replies (3)
|
|
Well @James D Jarvis you did it now, you rekindled my interest in Conway's Life.
For starters add that mem copy method to old code for testing different Line Lengths for Seeds, maybe call it "Life in the Fast Lane!" but it was speedy enough before that I had to use limit the loops!
Anyway different line lengths for seed on a 140 x 140 array. It stays symmetric until we hit top or bottom before the other side does, right and left seem to always be symmetric.
Code: (Select All) Option _Explicit ' by bplus 2019-09-20 mod to Life Line Seed Experiment 2022-08-17
_Title "Life Line Seed Experiment"
DefLng A-Z
Const xmax = 700, ymax = 700, n = 140, s = 5
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 360, 0
Dim g, x, y, r, nc, wait$ 'nc is neighbor count
Dim a(0 To n + 1, 0 To n + 1), ng(0 To n + 1, 0 To n + 1) ' a() is Life array, ng() is next generation
Color &HFFFFFF00, &HFF080021: r = 35
Do 'seed for Conway's Life Classic
' Using lines of different lengths if line is odd symmetric results, even maybe not top and bottom differ << nope it depends !
Cls
g = 0: r = r - 1: If r = 1 Then r = 68
For y = 0 To n + 1
For x = 0 To n + 1 'for symmetric line blocks
If y = n / 2 And x > r And x < (n + 1 - r) Then a(x, y) = 1 Else a(x, y) = 0
If a(x, y) = 1 Then
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), &HFFFFFFFF, BF
Else
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), &HFF000000, BF
End If
Next
Next
' Sleep refuses to cooperate with _KeyClear! So a full stop Input statement.
Locate 1, 1: Input "This is the line seed. Press enter to continue..."; wait$
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
' Run through the generations use any key to stop run and reseed with new line length.
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
While InKey$ <> " " And _KeyDown(27) = 0 'run life until spacebar detected
For x = 1 To n
For y = 1 To n
nc = a(x - 1, y - 1) + a(x - 1, y) + a(x - 1, y + 1) + a(x, y - 1) + a(x, y + 1) + a(x + 1, y - 1) + a(x + 1, y) + a(x + 1, y + 1)
If a(x, y) Then ' a is alive Classic Conway's Life Rules for survival
If nc = 2 Or nc = 3 Then ng(x, y) = 1 Else ng(x, y) = 0
Else 'birth?
If nc = 3 Then ng(x, y) = 1 Else ng(x, y) = 0
End If
Next
Next
Line (0, 0)-Step(xmax, ymax), &H11080021, BF
For y = 1 To n
For x = 1 To n
If a(x, y) Then 'this separates into individual cells for Classic look
Line ((x - 1) * s + 1, (y - 1) * s + 1)-Step(s - 2, s - 2), &HFFFFFFFF, BF
End If
Next
Next
Locate 1, 1: Print "Seed:"; r; " Gen:"; g
_Display
LngArrCopy ng(), a() ' good! looks like mem copy works
g = g + 1
_Display
_Limit 30
Wend
Loop Until _KeyDown(27)
Cls: End
Sub LngArrCopy (A&(), copyB&())
'ReDim copyB&(LBound(A&) To UBound(A&)) 'container for _memget is ready
Dim m As _MEM
m = _Mem(A&())
_MemGet m, m.OFFSET, copyB&()
_MemFree m '<<<<<<<<<<<<<<<<<<<<<<<<<< like freeimage very important
End Sub
|
|
|
|
| Various code questions |
|
Posted by: james2464 - 08-17-2022, 01:57 PM - Forum: Help Me!
- Replies (13)
|
 |
I have a few assorted pieces of code that I don't really understand, and I'm wondering if anyone can help explain or break down what the code means.
1)
Code: (Select All) variable~&(1)
I know the & symbol means long integer, but is "~" part of the variable name or is this part of the variable type?
2)
Code: (Select All) Do: _Limit 10
Loop Until Len(InKey$)
Obviously the point of this is "press a key to continue" but the code is not familiar to me. Do followed by : is a new one, and I'm not sure what _Limit 10 is doing on this line.
Additionally "Loop Until" is normal stuff but having Len(Inkey$) afterward isn't something I've seen before. Is this some advanced efficient coding? These two lines as they appear are a bit over my head.
3)
Code: (Select All) _MemCopy m1, m1.OFFSET, m1.SIZE To m0, m0.OFFSET
This can be found in the wiki, and it says:
The _MEMCOPY statement copies a block of bytes from one memory offset to another offset in memory.
This purpose of this isn't clear to me. Is it just a quicker copying method (as opposed to setting up loops to copy an array) or is there some other advantage?
Also I have no idea what the OFFSET is doing. The wiki says it's about memory blocks so this seems like a more advanced coding/theory (beyond my level of experience)
4)
Code: (Select All) While _MouseInput: Wend
This is probably obvious to everyone here but I'm a bit lost. The wiki shows the Wend statement on a completely different line, so if you have this all on one line, what is happening?
The code I'm referring to has a comment at the end (While _MouseInput: Wend ' clear) so the intent is to clear....but how this works to clear is what I'm wondering.
5)
Code: (Select All) m2Dn = _MouseButton(2) ' button 2 processing
If m2Dn Then ' Btn 2 down
This is straightforward enough, but what's unclear to me is the IF statement:
If m2Dn then
I have never seen this before, where the IF THEN does not have an equation between them. Example:
If m2Dn>1 then
if m2Dn=0 then
I'd definitely like to understand how this works.
Thanks!
|
|
|
|
neat _SndRaw example, but how do you stop _SndRaw from playing? |
|
Posted by: madscijr - 08-16-2022, 06:25 PM - Forum: Help Me!
- Replies (10)
|
|
I was searching through various QB64 examples I had saved,
looking for examples of _SndRaw, and found this interesting one by angros47
(are they still around?) from way back in 2013 (when QB64 was at qb64.net!)
The first sound starts off okay but almost immediately becomes noise,
and I'm not sure why or how to turn it off.
The second sound is really really cool sounding, like sci fi sounds done on the early Moog synths.
I let it play for a while and it eventually starts sounding like noise, and again, I don't know how to turn it off.
Any input would be appreciated!
Code: (Select All) ' FM (Frequency modulation) sound with _SNDRAW
' http://www.qb64.net/forum/index.php?topic=11395.0
Const FALSE = 0
Const TRUE = Not FALSE
'FM_Sound_Test1
FM_Sound_Test2
End
' /////////////////////////////////////////////////////////////////////////////
' Plays 2 sounds based on angros47's parameters:
'
' 1. sounds okay for about a second, then just plays harsh noise without
' stopping - how do you turn it off without killing the program?
'
' 2. sounds pretty cool! But it goes on forever, does it ever stop?
' (how do you stop _SNDRAW sounds once they start playing?)
Sub FM_Sound_Test2
Dim iSoundFrequency As Integer
Dim iSoundDuration As Integer
Dim iSoundMaxVolume As Integer
Dim sngCarrierAttack As Single
Dim sngCarrierDecay As Single
Dim sngCarrierSustain As Single
Dim sngCarrierRelease As Single
Dim iModulatorFrequency As Integer
Dim sngModulatorPhase As Single
Dim iModulatorMaxLevel As Integer
Dim sngSoundAttack As Single
Dim sngSoundDecay As Single
Dim sngSoundSustain As Single
Dim sngSoundRelease As Single
Dim in$
Do
Input "Press ENTER to play sound #1, 's' to skip, or 'q' to quit"; in$
If in$ = "q" Then Exit Do
If in$ <> "s" Then
iSoundFrequency = 500
iSoundDuration = 182
iSoundMaxVolume = 256
sngCarrierAttack = 0
sngCarrierDecay = 0.1
sngCarrierSustain = 0.01
sngCarrierRelease = 0.5
iModulatorFrequency = 500
sngModulatorPhase = 0.5
iModulatorMaxLevel = 30
sngSoundAttack = 0
sngSoundDecay = 0.1
sngSoundSustain = 0.5
sngSoundRelease = 0.6
FM_Sound _
iSoundFrequency, _
iSoundDuration, _
iSoundMaxVolume, _
sngCarrierAttack, _
sngCarrierDecay, _
sngCarrierSustain, _
sngCarrierRelease, _
iModulatorFrequency, _
sngModulatorPhase, _
iModulatorMaxLevel, _
sngSoundAttack, _
sngSoundDecay, _
sngSoundSustain, _
sngSoundRelease
End If
Input "Press ENTER to play sound #2, 's' to skip, or 'q' to quit"; in$
If in$ = "q" Then Exit Do
If in$ <> "s" Then
iSoundFrequency = 3000
iSoundDuration = 182
iSoundMaxVolume = 256
sngCarrierAttack = 0.5
sngCarrierDecay = 0.2
sngCarrierSustain = 1
sngCarrierRelease = 0.1
iModulatorFrequency = 10
sngModulatorPhase = 0.5
iModulatorMaxLevel = 1000
sngSoundAttack = 0.6
sngSoundDecay = 0.2
sngSoundSustain = 0.7
sngSoundRelease = 0.2
FM_Sound _
iSoundFrequency, _
iSoundDuration, _
iSoundMaxVolume, _
sngCarrierAttack, _
sngCarrierDecay, _
sngCarrierSustain, _
sngCarrierRelease, _
iModulatorFrequency, _
sngModulatorPhase, _
iModulatorMaxLevel, _
sngSoundAttack, _
sngSoundDecay, _
sngSoundSustain, _
sngSoundRelease
End If
Loop
End Sub ' FM_Sound_Test2
' /////////////////////////////////////////////////////////////////////////////
' This version prompts for parameters.
' TODO: simple mouse or keyboard interface for realtime input?
Sub FM_Sound_Test1
Dim iSoundFrequency As Integer
Dim iSoundDuration As Integer
Dim iSoundMaxVolume As Integer
Dim sngCarrierAttack As Single
Dim sngCarrierDecay As Single
Dim sngCarrierSustain As Single
Dim sngCarrierRelease As Single
Dim iModulatorFrequency As Integer
Dim sngModulatorPhase As Single
Dim iModulatorMaxLevel As Integer
Dim sngSoundAttack As Single
Dim sngSoundDecay As Single
Dim sngSoundSustain As Single
Dim sngSoundRelease As Single
Dim in$
Do
Print "--- Sound ---"
Input "Frequency"; iSoundFrequency
Input "Duration"; iSoundDuration
Input "Maximum Volume"; iSoundMaxVolume
Print "--- Carrier ---"
Input "Attack"; sngCarrierAttack
Input "Decay"; sngCarrierDecay
Input "Sustain"; sngCarrierSustain
Input "Release"; sngCarrierRelease
Print "--- Modulator ---"
Input "Frequency"; iModulatorFrequency
Input "Phase"; sngModulatorPhase
Input "Maximum level"; iModulatorMaxLevel
Print "--- ADSR ---"
Input "Attack"; sngSoundAttack
Input "Decay"; sngSoundDecay
Input "Sustain"; sngSoundSustain
Input "Release"; sngSoundRelease
FM_Sound _
iSoundFrequency, _
iSoundDuration, _
iSoundMaxVolume, _
sngCarrierAttack, _
sngCarrierDecay, _
sngCarrierSustain, _
sngCarrierRelease, _
iModulatorFrequency, _
sngModulatorPhase, _
iModulatorMaxLevel, _
sngSoundAttack, _
sngSoundDecay, _
sngSoundSustain, _
sngSoundRelease
Input "Type 'q' to quit or any key to continue"; in$
If in$ = "q" Then Exit Do
Loop
End Sub ' FM_Sound_Test1
' /////////////////////////////////////////////////////////////////////////////
' Version 2 of angros47's function, modified by madscijr:
' - more descriptive variable names,
' - user can press ESC to quit.
' TODO: if user presses ESC, stop playing the sound. How??
Sub FM_Sound( _
iSoundFrequency as integer, _
iSoundDuration as integer, _
iSoundMaxVolume as integer, _
sngCarrierAttack as single, _
sngCarrierDecay as single, _
sngCarrierSustain as single, _
sngCarrierRelease as single, _
iModulatorFrequency as integer, _
sngModulatorPhase as single, _
iModulatorMaxLevel as integer, _
sngSoundAttack as single, _
sngSoundDecay as single, _
sngSoundSustain as single, _
sngSoundRelease as single)
Dim nSamples As Long
Dim CS As Single
Dim MS As Single
Dim CEnvelopeInc As Double
Dim CEnvelopeDecD As Double
Dim CEnvelopeDecR As Double
Dim MEnvelopeInc As Double
Dim MEnvelopeDecD As Double
Dim MEnvelopeDecR As Double
Dim iLoop As Integer
nSamples = _SndRate * Int(iSoundDuration / 18.2) ' seconds
CS = 1 - sngCarrierAttack - sngCarrierDecay - sngCarrierRelease
MS = 1 - sngSoundAttack - sngSoundDecay - sngSoundRelease
CEnvelopeInc = 100 * iSoundMaxVolume / (nSamples * sngCarrierAttack + 1)
CEnvelopeDecD = 100 * iSoundMaxVolume * (1 - sngCarrierSustain) / (nSamples * sngCarrierDecay + 1)
CEnvelopeDecR = 100 * iSoundMaxVolume * sngCarrierSustain / (nSamples * sngCarrierRelease + 1)
sngCarrierDecay = sngCarrierDecay + sngCarrierAttack
CS = CS + sngCarrierDecay
sngCarrierRelease = sngCarrierRelease + CS
MEnvelopeInc = iModulatorMaxLevel / (nSamples * sngSoundAttack + 1)
MEnvelopeDecD = iModulatorMaxLevel * (1 - sngSoundSustain) / (nSamples * sngSoundDecay + 1)
MEnvelopeDecR = iModulatorMaxLevel * sngSoundSustain / (nSamples * sngSoundRelease + 1)
sngSoundDecay = sngSoundDecay + sngSoundAttack
MS = MS + sngSoundDecay
sngSoundRelease = sngSoundRelease + MS
Pi2 = 8 * Atn(1) '2 * pi
Amplitude = .000001
For iLoop = 0 To nSamples
If iLoop <= sngCarrierAttack * nSamples Then
Volume = Volume + CEnvelopeInc
ElseIf iLoop < sngCarrierDecay * nSamples Then
Volume = Volume - CEnvelopeDecD
ElseIf iLoop < CS * nSamples Then
ElseIf iLoop < sngCarrierRelease * nSamples Then
Volume = Volume - CEnvelopeDecR
End If
If iLoop <= sngSoundAttack * nSamples Then
Mamp = Mamp + MEnvelopeInc
ElseIf iLoop < sngSoundDecay * nSamples Then
Mamp = Mamp - MEnvelopeDecD
ElseIf iLoop < MS * nSamples Then
ElseIf iLoop < sngSoundRelease * nSamples Then
Mamp = Mamp - MEnvelopeDecR
End If
Modulator = Cos(Pi2 / _SndRate * iLoop * iModulatorFrequency + sngModulatorPhase) * Mamp
Waveform = Sin(Pi2 / _SndRate * iLoop * iSoundFrequency + Modulator) * Volume
_SndRaw Amplitude * Waveform
If InKey$ = Chr$(27) Then Exit For ' GIVE THE USER A WAY TO EXIT
Next iLoop
Do
If InKey$ = Chr$(27) Then Exit Do ' GIVE THE USER A WAY TO EXIT
Loop While _SndRawLen
End Sub ' FM_Sound
' /////////////////////////////////////////////////////////////////////////////
' Original version of the code by angros47
' -----------------------------------------------------------------------------
' angros47
' « on: September 15, 2013, 12:19:04 pm »
' http://www.qb64.net/forum/index.php?topic=11395.0
'
' Years ago, I made a program to generate sound effects in FreeBasic...
' just for fun, I tried to port it to QB64, too (the _SNDRAW helped, of course).
' Have fun!
' -----------------------------------------------------------------------------
' LeChuck
' « Reply #1 on: September 15, 2013, 02:27:54 pm »
' http://www.qb64.net/forum/index.php?topic=11395.msg97452#msg97452
'
' Hey angros47,
' Can you add some demo values as well because I can't seem to generate any
' sound.
' Thanks
' No disaster occurs for any single reason.
' -----------------------------------------------------------------------------
' angros47
' « Reply #2 on: September 16, 2013, 08:03:22 am »
' http://www.qb64.net/forum/index.php?topic=11395.msg97464#msg97464
'
' Frequency 500
' Duration 182
' Maximum Volume 256
'
' Carrier
' Attack 0
' Decay 0.1
' Sustain 0.01
' Release 0.5
'
' Modulator
' Frequency 500
' Phase 0.5
' Maximum level 30
'
' Attack 0
' Decay 0.1
' Sustain 0.5
' Release 0.6
'
' Or
'
' Frequency 3000
' Duration 182
' Maximum Volume 256
'
' Carrier
' Attack 0.5
' Decay 0.2
' Sustain 1
' Release 0.1
'
' Modulator
' Frequency 10
' Phase 0.5
' Maximum level 1000
'
' Attack 0.6
' Decay 0.2
' Sustain 0.7
' Release 0.2
' -----------------------------------------------------------------------------
' OlDosLover
' « Reply #3 on: September 16, 2013, 06:54:06 pm »
' http://www.qb64.net/forum/index.php?topic=11395.msg97469#msg97469
'
' Hi all,
' Wow! Very impressive. I think this might be QB64's first sound generator.
' Thank you for sharing this valuable tool.
' OlDosLover.
' -----------------------------------------------------------------------------
Sub FM_Sound_v1
Input "Frequency"; Frequency
Input "Duration"; Duration
Input "Maximum Volume"; MaxVol
Print "--- Carrier ---"
Input "Attack"; ca
Input "Decay"; cd
Input "Sustain"; csl
Input "Release"; cr
Print "--- Modulator ---"
Input "Frequency"; MFrequency
Input "Phase"; ModStart
Input "Maximum level"; MaxModulator
Input "Attack"; Ma
Input "Decay"; md
Input "Sustain"; msl
Input "Release"; mr
Dim nSamples As Long
Dim CS As Single, MS As Single
nSamples = _SndRate * Int(Duration / 18.2) ' seconds
CS = 1 - ca - cd - cr
MS = 1 - Ma - md - mr
Dim CEnvelopeInc As Double, CEnvelopeDecD As Double, CEnvelopeDecR As Double
CEnvelopeInc = 100 * MaxVol / (nSamples * ca + 1)
CEnvelopeDecD = 100 * MaxVol * (1 - csl) / (nSamples * cd + 1)
CEnvelopeDecR = 100 * MaxVol * csl / (nSamples * cr + 1)
cd = cd + ca
CS = CS + cd
cr = cr + CS
Dim MEnvelopeInc As Double, MEnvelopeDecD As Double, MEnvelopeDecR As Double
MEnvelopeInc = MaxModulator / (nSamples * Ma + 1)
MEnvelopeDecD = MaxModulator * (1 - msl) / (nSamples * md + 1)
MEnvelopeDecR = MaxModulator * msl / (nSamples * mr + 1)
md = md + Ma
MS = MS + md
mr = mr + MS
Pi2 = 8 * Atn(1) '2 * pi
Amplitude = .000001
For i = 0 To nSamples
If i <= ca * nSamples Then
Volume = Volume + CEnvelopeInc
ElseIf i < cd * nSamples Then
Volume = Volume - CEnvelopeDecD
ElseIf i < CS * nSamples Then
ElseIf i < cr * nSamples Then
Volume = Volume - CEnvelopeDecR
End If
If i <= Ma * nSamples Then
Mamp = Mamp + MEnvelopeInc
ElseIf i < md * nSamples Then
Mamp = Mamp - MEnvelopeDecD
ElseIf i < MS * nSamples Then
ElseIf i < mr * nSamples Then
Mamp = Mamp - MEnvelopeDecR
End If
Modulator = Cos(Pi2 / _SndRate * i * MFrequency + ModStart) * Mamp
Waveform = Sin(Pi2 / _SndRate * i * Frequency + Modulator) * Volume
_SndRaw Amplitude * Waveform
Next
Do: Loop While _SndRawLen
End Sub ' FM_Sound_v1
|
|
|
|
| Monty Hall Simulation |
|
Posted by: dcromley - 08-16-2022, 03:51 PM - Forum: Programs
- Replies (12)
|
 |
Quote:>> I wrote: (https://qb64phoenix.com/forum/showthread...50#pid5250):
> I agree (.. nonsense).
> So many internet bytes have been wasted on .99999.. = 1. Reminds me of the excessive threads regarding the Monty Hall "problem".
> But it IS worth the time to get the not-too-difficult "solution" to the Monty Hall problem. It is not immediately obvious.
Quote:>> @Jack wrote:
> all talk and no code, why don't you show us a dignified answer?
Thanks for the challenge.
The classic 'Monty Hall' problem is interesting: (from https://en.wikipedia.org/wiki/Monty_Hall_problem)
Suppose you're on a game show, and you're given the choice of three doors:
Behind one door is a car; behind the others, goats.
You pick a door, say #1.
The host opens another door, say door #3, which has a goat.
He then says to you, 'Do you want to change your pick to door #2?'
Is it to your advantage to switch your choice?
If you "stick" (don't switch), the probability is simple:
P(win) = P(choice is car) = 1/3
If you "switch":
P(win) = P(choice is not the car) = 2/3
because the host will then open the other non-car door
and offer you the third door, which has to have the car.
But that's just MY take. There has been enormous discussion on the subject. Hit the link above for a BIG read.
This program simulates many trials of the Monty Hall "problem".
It pretty much confirms the 1/3 - 2/3 probabilities.
Code: (Select All) _Title "Monty Hall Simulator" ' dcromley
Option _Explicit
Dim s$, pause$, n
Dim Shared carDoor, choiceDoor, openDoor, offerDoor
Dim stickerWins, stickerLosses, switcherWins, switcherLosses
Randomize Timer
Locate 2, 6: Print " '1' for single trial; '2' for continuous running; ESC to exit"
pause$ = "1"
Do
n = n + 1
Locate 4, 2: Print "Trial#";: Print Using "#,###,###,###"; n
' get setup for this n
carDoor = 1 + Int(Rnd * 3) ' the car, 1-3
choiceDoor = 1 + Int(Rnd * 3) ' the choice,1-3
openDoor = getopenDoor ' host opens a non-car Door
offerDoor = getofferDoor ' the offer is not the choiceDoor, not the openDoor
Locate , 2: Print "carDoor="; carDoor
Locate , 2: Print "choiceDoor="; choiceDoor
Locate , 2: Print "openDoor="; openDoor
Locate , 2: Print "offerDoor="; offerDoor
' -- the sticker (non-switcher) --
If choiceDoor = carDoor Then stickerWins = stickerWins + 1 Else stickerLosses = stickerLosses + 1
' -- the switcher --
If offerDoor = carDoor Then switcherWins = switcherWins + 1 Else switcherLosses = switcherLosses + 1
' post results
Locate , 2
print using "Non-Switcher: Wins=#,###,###,### Losses=#,###,###,### Percent=###.###"; _
stickerWins;stickerLosses;100*stickerWIns/n
Locate , 2
print using "Switcher: Wins=#,###,###,### Losses=#,###,###,### Percent=###.###"; _
switcherWins;switcherLosses;100*switcherWIns/n
If pause$ = "1" Then
Do
pause$ = InKey$
Loop While pause$ = ""
Else
pause$ = InKey$
End If
Loop Until pause$ = Chr$(27)
Function getopenDoor () ' open a non-car door
Dim r
Do
r = 1 + Int(Rnd * 3)
Loop Until r <> choiceDoor And r <> carDoor
getopenDoor = r
End Function
Function getofferDoor () ' offer the non-open door
Dim r
Do
r = 1 + Int(Rnd * 3)
Loop Until r <> choiceDoor And r <> openDoor
getofferDoor = r
End Function
|
|
|
|
| Bad Life |
|
Posted by: James D Jarvis - 08-16-2022, 02:12 PM - Forum: Programs
- Replies (2)
|
 |
Ever code anything with a poor recollection of how it's been done before?
Well this is what you get.
Bad Life.
Play with the variables and you are getting a whole different set of results.
Code: (Select All) 'bad life
'by James D. Jarvis
'I was knocking out a quick version of life seeded by mouse doodles and something went wrong
'eventually the program mutated into what you see now
'change the values and what emerges will vary
maxx = 600 'screen x
maxy = 500 'screen y
agelimit = 8 'the oldest a cell can be, any positivetve value, you want it higher than weaklim
growthboost = 2 'how much a cell grows each cycle
weaklim = 5 'the point at which cells are too weak to go on
merger = 1.71 ' the factor for merging cells some of the largest differences come from changing this value, any value except 0 will work
logic = 9 ' 0 to 9
pointer = 1 '1 to 3 , 1 is the only sensible one
Screen _NewImage(maxx, maxy, 256)
_Title "Bad Life"
Dim cell(0 To maxx - 1, 0 To maxy - 1)
Dim ncell(0 To maxx - 1, 0 To maxy - 1)
biglooplimit = (maxx + maxy) * 10
For x = 1 To maxx - 1
For y = 1 To maxy - 1
cell(x, y) = 0
Next y
Next x
Print "Bad Life"
Print "Doodle on the screen with the mouse. Press any key when ready."
'you can keep placing points later in the program but it doesn't wait for you
Do
_Limit 60
Do While _MouseInput
x = _MouseX
y = _MouseY
'check for the mouse pointer in the image drawing area
If _MouseButton(1) Then
PSet (x, y), 1
cell(x, y) = 4
If pointer > 1 Then
Select Case pointer
Case 2
For px = x - 1 To x + 1
For py = y - 1 To y + 1
cell(px, py) = cell(px, py) + 4
PSet (px, py), cell(px, py)
Next py
Next px
Case 3
For px = x - 2 To x + 2
For py = y - 2 To y + 2
cell(px, py) = cell(px, py) + Int((Abs(px) + Abs(py)) / 2)
PSet (px, py), cell(px, py)
Next py
Next px
End Select
End If
End If
Loop
a$ = InKey$
Loop Until a$ <> ""
g = 0
Do
Cls
_Limit 60
For x = 2 To maxx - 2
_Limit biglooplimit
For y = 2 To maxy - 2
ncell(x, y) = 0
If logic > -1 Then
If cell(x - 1, y) > 0 Then ncell(x, y) = Int((cell(x - 1, y) + cell(x, y)) / merger) + growthboost
If cell(x + 1, y) > 0 Then ncell(x, y) = Int((cell(x + 1, y) + cell(x, y)) / merger) + growthboost
If cell(x, y - 1) > 0 Then ncell(x, y) = Int((cell(x, y - 1) + cell(x, y)) / merger) + growthboost
If cell(x, y + 1) > 0 Then ncell(x, y) = Int((cell(x, y + 1) + cell(x, y)) / merger) + growthboost
End If
If logic > 0 Then If cell(x, y) > 0 Then ncell(x, y) = cell(x, y) + growthboost
If logic > 1 Then
If cell(x - 1, y - 1) > 0 Then ncell(x, y) = Int((cell(x - 1, y - 1) + cell(x, y)) / merger) + growthboost
If cell(x - 1, y + 1) > 0 Then ncell(x, y) = Int((cell(x - 1, y + 1) + cell(x, y)) / merger) + growthboost
If cell(x + 1, y - 1) > 0 Then ncell(x, y) = Int((cell(x + 1, y - 1) + cell(x, y)) / merger) + growthboost
If cell(x + 1, y + 1) > 0 Then ncell(x, y) = Int((cell(x + 1, y + 1) + cell(x, y)) / merger) + growthboost
End If
If logic > 2 Then
If cell(x - 1, y) > 0 Then ncell(x, y) = cell(x, y) + growthboost
If cell(x + 1, y) > 0 Then ncell(x, y) = cell(x, y) + growthboost
If cell(x, y - 1) > 0 Then ncell(x, y) = cell(x, y) + growthboost
If cell(x, y + 1) > 0 Then ncell(x, y) = cell(x, y) + growthboost
End If
If logic > 3 Then
If cell(x - 1, y - 1) > 0 Then ncell(x, y) = cell(x, y) + growthboost
If cell(x - 1, y + 1) > 0 Then ncell(x, y) = cell(x, y) + growthboost
If cell(x + 1, y - 1) > 0 Then ncell(x, y) = cell(x, y) + growthboost
If cell(x + 1, y + 1) > 0 Then ncell(x, y) = cell(x, y) + growthboost
End If
If logic > 4 Then
If cell(x - 1, y - 1) > cell(x, y) Then ncell(x, y) = cell(x, y) + growthboost
If cell(x - 1, y + 1) > cell(x, y) Then ncell(x, y) = cell(x, y) + growthboost
If cell(x + 1, y - 1) > cell(x, y) Then ncell(x, y) = cell(x, y) + growthboost
If cell(x + 1, y + 1) > cell(x, y) Then ncell(x, y) = cell(x, y) + growthboost
End If
If logic > 5 Then
If cell(x - 1, y) > cell(x, y) / 2 Then ncell(x, y) = Int((cell(x - 1, y) + cell(x, y)) / merger) + growthboost
If cell(x + 1, y) > cell(x, y) / 2 Then ncell(x, y) = Int((cell(x + 1, y) + cell(x, y)) / merger) + growthboost
If cell(x, y - 1) > cell(x, y) / 2 Then ncell(x, y) = Int((cell(x, y - 1) + cell(x, y)) / merger) + growthboost
If cell(x, y + 1) > cell(x, y) / 2 Then ncell(x, y) = Int((cell(x, y + 1) + cell(x, y)) / merger) + growthboost
End If
If logic > 7 Then
If cell(x - 1, y - 1) > 0 Then ncell(x, y) = Int((cell(x - 1, y - 1) + ncell(x, y)) / merger) + growthboost
If cell(x - 1, y + 1) > 0 Then ncell(x, y) = Int((cell(x - 1, y + 1) + ncell(x, y)) / merger) + growthboost
If cell(x + 1, y - 1) > 0 Then ncell(x, y) = Int((cell(x + 1, y - 1) + ncell(x, y)) / merger) + growthboost
If cell(x + 1, y + 1) > 0 Then ncell(x, y) = Int((cell(x + 1, y + 1) + ncell(x, y)) / merger) + growthboost
End If
If logic > 8 Then
If cell(x - 1, y) > cell(x, y) / 2 Then ncell(x, y) = 0
If cell(x + 1, y) > cell(x, y) / 2 Then ncell(x, y) = 0
If cell(x, y - 1) > cell(x, y) / 2 Then ncell(x, y) = 0
If cell(x, y + 1) > cell(x, y) / 2 Then ncell(x, y) = 0
End If
Next y
Next x
For y = 2 To maxy - 2
_Limit biglooplimit
For x = 2 To maxx - 2
cell(x, y) = ncell(x, y)
If cell(x, y) > agelimit Or cell(x, y) < weaklim Then cell(x, y) = 0
PSet (x, y), cell(x, y)
Next x
Next y
Locate 1, 1: Print g
_Display
g = g + 1
If B$ = "m" Then merger = merger + 1
If B$ = "n" Then
merger = merger - 1
If merger = 0 Then merger = -1
End If
If B$ = "," Then
weaklim = weaklim - 1
If weaklim < 1 Then weaklim = 1
End If
If B$ = "." Then
weaklim = weaklim + 1
If weaklim > agelimit - 1 Then weaklim = agelimit - 1
End If
If B$ = "a" Then agelimit = agelimit + 1
If B$ = "z" Then
agelimit = agelimit - 1
If agelimit < wealim + growth Then agelimit = wealim + growth
End If
If B$ = "g" Then growthboost = growthboost + 1
If B$ = "f" Then
growthboost = growthboost - 1
If growthboost < 1 Then growthboost = 1
End If
If B$ = "l" Then
logic = logic + 1
If logic > 9 Then logic = 0
End If
B$ = InKey$
Do While _MouseInput
x = _MouseX
y = _MouseY
'check for the mouse pointer in the image drawing area
If _MouseButton(1) Then
PSet (x, y), 1
cell(x, y) = 4
If pointer > 1 Then
Select Case pointer
Case 2
For px = x - 1 To x + 1
For py = y - 1 To y + 1
If px > 1 And py > 1 And px < maxx - 1 And py < maxy - 1 Then
cell(px, py) = cell(px, py) + 4
PSet (px, py), cell(px, py)
End If
Next py
Next px
Case 3
For px = x - 2 To x + 2
For py = y - 2 To y + 2
If px > 2 And py > 2 And px < maxx - 2 And py < maxy - 2 Then
cell(px, py) = cell(px, py) + Int((Abs(px) + Abs(py)) / 2)
PSet (px, py), cell(px, py)
End If
Next py
Next px
Case 4
For px = x - 1 To x + 1
For py = y - 1 To y + 1
cell(px, py) = 0
PSet (px, py), 0
Next py
Next px
End Select
End If
End If
Loop
Loop Until B$ = Chr$(27)
|
|
|
|
|
