| Welcome, Guest |
You have to register before you can post on our site.
|
| Latest Threads |
The QB64 IDE shell
Forum: Utilities
Last Post: JasonPag
09-16-2024, 05:37 PM
» Replies: 9
» Views: 762
|
Importance regarding Ches...
Forum: Utilities
Last Post: JasonPag
09-01-2024, 06:34 PM
» Replies: 0
» Views: 31
|
Chess and Analysis and En...
Forum: Utilities
Last Post: JasonPag
08-28-2024, 02:37 PM
» Replies: 0
» Views: 32
|
DAY 009:_PutImage
Forum: Keyword of the Day!
Last Post: grymmjack
09-02-2023, 02:57 PM
» Replies: 54
» Views: 2,034
|
Fall Banner Contest?
Forum: Site Suggestions
Last Post: grymmjack
08-31-2023, 11:50 PM
» Replies: 36
» Views: 1,261
|
ColorPicker - Function th...
Forum: Dav
Last Post: Dav
08-31-2023, 11:04 PM
» Replies: 3
» Views: 315
|
Goals(1) = New Tile()
Forum: Works in Progress
Last Post: RhoSigma
08-31-2023, 09:45 PM
» Replies: 3
» Views: 127
|
micro(A)v11
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:14 PM
» Replies: 90
» Views: 3,589
|
Updating The Single Most ...
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:13 PM
» Replies: 7
» Views: 254
|
QBJS Image Question
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 05:49 PM
» Replies: 5
» Views: 155
|
|
|
| Anemometer Wind Gauge |
|
Posted by: SierraKen - 08-20-2022, 06:28 PM - Forum: Programs
- Replies (3)
|
 |
Today I decided to work more with 3D animation. 
Code: (Select All) _Title "Anemometer Wind Gauge by SierraKen"
Screen _NewImage(800, 600, 32)
t = 900
t2 = 1350
t3 = 1800
cc = 200
Do
_Limit 30
If t < 90 Then t = 900
If t2 < 135 Then t2 = 1350
If t3 < 180 Then t3 = 1800
x = (Sin(t) * 20) * (_Pi * 2) + 400
y = (Cos(t) * 10) * (_Pi / 2) + 200
r = (Cos(t) * 180) / _Pi / 1.5 + 50
t = t - .25
x2 = (Sin(t2) * 20) * (_Pi * 2) + 400
y2 = (Cos(t2) * 10) * (_Pi / 2) + 200
r2 = (Cos(t2) * 180) / _Pi / 1.5 + 50
t2 = t2 - .25
x3 = (Sin(t3) * 20) * (_Pi * 2) + 400
y3 = (Cos(t3) * 10) * (_Pi / 2) + 200
r3 = (Cos(t3) * 180) / _Pi / 1.5 + 50
t3 = t3 - .25
For S = .25 To r Step .1
cc = cc - .25
Circle (x, y), S, _RGB32(cc, cc, 100 + cc)
Next S
cc = 200
For S = .25 To r2 Step .1
cc = cc - .25
Circle (x2, y2), S, _RGB32(cc, 100 + cc, cc)
Next S
cc = 200
For S = .25 To r3 Step .1
cc = cc - .25
Circle (x3, y3), S, _RGB32(100 + cc, cc, cc)
Next S
cc = 200
Line (400, 200)-(x, y), _RGB32(255, 255, 255)
Line (400, 200)-(x2, y2), _RGB32(255, 255, 255)
Line (400, 200)-(x3, y3), _RGB32(255, 255, 255)
cc2 = 100
For sz = .1 To 100 Step .25
cc2 = cc2 - .25
Circle (400, 450), sz, _RGB32(100 + cc2, 100 + cc2, cc2), , , .5
Next sz
Line (400, 200)-(400, 450), _RGB32(255, 255, 255)
_Display
Cls
Loop
|
|
|
| Converting a MIDI file to text (csv, tab-delimited, etc.) and back again? |
|
Posted by: madscijr - 08-19-2022, 10:54 PM - Forum: General Discussion
- Replies (4)
|
 |
I could see these being a couple useful routines, and I even had (have? somewhere?) a couple ancient DOS EXEs that do it, but no source code and they may not work under modern Windows. If anyone has done this in QuickBasic or VB or a non-OO language like C, and would share your code, or even any experience with this, I would be willing to give it the old college try! :-D
|
|
|
|
| String Math (Add and Subtract) |
|
Posted by: SMcNeill - 08-19-2022, 06:25 PM - Forum: SMcNeill
- No Replies
|
 |
Code: (Select All) Screen _NewImage(1280, 720, 32)
a$ = "-10000000000000000000123.256"
b$ = " 60000000000000000000000.111"
Test a$, b$
a$ = " 100000000000000000000000000"
b$ = "-000000000000000000000000001.1"
Test a$, b$
a$ = "24123538548354853499345235498325489235982355952936529659265982635982398569.56466456"
b$ = "3.1"
Test a$, b$
Sub Test (a$, b$)
Print "==========================================================================="
Print a$
Print b$
Print "STEVE+:"; StringAdd(a$, b$)
Print "BTEN +:"; BTen$(a$, "+", b$)
Print "STEVE-:"; StringSubtract(a$, b$)
Print "BTEN -:"; BTen$(a$, "-", b$)
Print "==========================================================================="
Sleep
End Sub
Function StringAdd$ (tempa$, tempb$)
a$ = tempa$: b$ = tempb$ 'don't alter our original numbers
Dim As _Unsigned _Integer64 a, b, c, carryover 'to hold our values
'first fix the numbers to notmalize their lengths
FixNumbers a$, b$
'find the signs and strip them off
If Left$(a$, 1) = "-" Then sa$ = "-": a$ = Mid$(a$, 2) Else sa$ = " "
If Left$(b$, 1) = "-" Then sb$ = "-": b$ = Mid$(b$, 2) Else sb$ = " "
'find the decimal position
dp = InStr(a$, ".")
If dp > 0 Then 'remove the decimal place from our numbers. We can put it back later, in its proper position
righta$ = Mid$(a$, dp + 1)
rightb$ = Mid$(b$, dp + 1)
a$ = Left$(a$, dp - 1) + righta$
b$ = Left$(b$, dp - 1) + rightb$
End If
'our strings are now nothing but numbers with no signs and no decimals to deal with. Let's start adding!
'are we adding or really subtracting?
If sa$ <> sb$ Then 'we're subtracting the two values if the signs aren't the same.
Select Case a$
Case Is < b$: s$ = sb$: Swap a$, b$ 'our sign is going to be determiined by b$
Case Is = b$ 'if the two values are the same and are subtracting, our result is zero!
StringAdd$ = "0" 'How easy was that?
Exit Function
Case Else: s$ = sa$ 'our sign is determined by a$
End Select
Do
lb = Len(b$)
a = Val(Right$(a$, 18)): a$ = Left$(a$, Len(a$) - 18)
b = Val(Right$(b$, 18)): b$ = Left$(b$, Len(b$) - 18)
If borrow Then b = b + 1~&& 'in case we had to borrow a digit for the last subtraction
If a < b Then
If lb < 18 Then a = a + 10 ^ lb Else a = a + 10 ^ 18
borrow = -1
Else
borrow = 0
End If
c = a - b
temp$ = _Trim$(Str$(c))
answer$ = String$(18 - Len(temp$), "0") + temp$ + answer$
Loop Until Len(a$) = 0
'remove leading 0's
Do Until Left$(answer$, 1) <> "0"
answer$ = Mid$(answer$, 2)
Loop
'remember to add in the decimal place before finished
dp = Len(righta$)
If dp > 0 Then
answer$ = Left$(answer$, Len(answer$) - dp) + "." + Right$(answer$, dp)
End If
StringAdd$ = s$ + answer$
Exit Function
End If
Do
a1$ = Right$(a$, 18)
b1$ = Right$(b$, 18)
a = Val(Right$(a$, 18)): a$ = Left$(a$, Len(a$) - 18)
b = Val(Right$(b$, 18)): b$ = Left$(b$, Len(b$) - 18)
c = a + b + carryover
temp$ = _Trim$(Str$(c))
If Len(temp$) > 18 Then 'see if we have an answer that is more than 18 digits
temp$ = Right$(temp$, 18) 'keep 18 digits
carryover = 1 'store one for carry over
Else
carryover = 0 'no carryover
End If
answer$ = String$(18 - Len(temp$), "0") + temp$ + answer$
Loop Until Len(a$) = 0
If carryover Then answer$ = "1" + answer$
'remember to add in the decimal place before finished
dp = Len(righta$)
If dp > 0 Then
answer$ = Left$(answer$, Len(answer$) - dp) + "." + Right$(answer$, dp)
End If
'remove leading 0's
Do Until Left$(answer$, 1) <> "0"
answer$ = Mid$(answer$, 2)
Loop
StringAdd$ = sa$ + answer$
End Function
Function StringSubtract$ (tempa$, tempb$)
a$ = tempa$: b$ = tempb$
FixNumbers a$, b$
If Left$(b$, 1) = "-" Then b$ = Mid$(b$, 2) Else b$ = "-" + b$
StringSubtract$ = StringAdd$(a$, b$)
End Function
Sub FixNumbers (a$, b$)
'first remove scientific notation and spaces from both
a$ = _Trim$(N2S$(a$)): b$ = _Trim$(N2S$(b$))
'then find the decimal position for both and normalize the expressions
d1 = InStr(a$, "."): d2 = InStr(b$, ".")
If d1 <> 0 Then 'break down the left and right side of the decimal point for ease of processing (this is a$)
lefta$ = Left$(a$, d1 - 1)
righta$ = Mid$(a$, d1)
Else
lefta$ = a$
End If
If d2 <> 0 Then 'break down the left and right side of the decimal point for ease of processing (this is b$)
leftb$ = Left$(b$, d2 - 1)
rightb$ = Mid$(b$, d2)
Else
leftb$ = b$
End If
'normalize the right side of our expressions
l1 = Len(righta$): l2 = Len(rightb$)
If l1 < l2 Then
addzero = l2 - l1
If l1 = 0 Then righta$ = ".": addzero = addzero - 1
righta$ = righta$ + String$(addzero, "0")
ElseIf l1 > l2 Then
addzero = l1 - l2
'If l2 = 0 Then rightb$ = ".": addzero = addzero - 1
rightb$ = rightb$ + String$(addzero, "0")
End If
'strip off any plus/minus signs from the two numbers.
If Left$(lefta$, 1) = "-" Then signa$ = "-": lefta$ = Mid$(lefta$, 2)
If Left$(leftb$, 1) = "-" Then signb$ = "-": leftb$ = Mid$(leftb$, 2)
If Left$(lefta$, 1) = "+" Then signa$ = "": lefta$ = Mid$(lefta$, 2)
If Left$(leftb$, 1) = "+" Then signb$ = "": leftb$ = Mid$(leftb$, 2)
'normalize the left side of our expressions
l1 = Len(lefta$): l2 = Len(leftb$)
If l1 < l2 Then
addzero = l2 - l1
lefta$ = String$(addzero, "0") + lefta$
ElseIf l1 > l2 Then
addzero = l1 - l2
leftb$ = String$(addzero, "0") + leftb$
End If
'and then put it all together
a$ = signa$ + lefta$ + righta$
b$ = signb$ + leftb$ + rightb$
End Sub
Function N2S$ (exp$) 'scientific Notation to String
t$ = LTrim$(RTrim$(exp$))
If Left$(t$, 1) = "-" Or Left$(t$, 1) = "N" Then sign$ = "-": t$ = Mid$(t$, 2)
dp = InStr(t$, "D+"): dm = InStr(t$, "D-")
ep = InStr(t$, "E+"): em = InStr(t$, "E-")
check1 = Sgn(dp) + Sgn(dm) + Sgn(ep) + Sgn(em)
If check1 < 1 Or check1 > 1 Then N2S = exp$: Exit Function 'If no scientic notation is found, or if we find more than 1 type, it's not SN!
Select Case l 'l now tells us where the SN starts at.
Case Is < dp: l = dp
Case Is < dm: l = dm
Case Is < ep: l = ep
Case Is < em: l = em
End Select
l$ = Left$(t$, l - 1) 'The left of the SN
r$ = Mid$(t$, l + 1): r&& = Val(r$) 'The right of the SN, turned into a workable long
If InStr(l$, ".") Then 'Location of the decimal, if any
If r&& > 0 Then
r&& = r&& - Len(l$) + 2
Else
r&& = r&& + 1
End If
l$ = Left$(l$, 1) + Mid$(l$, 3)
End If
Select Case r&&
Case 0 'what the heck? We solved it already?
'l$ = l$
Case Is < 0
For i = 1 To -r&&
l$ = "0" + l$
Next
l$ = "0." + l$
Case Else
For i = 1 To r&&
l$ = l$ + "0"
Next
End Select
N2S$ = sign$ + l$
End Function
Function DWD$ (exp$) 'Deal With Duplicates
'To deal with duplicate operators in our code.
'Such as -- becomes a +
'++ becomes a +
'+- becomes a -
'-+ becomes a -
t$ = exp$
Do
bad = 0
Do
l = InStr(t$, "++")
If l Then t$ = Left$(t$, l - 1) + "+" + Mid$(t$, l + 2): bad = -1
Loop Until l = 0
Do
l = InStr(t$, "+-")
If l Then t$ = Left$(t$, l - 1) + "-" + Mid$(t$, l + 2): bad = -1
Loop Until l = 0
Do
l = InStr(t$, "-+")
If l Then t$ = Left$(t$, l - 1) + "-" + Mid$(t$, l + 2): bad = -1
Loop Until l = 0
Do
l = InStr(t$, "--")
If l Then t$ = Left$(t$, l - 1) + "+" + Mid$(t$, l + 2): bad = -1
Loop Until l = 0
Loop Until Not bad
DWD$ = t$
End Function
Function BTen$ (InTop As String, Op As String, InBot As String)
Rem $DYNAMIC
InTop = LTrim$(RTrim$(InTop))
InBot = LTrim$(RTrim$(InBot))
l = InStr(InTop, "-")
If l = 0 Then l = InStr(InTop, "+")
If l = 0 Then InTop = "+" + InTop
l = InStr(InBot, "-")
If l = 0 Then l = InStr(InBot, "+")
If l = 0 Then InBot = "+" + InBot
l = InStr(InTop, ".")
If l = 0 Then InTop = InTop + "."
l = InStr(InBot, ".")
If l = 0 Then InBot = InBot + "."
If Op$ = "-" Then
Op$ = "+"
If Mid$(InBot, 1, 1) = "-" Then Mid$(InBot, 1, 1) = "+" Else Mid$(InBot, 1, 1) = "-"
End If
TDP& = Check&(10, InTop$)
BDP& = Check&(10, InBot$)
If TDP& < 0 Or BDP& < 0 Then Exit Function
TSign% = Check&(11, InTop$)
BSign% = Check&(11, InBot$)
' Calculate Array Size
If Op$ = Chr$(43) Or Op$ = Chr$(45) Then
' "+" (Add) OR "-" (Subtract)
Temp& = 9
ElseIf Op$ = Chr$(42) Or Op$ = Chr$(50) Then
' "*" (Multiply) OR "2" (SQRT Multiply)
Temp& = 7
Else
Exit Function
End If
' LSA (Left Side of Array)
LSA& = TDP& - 2
TLS& = LSA& \ Temp&
If LSA& Mod Temp& > 0 Then
TLS& = TLS& + 1
Do While (TLPad& + LSA&) Mod Temp& > 0
TLPad& = TLPad& + 1
Loop
End If
LSA& = BDP& - 2
BLS& = LSA& \ Temp&
If LSA& Mod Temp& > 0 Then
BLS& = BLS& + 1
Do While (BLPad& + LSA&) Mod Temp& > 0
BLPad& = BLPad& + 1
Loop
End If
If TLS& >= BLS& Then LSA& = TLS& Else LSA& = BLS&
' RSA (Right Side of Array)
RSA& = Len(InTop$) - TDP&
TRS& = RSA& \ Temp&
If RSA& Mod Temp& > 0 Then
TRS& = TRS& + 1
Do While (TRPad& + RSA&) Mod Temp& > 0
TRPad& = TRPad& + 1
Loop
End If
RSA& = Len(InBot$) - BDP&
BRS& = RSA& \ Temp&
If RSA& Mod Temp& > 0 Then
BRS& = BRS& + 1
Do While (BRPad& + RSA&) Mod Temp& > 0
BRPad& = BRPad& + 1
Loop
End If
If TRS& >= BRS& Then RSA& = TRS& Else RSA& = BRS&
If Op$ = Chr$(43) Or Op$ = Chr$(45) Then
' "+" (Add) OR "-" (Subtract)
Dim Result(1 To (LSA& + RSA&)) As Long
If (Op$ = Chr$(43) And TSign% = BSign%) Or (Op$ = Chr$(45) And TSign% <> BSign%) Then
' Add Absolute Values and Return Top Sign
' Left Side
For I& = 1 To LSA&
' Top
If I& <= (LSA& - TLS&) Then
''' Result(I&) = Result(I&) + 0
ElseIf I& = (1 + LSA& - TLS&) Then
Result(I&) = Val(Mid$(InTop$, 2, (9 - TLPad&)))
TDP& = 11 - TLPad&
Else
Result(I&) = Val(Mid$(InTop$, TDP&, 9))
TDP& = TDP& + 9
End If
' Bottom
If I& <= (LSA& - BLS&) Then
''' Result(I&) = Result(I&) + 0
ElseIf I& = (1 + LSA& - BLS&) Then
Result(I&) = Result(I&) + Val(Mid$(InBot$, 2, (9 - BLPad&)))
BDP& = 11 - BLPad&
Else
Result(I&) = Result(I&) + Val(Mid$(InBot$, BDP&, 9))
BDP& = BDP& + 9
End If
Next I&
' Right Side
TDP& = TDP& + 1: BDP& = BDP& + 1
For I& = (LSA& + 1) To (LSA& + RSA&)
' Top
If I& > (LSA& + TRS&) Then
''' Result(I&) = Result(I&) + 0
ElseIf I& = (LSA& + TRS&) Then
Result(I&) = (10 ^ TRPad&) * Val(Right$(InTop$, (9 - TRPad&)))
Else
Result(I&) = Val(Mid$(InTop$, TDP&, 9))
TDP& = TDP& + 9
End If
' Bottom
If I& > (LSA& + BRS&) Then
''' Result(I&) = Result(I&) + 0
ElseIf I& = (LSA& + BRS&) Then
Result(I&) = Result(I&) + (10 ^ BRPad&) * Val(Right$(InBot$, (9 - BRPad&)))
Else
Result(I&) = Result(I&) + Val(Mid$(InBot$, BDP&, 9))
BDP& = BDP& + 9
End If
Next I&
' Carry
For I& = (LSA& + RSA&) To 2 Step -1
If Result(I&) >= 1000000000 Then
Result(I& - 1) = Result(I& - 1) + 1
Result(I&) = Result(I&) - 1000000000
End If
Next I&
' Return Sign
If TSign% = 1 Then RetStr$ = Chr$(43) Else RetStr$ = Chr$(45)
Else
' Compare Absolute Values
If TDP& > BDP& Then
Compare& = 1
ElseIf TDP& < BDP& Then
Compare& = -1
Else
If Len(InTop$) > Len(InBot$) Then Compare& = Len(InBot$) Else Compare& = Len(InTop$)
For I& = 2 To Compare&
If Val(Mid$(InTop$, I&, 1)) > Val(Mid$(InBot$, I&, 1)) Then
Compare& = 1
Exit For
ElseIf Val(Mid$(InTop$, I&, 1)) < Val(Mid$(InBot$, I&, 1)) Then
Compare& = -1
Exit For
End If
Next I&
If Compare& > 1 Then
If Len(InTop$) > Len(InBot$) Then
Compare& = 1
ElseIf Len(InTop$) < Len(InBot$) Then
Compare& = -1
Else
Compare& = 0
End If
End If
End If
' Conditional Subtraction
If Compare& = 1 Then
' Subtract Bottom from Top and Return Top Sign
' Top
Result(1) = Val(Mid$(InTop$, 2, (9 - TLPad&)))
TDP& = 11 - TLPad&
For I& = 2 To LSA&
Result(I&) = Val(Mid$(InTop$, TDP&, 9))
TDP& = TDP& + 9
Next I&
TDP& = TDP& + 1
For I& = (LSA& + 1) To (LSA& + TRS& - 1)
Result(I&) = Val(Mid$(InTop$, TDP&, 9))
TDP& = TDP& + 9
Next I&
Result(LSA& + TRS&) = 10& ^ TRPad& * Val(Right$(InTop$, (9 - TRPad&)))
' Bottom
BDP& = (Len(InBot$) - 17) + BRPad&
For I& = (LSA& + BRS&) To (1 + LSA& - BLS&) Step -1
If I& = LSA& Then BDP& = BDP& - 1
If I& = (LSA& + BRS&) Then
Temp& = (10& ^ BRPad&) * Val(Right$(InBot$, (9 - BRPad&)))
ElseIf I& = (1 + LSA& - BLS&) Then
Temp& = Val(Mid$(InBot$, 2, (9 - BLPad&)))
Else
Temp& = Val(Mid$(InBot$, BDP&, 9))
BDP& = BDP& - 9
End If
If Result(I&) < Temp& Then
' Borrow
For J& = (I& - 1) To 1 Step -1
If Result(J&) = 0 Then
Result(J&) = 999999999
Else
Result(J&) = Result(J&) - 1
Exit For
End If
Next J&
Result(I&) = Result(I&) + 1000000000
End If
Result(I&) = Result(I&) - Temp&
Next I&
' Return Sign
If TSign% = 1 Then RetStr$ = Chr$(43) Else RetStr$ = Chr$(45)
ElseIf Compare& = -1 Then
' Subtract Top from Bottom and Return Bottom Sign
' Bottom
Result(1) = Val(Mid$(InBot$, 2, (9 - BLPad&)))
BDP& = 11 - BLPad&
For I& = 2 To LSA&
Result(I&) = Val(Mid$(InBot$, BDP&, 9))
BDP& = BDP& + 9
Next I&
BDP& = BDP& + 1
For I& = (LSA& + 1) To (LSA& + BRS& - 1)
Result(I&) = Val(Mid$(InBot$, BDP&, 9))
BDP& = BDP& + 9
Next I&
Result(LSA& + BRS&) = 10& ^ BRPad& * Val(Right$(InBot$, (9 - BRPad&)))
' Top
TDP& = (Len(InTop$) - 17) + TRPad&
For I& = (LSA& + TRS&) To (1 + LSA& - TLS&) Step -1
If I& = LSA& Then TDP& = TDP& - 1
If I& = (LSA& + TRS&) Then
Temp& = (10& ^ TRPad&) * Val(Right$(InTop$, (9 - TRPad&)))
ElseIf I& = (1 + LSA& - TLS&) Then
Temp& = Val(Mid$(InTop$, 2, (9 - TLPad&)))
Else
Temp& = Val(Mid$(InTop$, TDP&, 9))
TDP& = TDP& - 9
End If
If Result(I&) < Temp& Then
' Borrow
For J& = (I& - 1) To 1 Step -1
If Result(J&) = 0 Then
Result(J&) = 999999999
Else
Result(J&) = Result(J&) - 1
Exit For
End If
Next J&
Result(I&) = Result(I&) + 1000000000
End If
Result(I&) = Result(I&) - Temp&
Next I&
' Build Return Sign
If BSign% = 1 Then RetStr$ = Chr$(43) Else RetStr$ = Chr$(45)
Else
' Result will always be 0
LSA& = 1: RSA& = 1
RetStr$ = Chr$(43)
End If
End If
' Generate Return String
RetStr$ = RetStr$ + LTrim$(Str$(Result(1)))
For I& = 2 To LSA&
RetStr$ = RetStr$ + Right$(String$(8, 48) + LTrim$(Str$(Result(I&))), 9)
Next I&
RetStr$ = RetStr$ + Chr$(46)
For I& = (LSA& + 1) To (LSA& + RSA&)
RetStr$ = RetStr$ + Right$(String$(8, 48) + LTrim$(Str$(Result(I&))), 9)
Next I&
Erase Result
ElseIf Op$ = Chr$(42) Then
' * (Multiply)
Dim TArray(1 To (LSA& + RSA&)) As Long
Dim BArray(1 To (LSA& + RSA&)) As Long
Dim ResDBL(0 To (LSA& + RSA&)) As Double
' Push String Data Into Array
For I& = 1 To LSA&
If I& <= (LSA& - TLS&) Then
''' TArray(I&) = TArray(I&) + 0
ElseIf I& = (1 + LSA& - TLS&) Then
TArray(I&) = Val(Mid$(InTop$, 2, (7 - TLPad&)))
TDP& = 9 - TLPad&
Else
TArray(I&) = Val(Mid$(InTop$, TDP&, 7))
TDP& = TDP& + 7
End If
If I& <= (LSA& - BLS&) Then
''' BArray(I&) = BArray(I&) + 0
ElseIf I& = (1 + LSA& - BLS&) Then
BArray(I&) = Val(Mid$(InBot$, 2, (7 - BLPad&)))
BDP& = 9 - BLPad&
Else
BArray(I&) = Val(Mid$(InBot$, BDP&, 7))
BDP& = BDP& + 7
End If
Next I&
TDP& = TDP& + 1: BDP& = BDP& + 1
For I& = (LSA& + 1) To (LSA& + RSA&)
If I& > (LSA& + TRS&) Then
''' TArray(I&) = TArray(I&) + 0
ElseIf I& = (LSA& + TRS&) Then
TArray(I&) = 10 ^ TRPad& * Val(Right$(InTop$, (7 - TRPad&)))
Else
TArray(I&) = Val(Mid$(InTop$, TDP&, 7))
TDP& = TDP& + 7
End If
If I& > (LSA& + BRS&) Then
''' BArray(I&) = BArray(I&) + 0
ElseIf I& = (LSA& + BRS&) Then
BArray(I&) = 10 ^ BRPad& * Val(Right$(InBot$, (7 - BRPad&)))
Else
BArray(I&) = Val(Mid$(InBot$, BDP&, 7))
BDP& = BDP& + 7
End If
Next I&
' Multiply from Arrays to Array
For I& = (LSA& + TRS&) To (1 + LSA& - TLS&) Step -1
For J& = (LSA& + BRS&) To (1 + LSA& - BLS&) Step -1
Temp# = 1# * TArray(I&) * BArray(J&)
If (I& + J&) Mod 2 = 0 Then
TL& = Int(Temp# / 10000000)
TR& = Temp# - 10000000# * TL&
ResDBL(((I& + J&) \ 2) - 1) = ResDBL(((I& + J&) \ 2) - 1) + TL&
ResDBL((I& + J&) \ 2) = ResDBL((I& + J&) \ 2) + 10000000# * TR&
Else
ResDBL((I& + J&) \ 2) = ResDBL((I& + J&) \ 2) + Temp#
End If
If ResDBL((I& + J&) \ 2) >= 100000000000000# Then
Temp# = ResDBL((I& + J&) \ 2)
TL& = Int(Temp# / 100000000000000#)
ResDBL(((I& + J&) \ 2) - 1) = ResDBL(((I& + J&) \ 2) - 1) + TL&
ResDBL((I& + J&) \ 2) = Temp# - 100000000000000# * TL&
End If
Next J&
Next I&
Erase TArray, BArray
' Generate Return String
If (TSign% * BSign%) = 1 Then RetStr$ = Chr$(43) Else RetStr$ = Chr$(45)
RetStr$ = RetStr$ + LTrim$(Str$(ResDBL(0)))
For I& = 1 To (LSA&)
RetStr$ = RetStr$ + Right$(String$(13, 48) + LTrim$(Str$(ResDBL(I&))), 14)
Next I&
RetStr$ = Left$(RetStr$, Len(RetStr$) - 7) + Chr$(46) + Right$(RetStr$, 7)
For I& = (LSA& + 1) To (LSA& + RSA&)
RetStr$ = RetStr$ + Right$(String$(13, 48) + LTrim$(Str$(ResDBL(I&))), 14)
Next I&
Erase ResDBL
ElseIf Op$ = Chr$(50) Then
' 2 (SQRT Multiply)
Dim IArray(1 To (LSA& + RSA&)) As Long
Dim ResDBL(0 To (LSA& + RSA&)) As Double
' Push String Data Into Array
For I& = 1 To LSA&
If I& <= (LSA& - TLS&) Then
''' IArray(I&) = IArray(I&) + 0
ElseIf I& = (1 + LSA& - TLS&) Then
IArray(I&) = Val(Mid$(InTop$, 2, (7 - TLPad&)))
TDP& = 9 - TLPad&
Else
IArray(I&) = Val(Mid$(InTop$, TDP&, 7))
TDP& = TDP& + 7
End If
Next I&
TDP& = TDP& + 1
For I& = (LSA& + 1) To (LSA& + RSA&)
If I& > (LSA& + TRS&) Then
''' IArray(I&) = IArray(I&) + 0
ElseIf I& = (LSA& + TRS&) Then
IArray(I&) = 10 ^ TRPad& * Val(Right$(InTop$, (7 - TRPad&)))
Else
IArray(I&) = Val(Mid$(InTop$, TDP&, 7))
TDP& = TDP& + 7
End If
Next I&
' SQRT Multiply from Array to Array
For I& = (LSA& + TRS&) To 1 Step -1
For J& = I& To 1 Step -1
Temp# = 1# * IArray(I&) * IArray(J&)
If I& <> J& Then Temp# = Temp# * 2
If (I& + J&) Mod 2 = 0 Then
TL& = Int(Temp# / 10000000)
TR& = Temp# - 10000000# * TL&
ResDBL(((I& + J&) \ 2) - 1) = ResDBL(((I& + J&) \ 2) - 1) + TL&
ResDBL((I& + J&) \ 2) = ResDBL((I& + J&) \ 2) + 10000000# * TR&
Else
ResDBL((I& + J&) \ 2) = ResDBL((I& + J&) \ 2) + Temp#
End If
If ResDBL((I& + J&) \ 2) >= 100000000000000# Then
Temp# = ResDBL((I& + J&) \ 2)
TL& = Int(Temp# / 100000000000000#)
ResDBL(((I& + J&) \ 2) - 1) = ResDBL(((I& + J&) \ 2) - 1) + TL&
ResDBL((I& + J&) \ 2) = Temp# - 100000000000000# * TL&
End If
Next J&
Next I&
Erase IArray
' Generate Return String
If (TSign% * BSign%) = 1 Then RetStr$ = Chr$(43) Else RetStr$ = Chr$(45)
RetStr$ = RetStr$ + LTrim$(Str$(ResDBL(0)))
For I& = 1 To (LSA&)
RetStr$ = RetStr$ + Right$(String$(13, 48) + LTrim$(Str$(ResDBL(I&))), 14)
Next I&
RetStr$ = Left$(RetStr$, Len(RetStr$) - 7) + Chr$(46) + Right$(RetStr$, 7)
' Don't usually want the full right side for this, just enough to check the
' actual result against the expected result, which is probably an integer.
' Uncomment the three lines below when trying to find an oddball square root.
'FOR I& = (LSA& + 1) TO (LSA& + RSA&)
' RetStr$ = RetStr$ + RIGHT$(STRING$(13, 48) + LTRIM$(STR$(ResDBL(I&))), 14)
'NEXT I&
Erase ResDBL
End If
' Trim Leading and Trailing Zeroes
Do While Mid$(RetStr$, 2, 1) = Chr$(48) And Mid$(RetStr$, 3, 1) <> Chr$(46)
RetStr$ = Left$(RetStr$, 1) + Right$(RetStr$, Len(RetStr$) - 2)
Loop
Do While Right$(RetStr$, 1) = Chr$(48) And Right$(RetStr$, 2) <> Chr$(46) + Chr$(48)
RetStr$ = Left$(RetStr$, Len(RetStr$) - 1)
Loop
If Mid$(RetStr$, 1, 1) = "+" Then Mid$(RetStr$, 1, 1) = " "
Do
r$ = Right$(RetStr$, 1)
If r$ = "0" Then RetStr$ = Left$(RetStr$, Len(RetStr$) - 1)
Loop Until r$ <> "0"
r$ = Right$(RetStr$, 1)
If r$ = "." Then RetStr$ = Left$(RetStr$, Len(RetStr$) - 1)
BTen$ = RetStr$
End Function
Rem $STATIC
' ---------------------------------------------------------------------------
' FUNCTION Check& (Op&, InString$) Multi-Purpose String Tester
' ---------------------------------------------------------------------------
'
' * Op& = Type of string to expect and/or operation to perform
'
' { 00A } = (10) Test Base-10-Format String ( *!* ALTERS InString$ *!* )
' { 00B } = (11) Read Sign ("+", "-", or CHR$(241))
'
' Unlisted values are not used and will return [ Check& = 0 - Op& ].
' Different Op& values produce various return values.
' Refer to the in-code comments for details.
'
' ---------------------------------------------------------------------------
' FUNCTION Check& (Op&, InString$) Multi-Purpose String Tester
' ---------------------------------------------------------------------------
Function Check& (Op As Long, InString As String)
Rem $DYNAMIC
RetVal& = Len(InString$)
Select Case Op&
Case 10
' {00A} Test String for Base-10-Format ( *!* ALTERS InString$ *!* )
' Returns:
' {& > 0} = DP offset; {& < 0} = FAILED at negative offset
'
' After testing passes, the string is trimmed
' of nonessential leading and trailing zeroes.
If RetVal& = 0 Then
RetVal& = -1
Else
Select Case Asc(Left$(InString$, 1))
Case 43, 45 ' "+", "-"
For I& = 2 To RetVal&
Select Case Asc(Mid$(InString$, I&, 1))
Case 46 ' "."
If DPC% > 0 Then
RetVal& = 0 - I&
Exit For
Else
DPC% = DPC% + 1
RetVal& = I&
End If
Case 48 To 57
' keep going
Case Else
RetVal& = 0 - I&
Exit For
End Select
Next I&
Case Else
RetVal& = -1
End Select
If DPC% = 0 And RetVal& > 0 Then
RetVal& = 0 - RetVal&
ElseIf RetVal& = 2 Then
InString$ = Left$(InString$, 1) + Chr$(48) + Right$(InString$, Len(InString$) - 1)
RetVal& = RetVal& + 1
End If
If RetVal& = Len(InString$) Then InString$ = InString$ + Chr$(48)
Do While Asc(Right$(InString$, 1)) = 48 And RetVal& < (Len(InString$) - 1)
InString$ = Left$(InString$, Len(InString$) - 1)
Loop
Do While Asc(Mid$(InString$, 2, 1)) = 48 And RetVal& > 3
InString$ = Left$(InString$, 1) + Right$(InString$, Len(InString$) - 2)
RetVal& = RetVal& - 1
Loop
End If
Case 11
' {00B} Read Sign ("+", "-", or CHR$(241))
' Returns:
' Explicit: +1 = Positive; -1 = Negative; 0 = Unsigned;
' Implied: +64 = Positive; -64 = NULL String
If RetVal& = 0 Then RetVal& = -64
For I& = 1 To RetVal&
Select Case Asc(Mid$(InString$, I&, 1))
Case 32
RetVal& = 64
' keep going
Case 43
RetVal& = 1
Exit For
Case 45
RetVal& = -1
Exit For
Case 241
RetVal& = 0
Exit For
Case Else
RetVal& = 64
Exit For
End Select
Next I&
Case Else
RetVal& = 0 - Op&
End Select
Check& = RetVal&
End Function
Code to plug in and use for string math. So far, I've only coded these for addition or subtraction, though the older BTEN$ also handles multiplication and SQRT. I figured I'd toss these up here as it seems nearly every programmer ends up writing a sting math routine at some point in their coding career, and these should be easy enough to plug into any other program and use as a comparison test to make certain that results match.
Of course, if results don't match, and the issue is somehow with my code here, feel free to mention it to me and I'll try and dig into the problem and sort it out. There's a lot of little tweaks which can toss string math off, so I wouldn't swear everything here is 100% bug-free, but it's got 2 different routines to compare against, if you need it. AFAIK, things work without issues, but I wouldn't swear to anything. After all, @Pete found a glitch earlier where my integer64 variables were trying to do floating point math, and I *never* would've expected that ! (Especially just to add 1 for carryover!!)
I reserve the right to always hide glitches somewhere in the code for... umm.... for... for learning experience! Yeah! There might be some in there for the learning experience! 
|
|
|
|
| palindrome with numbers |
|
Posted by: madscijr - 08-19-2022, 03:51 PM - Forum: Programs
- Replies (7)
|
|
Here's a neat little math factoid a coworker shared with us,
if you multiply 111,111,111 times 111,111,111
the answer is 12345678987654321 (reads the same backwards as forwards).
I got it working in QB64 with _INTEGER64, but a plain Excel formula does not yield the right answer!
Code: (Select All) Dim n1&&, n2&&, n3&&, n4&&
n1&& = 111111111
n2&& = n1&& * n1&&
Print " " + _Trim$(Str$(n1&&))
Print " x " + _Trim$(Str$(n1&&))
Print " -----------------"
Print " = " + _Trim$(Str$(n2&&))
Print
n3&& = 12345678987654321
n4&& = Sqr(n3&&)
Print "Sqr(" + _Trim$(Str$(n3&&)) + ")"
Print " = " + _Trim$(Str$(n4&&))
![[Image: math-tidbit-1.png]](https://i.ibb.co/3mfGy78/math-tidbit-1.png)
|
|
|
|
| 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://staging.qb64phoenix.com/showthre...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!"
|
|
|
|
|
