| 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
|
|
|
| module for the choice of options in programs |
|
Posted by: euklides - 08-13-2022, 03:02 PM - Forum: Programs
- Replies (3)
|
 |
A small module for the choice of options in your programs (key+mouse ok, but mouse wheel not in action here).
Code: (Select All) 'Optionator ' by Euklides
'A little selector of options in programs using mouse & key...
'----------------------------------------
' The menu of your program
'----------------------------------------
RESTART: Color 7, 0: Cls:
HVV = 8: Locate HVV - 1, 1: VID$ = " ": ima$ = ""
Color 0, 7: Print "{MENU} (choice with mouse or key)"
Color 14, 0: Print VID$; "0/ESC stop"
Print VID$; "1 Doing something interesting here"
Print VID$; "2 Here, come here "
Print VID$; "3 Start a game, for instance"
Print VID$; "4 Do you want something ?"
Print VID$; "5 Access to many options "
Print VID$; "6 and so on number 6"
Print VID$; "7 doing this or that !"
Print VID$; "8 and so on number 8"
Print VID$; "9 and so on number 9"
MousyComeOn: Color 7, 0: Locate 22, 1: Print String$(79, 32);
GoSub souriskey
'----------------------------------------
' Understanding your choice
'----------------------------------------
If clicko = 0 And z$ = "" Then GoTo MousyComeOn
If clicko = 0 Then numac = Val(z$): clicy = numac + HVV
If clicko > 0 Then numac = clicy - HVV
If human > 0 Then If z$ = Chr$(27) Then z$ = "0"
If numac < 0 Then Clear: GoTo RESTART
BB$ = "": For h = 1 To 75: BB$ = BB$ + Chr$(Screen(clicy, h)): Next h
BB$ = _Trim$(BB$): If BB$ = "" Then GoTo RESTART
Locate clicy, 1: Color 0, 5: Print VID$; BB$
If InStr(BB$, "{MENU}") > 0 Then GoTo RESTART:
showchoice: Locate 22, 1: Print BB$
'----------------------------------------
' Here you write your modules
'----------------------------------------
'choice: O/ESC stop
If Val(BB$) = 0 Or BB$ = "0/ESC stop" Then Cls: Print "Program stops now": Sleep: End
'case 1:
If Val(BB$) = 1 Or BB$ = "Doing something interesting here" Then
Print "Here please write your program...."
End If
'----------------------------------------
'And so on here...
'----------------------------------------
Sleep:
Stop
'----------------------------------------
' SP whith mouse or key working...
souriskey:
human = 0: clicko = 0: wheel = 0: OKDBLCLICK = 0
videx: If _MouseInput Then _Delay .01: GoTo videx
Souriskey2: z$ = InKey$: If z$ <> "" Then human = 1: Return
If _MouseInput Then
If Not _MouseWheel Then
xsouris = Int(_MouseX + .5): ysouris = Int(_MouseY + .5)
MOUVSOURI$ = Right$(Str$(ysouris + 100), 2) + "s" + Right$(Str$(xsouris + 100), 2)
If _MouseButton(1) Or _MouseButton(3) Then
clicko = 1: human = 3: clicx = xsouris: clicy = ysouris
'test double clic 6/10 seconde
If Timer - timsouris < .6 Then
If ysouris - msqv = NUMREPOsouris Then
If xsouris > BORDTABGAUCHE And xsouris < BORDTABDROIT And ysouris > BORDTABHAUT And ysouris < BORDTABBAS Then
OKDBLCLICK = 1
End If
End If
End If
timsouris = Timer: NUMREPOsouris = ysouris - msqv:
End If
End If
If _MouseWheel Then wheel = _MouseWheel: human = 3: clicko = 1
loopy: End If:
If human = 0 Then GoTo Souriskey2
Return
'----------------------------------------
|
|
|
Life |
|
Posted by: james2464 - 08-13-2022, 01:19 AM - Forum: Works in Progress
- Replies (23)
|
 |
Just tried to program the game of "Life" by John Conway (1970)
Fun project so far!
Code: (Select All) 'The game of Life
'Based on the 1970 game by John Conway
'James2464 Aug 2022
Screen _NewImage(1650, 1000, 32)
_ScreenMove 0, 0
Randomize Timer
$Resize:Off
Const pi = 3.1415926
Const xblack = _RGB32(0, 0, 0)
Const xwhite = _RGB32(255, 255, 255)
Const xred = _RGB32(255, 0, 0)
Const xgreen = _RGB32(125, 255, 125)
Const xblue = _RGB32(0, 0, 255)
Const xyellow = _RGB32(150, 125, 0)
Const xpink = _RGB32(255, 0, 255)
Const xcyan = _RGB32(0, 255, 255)
Const xbrown = _RGB32(80, 0, 0)
Const xdarkgreen = _RGB32(0, 128, 0)
Const xlightgray = _RGB32(110, 110, 110)
Const xdarkgray = _RGB32(10, 10, 10)
Dim c1#(100)
c1#(0) = xblack
c1#(1) = xwhite
c1#(2) = xred
c1#(3) = xgreen
c1#(4) = xblue
c1#(5) = xyellow
c1#(6) = xpink
c1#(7) = xcyan
c1#(8) = xbrown
c1#(9) = xdarkgreen
c1#(10) = xlightgray
c1#(11) = xdarkgray
'================================================================================================================
'================================================================================================================
'================================================================================================================
'INITIALIZE
Cls
Dim mn(1000, 800)
Dim dp(1000, 800)
Dim aj(1000, 800)
'grid size
gx = 400
gy = 235
'resolution (1=smallest)
res1 = 4
Cls
xtxt = 60
Locate 10, xtxt
Print "Select starting pattern"
Locate 11, xtxt
Print "1. Full screen random scatter"
Locate 12, xtxt
Print "2. Fixed pattern A"
Locate 13, xtxt
Print "3. Random pattern partial"
Locate 14, xtxt
Print "4. Manually draw using mouse pointer. Left click when finished."
Locate 15, xtxt
Print "5. Fixed pattern B"
Locate 20, xtxt
Input "Choose 1-5: ", start1
'start1 = 5
'=================== random full
If start1 = 1 Then
For j = 1 To gx
For k = 1 To gy
r = Int(Rnd * 10)
If r < 3 Then
mn(j, k) = 1
Else
mn(j, k) = 0
End If
Next k
Next j
End If
'=============================== fixed pattern
If start1 = 2 Then
gx = 400
gy = 235
res1 = 4
For j = 105 To 300 Step 12
For k = 80 To 160
mn(j, k) = 1
Next k
Next j
For j = 1 To gx
For k = 1 To gy
If mn(j, k) <> 1 Then
mn(j, k) = 0
End If
Next k
Next j
End If
'=============================== random partial
If start1 = 3 Then
For j = 1 To gx
For k = 1 To gy
mn(j, k) = 0
Next k
Next j
For j = 40 To gx Step 1
tt = Int(gy / 2)
t = Int(Rnd * tt) + 40
For k = 10 To t
mn(j, k) = 1
Next k
Next j
End If
'================================draw with mouse pointer
If start1 = 4 Then
'use mouse to draw starting pattern
'draw STARTING GRID
For j = 1 To gx
For k = 1 To gy
Line (j * res1, k * res1)-(j * res1 + res1, k * res1 + res1), c1#(mn(j, k)), BF
Next k
Next j
Do
Do While _MouseInput
Loop
x% = _MouseX
y% = _MouseY
'Locate 1, 1
'Print x%, y%
x1 = Int(x% / res1)
y1 = Int(y% / res1)
mn(x1, y1) = 1
'mn(x1 - 1, y1 - 1) = 1
'mn(x1 + 1, y1 - 1) = 1
'mn(x1 + 1, y1 + 1) = 1
'mn(x1, y1 + 1) = 1
'mn(x1 + 1, y1) = 1
'mn(x1, y1 - 1) = 1
'draw GRID
For j = 1 To gx
For k = 1 To gy
Line (j * res1, k * res1)-(j * res1 + res1, k * res1 + res1), c1#(mn(j, k)), BF
Next k
Next j
lc% = _MouseButton(1)
Loop Until lc% = -1
End If
'=============================== fixed pattern - lines
If start1 = 5 Then
For k = 110 To gy - 80 Step 25
For j = 80 To gx - 80
mn(j, k) = 1
Next j
Next k
End If
'================================================================================================================
'================================================================================================================
'================================================================================================================
Cls
Locate 10, xtxt
Print "Press space bar to show starting pattern."
Locate 15, xtxt
Print "Then press space bar again to start algorithm."
Locate 16, xtxt
Print "While running, press 't' to toggle to thermal cam view."
Do While InKey$ = ""
Loop
'draw STARTING GRID
For j = 1 To gx
For k = 1 To gy
Line (j * res1, k * res1)-(j * res1 + res1, k * res1 + res1), c1#(mn(j, k)), BF
Next k
Next j
Do While InKey$ = ""
Loop
'================================================================================================================
'================================================================================================================
'================================================================================================================
flag1 = 0
Do While flag1 = 0
'BEGIN
'COPY ARRAY
For j = 1 To gx
For k = 1 To gy
dp(j, k) = mn(j, k)
Next k
Next j
'================ SCAN FIRST ROW =============================
'top left corner
aj(1, 1) = dp(1, 2) + dp(2, 1) + dp(2, 2)
'main portion of top row
For j = 2 To gx - 1
aj(j, 1) = dp(j - 1, 1) + dp(j + 1, 1) + dp(j - 1, 2) + dp(j, 2) + dp(j + 1, 2)
Next j
'top right corner
aj(gx, 1) = dp(gx - 1, 1) + dp(gx - 1, 2) + dp(gx, 2)
'=============SCAN SECOND TO SECOND LAST ROW=================
For k = 2 To gy - 1
'scan first position only
aj(1, k) = dp(1, k - 1) + dp(2, k - 1) + dp(2, k) + dp(2, k + 1) + dp(1, k + 1)
'scan main portion of current row
For j = 2 To gx - 1
aj(j, k) = dp(j - 1, k - 1) + dp(j, k - 1) + dp(j + 1, k - 1) + dp(j - 1, k) + dp(j + 1, k) + dp(j - 1, k + 1) + dp(j, k + 1) + dp(j + 1, k + 1)
Next j
'scan end position only
aj(gx, k) = dp(gx, k - 1) + dp(gx - 1, k - 1) + dp(gx - 1, k) + dp(gx - 1, k + 1) + dp(gx, k + 1)
Next k
'======================SCAN LAST ROW=======================
'bottom left corner
aj(1, gy) = dp(1, gy - 1) + dp(2, gy - 1) + dp(2, gy)
'main portion of last row
For j = 2 To gx - 1
aj(j, gy) = dp(j - 1, gy) + dp(j + 1, gy) + dp(j - 1, gy - 1) + dp(j, gy - 1) + dp(j + 1, gy - 1)
Next j
'bottom right corner
aj(gx, gy) = dp(gx - 1, gy) + dp(gx - 1, gy - 1) + dp(gx, gy - 1)
'=======================APPLY RULES AND UPDATE GRID========================
'rule 1 - if cell was dead and had exactly 3 neighbours, it becomes alive
'rule 2 - if cell was alive and had <2 or >3 neighbours, it becomes dead
For k = 1 To gy
For j = 1 To gx
If dp(j, k) = 0 Then
If aj(j, k) = 3 Then
mn(j, k) = 1
End If
End If
If dp(j, k) = 1 Then
If aj(j, k) < 2 Or aj(j, k) > 3 Then
mn(j, k) = 0
End If
End If
Next j
Next k
'=======================DRAW NEW UPDATED GRID=============================
For j = 1 To gx
For k = 1 To gy
If tog1 = 0 Then
Line (j * res1, k * res1)-(j * res1 + res1, k * res1 + res1), c1#(mn(j, k)), BF
Else
Line (j * res1, k * res1)-(j * res1 + res1, k * res1 + res1), c1#(aj(j, k)), BF
End If
Next k
Next j
If InKey$ = "t" Then tog1 = tog1 + 1
If InKey$ = "x" Then flag1 = 1
If tog1 > 1 Then tog1 = 0
Loop
|
|
|
|
| Scalable List |
|
Posted by: SMcNeill - 08-11-2022, 09:53 AM - Forum: Help Me!
- Replies (2)
|
 |
An example for the Discord channel. This isn't set up with a very intuitive interface, as I cobbled it together in all of about 10 minutes quick work. I doubt anyone will learn anything from this, without popping into discord and actually chatting with me in person so I can help walk through what we're doing and why in a life-time session. It's just easier to share code of this length here, than it is there, but it's easier there to actually discuss it in real time so I can answer questions and such as we go. My apologies to anyone who finds this confusing or a waste of time. ;D
Code: (Select All) Screen _NewImage(640, 640, 32)
$Color:32
ReDim Shared lists(5, 5, 0) As String * 10 'make a resizable list array
Dim Shared As Integer list2use, listcount 'track which list we're using, and how many we have
addDefaultLabels
Do
Cls
m = MBS 'mousebutton status
If m And 8 Then 'left mouse button clicked
X = (_MouseX - 4) \ 127: Y = (_MouseY - 4) \ 127 'in which box was the mouse butoon pressed?
If Y = 4 Then 'we're on the last row, which is always going to be my command row
Select Case X
Case 0 'home
list2use = 0
editMode = 0
Case 1 'edit item
editMode = -1
Case 2 'next list
list2use = list2use + 1
If list2use > listcount Then list2use = 0
editMode = 0
Case 3 'delete list
'not functional for this demo. LOL! I'm just trying to keep things simple..ish.
Case 4 'add list
ReformLists
listcount = listcount + 1
list2use = listcount
addDefaultLabels
editMode = 0
End Select
Else
If editMode Then
Color White, Red
Locate 1, 1: Input "Enter the name for the item you clicked on: "; temp$
lists(X, Y, list2use) = temp$
Color White, Black
editMode = 0
Else
Color White, Red
Locate 1, 1: Print "You clicked on: "; lists(X, Y, list2use)
Print "Which was item "; X; ","; Y; "in list"; list2use
Color White, Black
_Display
Sleep
End If
End If
End If
_Limit 30
DrawBoxes list2use
_Display
Loop Until _KeyDown(27)
Sleep
Sub ReformLists
Dim temp(10, 10, listcount + 1) As String * 10
For z = 0 To listcount
For x = 0 To 4
For y = 0 To 4
temp(x, y, z) = lists(x, y, z) 'make a copy of the old data
Next y, x, z
ReDim lists(x, y, listcount + 1) As String * 10 'notice we're making our lists array larger to hold the new information?
For z = 0 To listcount
For x = 0 To 4
For y = 0 To 4
lists(x, y, z) = temp(x, y, z) 'copy the old data back over
Next y, x, z
'We have to do things this way as REDIM _PRESERVE doesn't work across multi-dimensional arrays
End Sub
Sub addDefaultLabels
lists(4, 4, list2use) = "Add List"
lists(3, 4, list2use) = "Delete List"
lists(2, 4, list2use) = "Next List"
lists(1, 4, list2use) = "Edit Item"
lists(0, 4, list2use) = "Return Home"
End Sub
Sub DrawBoxes (list2use)
For x = 0 To 4
For y = 0 To 4
Line (x * 127 + 4, y * 127 + 4)-Step(120, 120), White, B
_PrintString (x * 127 + 20, y * 127 + 60), lists(x, y, list2use)
Next
Next
End Sub
Function MBS% 'Mouse Button Status
Static StartTimer As _Float
Static ButtonDown As Integer
Static ClickCount As Integer
Const ClickLimit## = 0.2 'Less than 1/4th of a second to down, up a key to count as a CLICK.
' Down longer counts as a HOLD event.
Shared Mouse_StartX, Mouse_StartY, Mouse_EndX, Mouse_EndY
While _MouseInput 'Remark out this block, if mouse main input/clear is going to be handled manually in main program.
Select Case Sgn(_MouseWheel)
Case 1: tempMBS = tempMBS Or 512
Case -1: tempMBS = tempMBS Or 1024
End Select
Wend
If _MouseButton(1) Then tempMBS = tempMBS Or 1
If _MouseButton(2) Then tempMBS = tempMBS Or 2
If _MouseButton(3) Then tempMBS = tempMBS Or 4
If StartTimer = 0 Then
If _MouseButton(1) Then 'If a button is pressed, start the timer to see what it does (click or hold)
ButtonDown = 1: StartTimer = Timer(0.01)
Mouse_StartX = _MouseX: Mouse_StartY = _MouseY
ElseIf _MouseButton(2) Then
ButtonDown = 2: StartTimer = Timer(0.01)
Mouse_StartX = _MouseX: Mouse_StartY = _MouseY
ElseIf _MouseButton(3) Then
ButtonDown = 3: StartTimer = Timer(0.01)
Mouse_StartX = _MouseX: Mouse_StartY = _MouseY
End If
Else
BD = ButtonDown Mod 3
If BD = 0 Then BD = 3
If Timer(0.01) - StartTimer <= ClickLimit Then 'Button was down, then up, within time limit. It's a click
If _MouseButton(BD) = 0 Then tempMBS = 4 * 2 ^ ButtonDown: ButtonDown = 0: StartTimer = 0
Else
If _MouseButton(BD) = 0 Then 'hold event has now ended
tempMBS = 0: ButtonDown = 0: StartTimer = 0
Mouse_EndX = _MouseX: Mouse_EndY = _MouseY
Else 'We've now started the hold event
tempMBS = tempMBS Or 32 * 2 ^ ButtonDown
End If
End If
End If
MBS = tempMBS
End Function
|
|
|
|
| Wordle Helper #2 |
|
Posted by: bplus - 08-10-2022, 09:06 PM - Forum: Programs
- Replies (2)
|
 |
Just had to see if there was a way to "cheat"!
There is this:
Code: (Select All) Option _Explicit
_Title "Wordle Helper v2" ' b+ 2022-08-09
' use yellow - where letter is NOT
' put in a loop to eliminate as play Wordle
Dim Shared green$, yellow$
Dim nope$, k$
Dim w$(1 To 3145), wLeft$(1 To 3145), bw$
Dim As Long topWL, i, j, flag, top
restart:
Open "5LW.txt" For Input As #1
For i = 1 To 3145
Input #1, w$(i)
Next
Close #1
top = 3145
topWL = 0
Do
' new round
Input " Enter 5 letters Green (* for non green) from newest round "; green$
Input "Enter 5 letters Yellow (* for non yellow) from newest round "; yellow$
Print "If letters appear as green or yellow then they are in word."
Input " Enter letters NOT in word (any length) from newest round "; nope$
For i = 1 To top ' eliminate words that have letters known not to be in word
flag = -1
For j = 1 To Len(nope$)
If InStr(w$(i), Mid$(nope$, j, 1)) Then flag = 0: Exit For
Next
If flag Then 'candidate
topWL = topWL + 1
wLeft$(topWL) = w$(i)
End If
Next
Print "After nope$, number of words left are"; topWL
' now
top = topWL
topWL = 0
For i = 1 To top
w$(i) = wLeft$(i) ' put the words left back into w$()
Next
For i = 1 To top
If match&(w$(i), bw$) Then ' bw$ is the word to check with green matches removed
If m2&(bw$) Then ' check yellow matches
topWL = topWL + 1
wLeft$(topWL) = w$(i)
End If
End If
Next
' now
top = topWL
topWL = 0
For i = 1 To top
w$(i) = wLeft$(i) ' put the words left back into w$()
Next
Print "Word candidates:"; top
For i = 1 To top
Print w$(i); " ";
Next
Print
Print " ...ZZZ press space bar to continue round, x to start over, esc to quit"
While 1
k$ = InKey$
If Len(k$) Then
If Asc(k$) = 27 Then End
If k$ = " " Or k$ = "x" Then Exit While
End If
_Limit 30
Wend
If k$ = "x" Then GoTo restart
_KeyClear
Loop
Function match& (w2$, bw$) ' replace matching greenies with spaces in bw$ and use bw$ for checking yellow
Dim As Long i
bw$ = w2$
For i = 1 To 5
If Mid$(green$, i, 1) <> "*" Then
If Mid$(green$, i, 1) <> Mid$(w2$, i, 1) Then
Exit Function
Else
Mid$(bw$, i, 1) = " "
End If
End If
'else pass the word untouched as bw$
Next
match& = -1
End Function
Function m2& (w$)
Dim bw$, i As Long, p As Long
bw$ = w$
For i = 1 To 5
If Mid$(yellow$, i, 1) <> "*" Then ' there is a letter here we have to find in candidate words but not at i!
p = InStr(bw$, Mid$(yellow$, i, 1))
If p Then ' use the info if letter yellow at spot it is not word it would be green
If p <> i Then Mid$(bw$, p, 1) = " " Else Exit Function
Else ' no p means the letter is not in word so dont pass word
Exit Function
End If
End If
Next
m2& = -1
End Function
Does it work?
Well this was just luck!
This wasn't!
You can get the word file from my Wordle post, I probably renamed it but if it has 3145 5-letter words you're gold.
|
|
|
|
| keyup, keydown,slowkeydown |
|
Posted by: James D Jarvis - 08-10-2022, 09:04 PM - Forum: Utilities
- Replies (8)
|
 |
Three little functions to help in using _keyhit for user input.
keyup only returns the release of a key
keydown only returns key presses and doesn't return negative values when a key is released.
Slowkeydown throttles how quickly entries are returned while holding down a key.
Code: (Select All) _ControlChr Off
Print "press any key, <ESC> to exit"
Do
'edit the comments to see the differences in behavior
' k = keydown
k = keyup
' k = slowkeydown(5)
_KeyClear
Print k 'just the key hit value
If Abs(k) > 0 And Abs(k) < 256 Then Print Chr$(Abs(k)) 'show the ascii value of the key press if it has one
_Limit 60
Loop Until Abs(k) = 27
Function keyup
'only returns negative values when a key is released
'this will keep user from entering mutiple keypresses
Do
k = _KeyHit
_Limit 60
Loop Until k < 0
keyup = k
End Function
Function keydown
'only returns positive values when a key is pressed
Do
k = _KeyHit
_Limit 60
Loop Until k > 0
keydown = k
End Function
Function slowkeydown (r)
'returns positive vlaues when a key is pressed
'the variable r sets the frequency of the do loop , 60 would match the other functions here
'it wouldn't be slow at all if r had a high value but i didn't want to call it speedkeydown or ratekeydown
'this allows for continuous presses if a key is held down but not at machinegun rates
Do
k = _KeyHit
_Limit r
Loop Until k > 0
slowkeydown = k
End Function
|
|
|
|
| Perpetual string math calculator. |
|
Posted by: Pete - 08-10-2022, 05:11 PM - Forum: Works in Progress
- Replies (15)
|
 |
I've seen online calculators that do this:
1 / 3 * 3 = .999...
and this:
1 / 3 * 3 = 1
Obviously, the second one takes into account 1 / 3 as an infinite repetend. So I was wondering if there was some algorithm I could apply to properly round all repetend situations. Well, I punted on that concept, as to identify a repetend that goes over 10,000 digits before repeating the number sequence, simply takes too much calculation time. Not to mention how far can we go? After all, Pi is a transcendental number, so that could take an eternity... or an eternity and a half, if you're using FreeBASIC.
So, I decided to approach this problem by going old-school. Although decimals can never be depended on to divide and multiply back symmetrically, fractions can. So I designed a string math calculator system that works with numerators and denominators, but displays the results in decimal form.
This is roughed out, which means I did not put much thought into variable and line number names, tricks to speed it up, or extensive optimization. Goal #1 for me is to always get it working, and I think this is either close or does meet my first goal...
Code: (Select All) DIM SHARED betatest%
REM betatest% = -1
WIDTH 160, 42
_SCREENMOVE 0, 0
DIM SHARED operator$, stringmatha$, stringmathb$, runningtotal$, limit&&
start:
display_as&& = 15
limit&& = 100
DO
IF sa$ = "" OR LEN(op$) THEN
LINE INPUT "Number: "; n$
IF op$ = "" THEN
sa$ = n$
ELSE
sb$ = n$
GOSUB calculate
op$ = ""
END IF
ELSE
' Input operation.
PRINT "[+-*/]: ";
DO
_LIMIT 30
mykey$ = INKEY$
IF LEN(mykey$) THEN
SELECT CASE mykey$
CASE "+", "="
op$ = "+": EXIT DO
CASE "-", "_"
op$ = "-": EXIT DO
CASE "*", "8"
op$ = "*": EXIT DO
CASE "/", "?"
op$ = "/": EXIT DO
CASE "c", "C"
PRINT: PRINT "Total = 0": CLEAR: GOTO start
CASE CHR$(27)
SYSTEM
END SELECT
END IF
LOOP
PRINT op$
END IF
LOOP
calculate:
SELECT CASE op$
CASE "+", "-"
IF nator_a$ = "" THEN
nator_a$ = sa$: nator_b$ = sb$
dator_a$ = "1": dator_b$ = "1"
ELSE
nator_b$ = sb$: dator_b$ = "1"
END IF
IF INSTR(nator_a$, ".") THEN
n$ = nator_a$
GOSUB convert_to_fraction
nator_a$ = numerator$: dator_a$ = denominator$
END IF
IF INSTR(sb$, ".") THEN
n$ = sb$
GOSUB convert_to_fraction
nator_b$ = numerator$: dator_b$ = denominator$
ELSE
nator_b$ = sb$: dator_b$ = "1"
END IF
' Cross multiply
IF dator_a$ <> datorb$ THEN
stringmatha$ = nator_a$: stringmathb$ = dator_b$: operator$ = "*"
CALL string_math
a$ = runningtotal$
stringmatha$ = dator_a$: stringmathb$ = dator_b$: operator$ = "*"
CALL string_math
dator_c$ = runningtotal$ ' Common denominator.
stringmatha$ = nator_b$: stringmathb$ = dator_a$: operator$ = "*"
CALL string_math
b$ = runningtotal$
stringmatha$ = a$: stringmathb$ = b$: operator$ = op$
CALL string_math
nator_c$ = runningtotal$
END IF
CASE "*"
IF nator_a$ = "" THEN
nator_a$ = sa$: nator_b$ = sb$
dator_a$ = "1": dator_b$ = "1"
ELSE
nator_b$ = sb$: dator_b$ = "1"
END IF
IF INSTR(nator_a$, ".") THEN
n$ = nator_a$
GOSUB convert_to_fraction
nator_a$ = numerator$: dator_a$ = denominator$
END IF
IF INSTR(sb$, ".") THEN
n$ = sb$
GOSUB convert_to_fraction
nator_b$ = numerator$: dator_b$ = denominator$
ELSE
nator_b$ = sb$: dator_b$ = "1"
END IF
stringmatha$ = nator_a$: stringmathb$ = nator_b$: operator$ = "*"
CALL string_math
nator_c$ = runningtotal$
stringmatha$ = dator_a$: stringmathb$ = dator_b$: operator$ = "*"
CALL string_math
dator_c$ = runningtotal$
CASE "/"
IF nator_a$ = "" THEN
nator_a$ = sa$: nator_b$ = sb$
dator_a$ = "1": dator_b$ = "1"
ELSE
nator_b$ = sb$: dator_b$ = "1"
END IF
IF INSTR(nator_a$, ".") THEN
n$ = nator_a$
GOSUB convert_to_fraction
nator_a$ = numerator$: dator_a$ = denominator$
END IF
IF INSTR(sb$, ".") THEN
n$ = sb$
GOSUB convert_to_fraction
nator_b$ = numerator$: dator_b$ = denominator$
ELSE
nator_b$ = sb$: dator_b$ = "1"
END IF
SWAP nator_b$, dator_b$
stringmatha$ = nator_a$: stringmathb$ = nator_b$: operator$ = "*"
CALL string_math
nator_c$ = runningtotal$
stringmatha$ = dator_a$: stringmathb$ = dator_b$: operator$ = "*"
CALL string_math
dator_c$ = runningtotal$
END SELECT
IF betatest% THEN
PRINT "nator_a$: "; nator_a$
PRINT "dator_a$: "; dator_a$
PRINT "nator_b$: "; nator_b$
PRINT "dator_b$: "; dator_b$
PRINT "nator_c$: "; nator_c$
PRINT "dator_c$: "; dator_c$
END IF
a$ = nator_c$: b$ = dator_c$: GOSUB greatest_common_factor
nator_c$ = numerator$: dator_c$ = denominator$
stringmatha$ = nator_c$: stringmathb$ = dator_c$: operator$ = "/"
CALL string_math
sa$ = runningtotal$
COLOR 15, 0: PRINT:
IF LEFT$(sa$, 1) = "-" THEN PRINT "Total: "; sa$ ELSE PRINT "Total: "; sa$
COLOR 7, 0
nator_a$ = nator_c$
dator_a$ = dator_c$
IF betatest% THEN COLOR 2, 0: PRINT: PRINT "nator_a$ ="; nator_a$, "dator_a$ = "; dator_a$: PRINT: COLOR 7, 0
RETURN
'=================================================================================
convert_to_fraction:
i = 0: j = 0: k = 0: msg$ = ""
IF MID$(n$, 1, 1) = "-" THEN j = 3 ELSE j = 2 ' Look for negative sign.
x1$ = MID$(n$, 1, INSTR(n$, ".") - 1)
IF j = 3 THEN x1$ = MID$(x1$, 2)
x2$ = MID$(n$, INSTR(n$, ".") + 1)
b$ = "1" + STRING$(LEN(x2$), "0")
x1$ = x1$ + x2$
DO UNTIL LEFT$(x1$, 1) <> "0"
x1$ = MID$(x1$, 2) ' Strip off any leading zeros
LOOP
IF j = 2 THEN a$ = x1$ ELSE a$ = "-" + x1$
z$ = ""
IF betatest% THEN PRINT "numerator and denomintor: "; a$, b$
numerator$ = a$: denominator$ = b$
RETURN
greatest_common_factor:
' GFC algorithm. -------------------------------------------------------------
gfca$ = a$: gfcb$ = b$
IF betatest% THEN PRINT "PRE GFC "; a$; " / "; b$
' Make both numbers positive.
IF MID$(gfca$, 1, 1) = "-" THEN gfca$ = MID$(gfca$, 2)
IF MID$(gfcb$, 1, 1) = "-" THEN gfcb$ = MID$(gfcb$, 2)
' STRING MATH < or > EVAL NOT NEEDED AS NEG NUMBERS ARE CONVERTED TO POS AND NO CHANCE OF 0 AND < 1 > 0 LIKE 0 AND .1 OCCURRING.
IF gfca$ < gfcb$ THEN SWAP gfca$, gfcb$
' MOD operation in string math.
DO
stringmatha$ = gfca$: stringmathb$ = gfcb$
operator$ = "/": CALL string_math
m1$ = runningtotal$
IF INSTR(m1$, ".") THEN m1$ = MID$(m1$, 1, INSTR(m1$, ".") - 1)
stringmatha$ = m1$
stringmathb$ = gfcb$
operator$ = "*": CALL string_math
m2$ = runningtotal$
stringmatha$ = gfca$: stringmathb$ = m2$
operator$ = "-": CALL string_math
SWAP gfca$, gfcb$: gfcb$ = runningtotal$
IF runningtotal$ = "0" THEN EXIT DO
LOOP
stringmatha$ = a$: stringmathb$ = gfca$
operator$ = "/": CALL string_math
numerator$ = runningtotal$
stringmatha$ = b$: stringmathb$ = gfca$
operator$ = "/": CALL string_math
denominator$ = runningtotal$
IF betatest% THEN COLOR 14, 0: PRINT "GFC "; numerator$; " / "; denominator$: COLOR 7, 0
RETURN
'===============================================================================
SUB string_math
SELECT CASE operator$
CASE "+", "-"
GOTO string_add_subtract
CASE "*"
GOTO string_multiply
CASE "/"
GOTO string_divide
CASE ELSE
PRINT "Error, no operator selected. operator$ = "; operator$
END SELECT
string_divide:
divsign% = 0 '''''''''''''''
divremainder& = 0: divremainder$ = "": divplace& = 0 AND divplace2& = 0: quotient$ = "": divcarry& = 0
operationdivision% = -1
divbuffer& = LEN(stringmathb$) - LEN(stringmatha$)
IF divbuffer& < 0 THEN divbuffer& = 0
d2dividend$ = stringmatha$
d1divisor$ = stringmathb$
IF LEFT$(d1divisor$, 1) = "0" AND LEN(d1divisor$) = 1 THEN PRINT "Division by zero not allowed.": divsign% = 0: operationdivision% = 0: EXIT SUB: RETURN '*'
IF LEFT$(d1divisor$, 1) = "-" THEN divsign% = -1: d1divisor$ = MID$(d1divisor$, 2)
IF LEFT$(d2dividend$, 1) = "-" THEN
IF divsign% THEN
divsign% = 0
ELSE
divsign% = -1
END IF
d2dividend$ = MID$(d2dividend$, 2)
END IF
IF INSTR(d1divisor$, ".") <> 0 THEN
DO UNTIL RIGHT$(d1divisor$, 1) <> "0"
d1divisor$ = MID$(d1divisor$, 1, LEN(d1divisor$) - 1) ' Strip off trailing zeros
LOOP
divplace& = LEN(d1divisor$) - INSTR(d1divisor$, ".")
d1divisor$ = MID$(d1divisor$, 1, INSTR(d1divisor$, ".") - 1) + MID$(d1divisor$, INSTR(d1divisor$, ".") + 1) ' Strip off decimal point.
DO UNTIL LEFT$(d1divisor$, 1) <> "0"
d1divisor$ = MID$(d1divisor$, 2) ' Strip off leading zeros for divisors smaller than .1
LOOP
END IF
IF INSTR(d2dividend$, ".") <> 0 THEN
d2dividend$ = d2dividend$ + STRING$(divplace& - LEN(d2dividend$) - INSTR(d2dividend$, "."), "0") ' Add any zeros based on the length of dividend at decimal - length of divisor at decimal. If less than zero, nothing added.
divplace2& = INSTR(d2dividend$, ".")
DO UNTIL RIGHT$(d2dividend$, 1) <> "0"
d2dividend$ = MID$(d2dividend$, 1, LEN(d2dividend$) - 1) ' Strip off trailing zeros
LOOP
d2dividend$ = MID$(d2dividend$, 1, INSTR(d2dividend$, ".") - 1) + MID$(d2dividend$, INSTR(d2dividend$, ".") + 1) ' Strip off decimal point.
ELSE
d2dividend$ = d2dividend$ + STRING$(divplace&, "0") ' Add any zeros based on the length of dividend at decimal - length of divisor at decimal. If less than zero, nothing added.
divplace& = 0
END IF
DO
DO
divremainder& = divremainder& + 1: divremainder$ = divremainder$ + MID$(d2dividend$, divremainder&, 1)
IF MID$(d2dividend$, divremainder&, 1) = "" THEN
IF divremainder$ = STRING$(LEN(divremainder$), "0") AND LEN(quotient$) > LEN(d2dividend$) THEN divflag% = -1: EXIT DO
divcarry& = divcarry& + 1
IF divcarry& = 1 THEN divplace3& = divremainder& - 1
IF divcarry& > limit&& + 1 + divbuffer& THEN
divflag% = -2: EXIT DO
END IF
divremainder$ = divremainder$ + "0" ' No more digits to bring down.
END IF
IF LEN(divremainder$) > LEN(d1divisor$) OR LEN(divremainder$) = LEN(d1divisor$) AND divremainder$ >= d1divisor$ THEN EXIT DO
quotient$ = quotient$ + "0"
LOOP
IF divflag% THEN divflag% = 0: EXIT DO
FOR div_i% = 9 TO 1 STEP -1
stringmatha$ = LTRIM$(STR$(div_i%)): stringmathb$ = d1divisor$
m_product$ = "": GOSUB string_multiply
tempcutd$ = divremainder$ ' divremainder$ can be 00 or other leading zero values.
DO
IF LEN(tempcutd$) = 1 THEN EXIT DO
IF LEFT$(tempcutd$, 1) = "0" THEN
tempcutd$ = MID$(tempcutd$, 2)
ELSE
EXIT DO
END IF
LOOP
IF LEN(tempcutd$) > LEN(m_product$) OR LEN(tempcutd$) = LEN(m_product$) AND m_product$ <= tempcutd$ THEN EXIT FOR
NEXT
quotient$ = quotient$ + LTRIM$(STR$(div_i%))
stringmatha$ = LTRIM$(STR$(div_i%)): stringmathb$ = d1divisor$
m_product$ = "": GOSUB string_multiply
operator$ = "-"
stringmatha$ = divremainder$
stringmathb$ = m_product$
GOSUB string_add_subtract
divremainder$ = stringmatha$
operator$ = "/"
LOOP
IF divplace& = 0 AND divplace2& = 0 THEN divplace& = divplace3&
IF divplace2& THEN divplace& = divplace& + divplace2& - 1
IF quotient$ = "" THEN divplace& = 0 ' dividend is zero.
IF divplace& OR divplace2& THEN
quotient$ = MID$(quotient$, 1, divplace&) + "." + MID$(quotient$, divplace& + 1)
DO UNTIL RIGHT$(quotient$, 1) <> "0"
quotient$ = MID$(quotient$, 1, LEN(quotient$) - 1) ' Strip off trailing zeros
LOOP
IF RIGHT$(quotient$, 1) = "." THEN quotient$ = MID$(quotient$, 1, LEN(quotient$) - 1) ' Strip off abandoned decimal.
END IF
DO UNTIL LEFT$(quotient$, 1) <> "0"
quotient$ = MID$(quotient$, 2) ' Strip off leading zeros
LOOP
IF quotient$ = "" THEN quotient$ = "0": divsign% = 0
operationdivision% = 0
stringmathb$ = quotient$: quotient$ = ""
'''GOSUB limit_round_convert
IF stringmathb$ = "overflow" THEN divsign% = 0: operationdivision% = 0: EXIT SUB: RETURN '*'
'''GOSUB sm_converter
runningtotal$ = stringmathb$: stringmathb$ = ""
IF divsign% THEN runningtotal$ = "-" + runningtotal$
IF stringmathround$ <> "" THEN runningtotal$ = runningtotal$ + stringmathround$
operationdivision% = 0 '''''
EXIT SUB ''' or RETURN to select case if goto changed to gosub.
string_multiply:
m_decimal_places& = 0: m_product$ = "" ''''''''''''''''''''''
fac1$ = stringmatha$: fac2$ = stringmathb$ ' Make numbers whole numbers and remove any - sign.
IF LEFT$(fac1$, 1) = "-" THEN fac1$ = MID$(fac1$, 2): m_sign% = -1
IF LEFT$(fac2$, 1) = "-" THEN fac2$ = MID$(fac2$, 2): IF m_sign% THEN m_sign% = 0 ELSE m_sign% = -1
IF INSTR(fac1$, ".") <> 0 THEN m_decimal_places& = LEN(fac1$) - INSTR(fac1$, "."): fac1$ = MID$(fac1$, 1, INSTR(fac1$, ".") - 1) + MID$(fac1$, INSTR(fac1$, ".") + 1)
IF INSTR(fac2$, ".") <> 0 THEN m_decimal_places& = m_decimal_places& + LEN(fac2$) - INSTR(fac2$, "."): fac2$ = MID$(fac2$, 1, INSTR(fac2$, ".") - 1) + MID$(fac2$, INSTR(fac2$, ".") + 1)
FOR m_i& = LEN(fac2$) TO 1 STEP -1 ' Multiply each charter top and bottom.
m_k& = m_l&
m_x2$ = MID$(fac2$, m_i&, 1)
FOR m_j& = LEN(fac1$) TO 1 STEP -1
m_x1$ = MID$(fac1$, m_j&, 1)
IF m_product$ <> "" THEN
m_add$ = LTRIM$(STR$(VAL(m_x1$) * VAL(m_x2$))) + STRING$(m_k&, "0")
m_t& = 0: m_xproduct$ = "": m_carry% = 0
DO ' Add multiplied characters together.
m_x3$ = MID$(m_add$, LEN(m_add$) - m_t&, 1)
m_x4$ = MID$(m_product$, LEN(m_product$) - m_t&, 1)
IF m_x3$ = "" AND m_x4$ = "" THEN
IF m_carry% THEN m_xproduct$ = "1" + m_xproduct$
EXIT DO
END IF
m_g% = VAL(m_x3$) + VAL(m_x4$) + m_carry%
IF m_g% >= 10 THEN m_g% = m_g% - 10: m_carry% = 1 ELSE m_carry% = 0
m_xproduct$ = LTRIM$(STR$(m_g%)) + m_xproduct$
m_t& = m_t& + 1
LOOP
m_product$ = m_xproduct$: m_xproduct$ = ""
ELSE
m_product$ = LTRIM$(STR$(VAL(m_x1$) * VAL(m_x2$))) + STRING$(m_k&, "0") ' First loop makes variable here.
END IF
m_k& = m_k& + 1 ' Adds trailing zeros multiplication
NEXT
m_l& = m_l& + 1 ' Used to reset value for m_k& adding one trailing zer for each loop.
NEXT
fac1$ = "": fac2$ = "": m_l& = 0: m_k& = 0: m_t& = 0
IF m_decimal_places& > LEN(m_product$) THEN m_product$ = STRING$(m_decimal_places& - LEN(m_product$), "0") + m_product$ ' Add any leading zeros to a decimal. Ex: .02 * .01 is factored as 002. It needs one leading zero before adding the decimal point, .0002.
IF m_decimal_places& AND m_product$ <> "0" THEN ' Replace any decimal point.
m_product$ = MID$(m_product$, 1, LEN(m_product$) - m_decimal_places&) + "." + MID$(m_product$, LEN(m_product$) - m_decimal_places& + 1)
END IF
DO UNTIL LEFT$(m_product$, 1) <> "0" ' Remove leading zeros.
m_product$ = MID$(m_product$, 2)
LOOP
IF m_decimal_places& THEN
DO UNTIL RIGHT$(m_product$, 1) <> "0" ' Remove trailing zeros in a decimal sum.
m_product$ = MID$(m_product$, 1, LEN(m_product$) - 1)
LOOP
END IF
IF m_product$ = "" THEN m_product$ = "0": m_sign% = 0
IF RIGHT$(m_product$, 1) = "." THEN m_product$ = MID$(m_product$, 1, LEN(m_product$) - 1) ' Remove decimal from the end of an integer total.
IF operationdivision% THEN m_sign% = 0: RETURN
stringmathb$ = m_product$: m_product$ = ""
'''GOSUB limit_round_convert
IF stringmathb$ = "overflow" THEN EXIT SUB: RETURN '*'
'''GOSUB sm_converter
runningtotal$ = stringmathb$: stringmathb$ = ""
IF m_sign% THEN runningtotal$ = "-" + runningtotal$: m_sign% = 0
EXIT SUB ''' or RETURN to select case if goto changed to gosub.
string_add_subtract:
IF INSTR(stringmatha$, ".") <> 0 THEN ' Evaluate sum for decimal fraction.
sumplace& = LEN(stringmatha$) - INSTR(stringmatha$, ".")
stringmatha$ = MID$(stringmatha$, 1, INSTR(stringmatha$, ".") - 1) + MID$(stringmatha$, INSTR(stringmatha$, ".") + 1) ' Strip out decimal
END IF
IF INSTR(stringmathb$, ".") <> 0 THEN ' Evaluate number for decimal fraction.
numplace& = LEN(stringmathb$) - INSTR(stringmathb$, ".")
stringmathb$ = MID$(stringmathb$, 1, INSTR(stringmathb$, ".") - 1) + MID$(stringmathb$, INSTR(stringmathb$, ".") + 1) ' Strip out decimal
END IF
IF sumplace& > numplace& THEN addsubplace& = sumplace& ELSE addsubplace& = numplace&
IF sumplace& > addsubplace& THEN
stringmatha$ = stringmatha$ + STRING$(sumplace& - addsubplace&, "0")
ELSEIF addsubplace& > sumplace& THEN
stringmatha$ = stringmatha$ + STRING$(addsubplace& - sumplace&, "0")
END IF
IF numplace& > addsubplace& THEN
stringmathb$ = stringmathb$ + STRING$(numplace& - addsubplace&, "0")
ELSEIF addsubplace& > numplace& THEN
stringmathb$ = stringmathb$ + STRING$(addsubplace& - numplace&, "0")
END IF ' END Decimal evaluations.
IF LEFT$(stringmatha$, 1) = "-" THEN sign_input$ = "-" ELSE sign_input$ = "+"
IF LEFT$(stringmathb$, 1) = "-" THEN sign_total$ = "-" ELSE sign_total$ = "+"
addsubsign% = 0
SELECT CASE sign_input$ + operator$ + sign_total$
CASE "+++", "+--"
operator$ = "+"
IF LEFT$(stringmathb$, 1) = "-" THEN stringmathb$ = MID$(stringmathb$, 2)
CASE "++-", "+-+"
operator$ = "-"
IF LEFT$(stringmathb$, 1) = "-" THEN stringmathb$ = MID$(stringmathb$, 2)
IF VAL(stringmathb$) > VAL(stringmatha$) THEN SWAP stringmatha$, stringmathb$: addsubsign% = -1
CASE "---", "-++"
operator$ = "-"
IF LEFT$(stringmatha$, 1) = "-" THEN stringmatha$ = MID$(stringmatha$, 2)
IF LEFT$(stringmathb$, 1) = "-" THEN stringmathb$ = MID$(stringmathb$, 2)
IF VAL(stringmathb$) > VAL(stringmatha$) THEN SWAP stringmatha$, stringmathb$ ELSE addsubsign% = -1
CASE "--+", "-+-"
operator$ = "+"
IF LEFT$(stringmatha$, 1) = "-" THEN stringmatha$ = MID$(stringmatha$, 2)
IF LEFT$(stringmathb$, 1) = "-" THEN stringmathb$ = MID$(stringmathb$, 2)
addsubsign% = -1
END SELECT
IF LEN(stringmatha$) > LEN(stringmathb$) THEN
stringmathb$ = STRING$(LEN(stringmatha$) - LEN(stringmathb$), "0") + stringmathb$
ELSEIF LEN(stringmatha$) < LEN(stringmathb$) THEN
stringmatha$ = STRING$(LEN(stringmathb$) - LEN(stringmatha$), "0") + stringmatha$
END IF
addsubx1$ = ""
SELECT CASE operator$
CASE "+", "="
FOR addsubii& = LEN(stringmatha$) TO 1 STEP -1
addsubx1% = VAL(MID$(stringmatha$, addsubii&, 1)) + VAL(MID$(stringmathb$, addsubii&, 1)) + addsubcarry%
IF addsubx1% > 9 THEN addsubx1% = addsubx1% - 10: addsubcarry% = 1 ELSE addsubcarry% = 0
addsubx1$ = LTRIM$(STR$(addsubx1%)) + addsubx1$
NEXT
IF addsubcarry% THEN addsubx1$ = "1" + addsubx1$: addsubcarry% = 0
GOSUB replace_decimal
CASE "-"
FOR addsubii& = LEN(stringmatha$) TO 1 STEP -1
addsubx1% = VAL(MID$(stringmatha$, addsubii&, 1)) - VAL(MID$(stringmathb$, addsubii&, 1)) + addsubcarry%
IF addsubx1% < 0 THEN addsubx1% = addsubx1% + 10: addsubcarry% = -1 ELSE addsubcarry% = 0
addsubx1$ = LTRIM$(STR$(addsubx1%)) + addsubx1$
NEXT
IF addsubx1$ <> "" AND addsubx1$ <> STRING$(LEN(addsubx1$), "0") THEN GOSUB replace_decimal
DO UNTIL LEFT$(addsubx1$, 1) <> "0" ' Remove leading zeros.
addsubx1$ = MID$(addsubx1$, 2)
LOOP
IF addsubx1$ = "" THEN
addsubx1$ = "0": addsubsign% = 0
ELSE
IF addsubcarry% THEN addsubx1$ = "-" + addsubx1$: addsubcarry% = 0
END IF
END SELECT
IF addsubsign% THEN
IF LEFT$(addsubx1$, 1) = "-" THEN addsubx1$ = MID$(addsubx1$, 2) ELSE addsubx1$ = "-" + addsubx1$
END IF
stringmatha$ = addsubx1$: addsubx1$ = ""
IF operationdivision% THEN RETURN
stringmathb$ = stringmatha$: stringmatha$ = ""
IF LEFT$(stringmathb$, 1) = "-" THEN
stringmathb$ = MID$(stringmathb$, 2)
n2sign$ = "-"
ELSE
n2sign$ = ""
END IF
''' GOSUB limit_round_convert
IF stringmathb$ = "overflow" THEN n2sign$ = "": EXIT SUB: RETURN '*'
''' GOSUB sm_converter
runningtotal$ = n2sign$ + stringmathb$: n2sign$ = ""
EXIT SUB ''' or RETURN to select case if goto changed to gosub.
replace_decimal:
IF addsubplace& THEN
addsubx1$ = STRING$(addsubplace& - LEN(addsubx1$), "0") + addsubx1$
addsubx1$ = MID$(addsubx1$, 1, LEN(addsubx1$) - addsubplace&) + "." + MID$(addsubx1$, LEN(addsubx1$) - addsubplace& + 1)
DO UNTIL RIGHT$(addsubx1$, 1) <> "0" ' Remove trailing zeros in a decimal sum.
addsubx1$ = MID$(addsubx1$, 1, LEN(addsubx1$) - 1)
addsubplace& = addsubplace& - 1
LOOP
IF RIGHT$(addsubx1$, 1) = "." THEN addsubx1$ = MID$(addsubx1$, 1, LEN(addsubx1$) - 1) ' Number is now an integer.
END IF
RETURN
END SUB
Pete
|
|
|
|
| Map Explorer |
|
Posted by: SierraKen - 08-10-2022, 12:22 AM - Forum: Programs
- Replies (33)
|
 |
Today I wanted to make something I haven't made in awhile, a moving background map while you move your guy around. Except this time I wanted to see if I could do it without an already-made graphic file to use it with. So I figured out how to randomly generate a 3000 x 3000 graphic and save the file as a BMP picture file, which after loading and calculating, it deletes the 30 mb file (or so) that it makes. Feel free to add your own graphics to it. I added a lot of comments in the code. It was Felippe that originally posted how to make something like this probably around a year ago or 2. But I haven't seen much use of it. I used it with my Cave Fighter game awhile back, using the already made picture file. This one shows how to make each game or app have a randomly generated map each time you make it so it's different every time. This map generates random sized houses in different locations and round rocks. That's all I have for it so far so I might create a game with it or something later on. Feel free to do what you wish with it of course. Oh, I also made the guy move his arms and legs as he walks and he walks using the arrow keys. This isn't a game since there's nothing to achieve, but it's an example of how to make this. So when you are done just press Esc or the X.
Also, it would probably be best to put this in its own folder since it generates the explorer-map.bmp file and it automatically deletes it after it's done loading it. I got the BMP saving code from the Wiki pages and I added a couple of modification lines to it to show the timer in the Title Bar on how long it will take to finish loading (calculating) it before you can use it.
Note: I just noticed that it uses around 378 MB of RAM, just so you know.
Enjoy!
(Code deleted: Much better code a few pages from this post, without the extra .bmp file or loading time and much less memory RAM.)
|
|
|
|
|
