| 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
|
|
|
| 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://staging.qb64phoenix.com/showthre...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)
|
|
|
|
| Equation For Specific Line Length Needed |
|
Posted by: SierraKen - 08-16-2022, 12:53 AM - Forum: Help Me!
- Replies (17)
|
 |
Hi all,
I'm in the middle of making my Explorer game with scrolling maps. The game uses the mouse to use your sword with. But I'm stuck at what the equation is to make a limited line (sword) from your character toward the area you point your mouse at. I can easily make a line from your character to the mouse coordinates, but I can't make it a limited length. Does anyone out there know how to do this? I think I will keep the sword at 100 pixels long. Let's say the guy is XX by YY coordinates (never mind the scrolling map part, that should be easy to add). And let's say the mouse is using mouseX and mouseY. I just want the sword to reach toward that mouse point but only 100 pixels toward it and no more. Thanks.
|
|
|
|
| Just finished calculating pi to 30 trillion places. |
|
Posted by: Pete - 08-15-2022, 07:33 AM - Forum: General Discussion
- Replies (30)
|
 |
And guess what, it is a repetend at decimal place 14 trillion, 678 billion, 36!
Okay, so I may be exaggerating a little. In reality, I think pi has been calculated to around 10-trillion non-repeating places. Now what the super computers use for that, I haven't looked up. The old school method uses something like this...
1/1 - 1/3 + 1/5 - 1/7 + 1/9... pi/4
It took me a few hours using 750 iterations to get the 3.14 part finally right. I suspect it would take several thousand iterations to get to 3.14159. Anyway, it was a neat way to see how my string math routine would hold up. Below is what I used, but set to just 40 iterations to make the demo speed tolerable and only 150 places. It only gets as far as: 3.11659
Code: (Select All) DIM SHARED betatest%: betatest% = -1
WIDTH 160, 42
_SCREENMOVE 0, 0
limit&& = 500
j = -1
FOR i = 1 TO 40
j = j + 2
IF oldd$ = "" THEN
d$ = "1": oldd$ = "1": oldn$ = "1": n$ = "1"
ELSE
d$ = LTRIM$(STR$(j))
' 2nd denominator * 1st numerator.
a$ = d$: b$ = oldn$: op$ = "*"
CALL string_math(a$, op$, b$, x$, limit&&)
m1$ = x$
' 1st denominator * 2nd numerator.
a$ = oldd$: b$ = n$
CALL string_math(a$, op$, b$, x$, limit&&)
m2$ = x$
' Get common denominator
a$ = d$: b$ = oldd$
CALL string_math(a$, op$, b$, x$, limit&&)
d$ = x$
a$ = m1$: b$ = m2$: IF i / 2 = i \ 2 THEN op$ = "-" ELSE op$ = "+"
CALL string_math(a$, op$, b$, x$, limit&&)
REM PRINT "oldn$ = "; oldn$; " oldd$ = "; oldd$, "n$ = "; x$; " d$ = "; d$
PRINT "n$ = "; x$; " d$ = "; d$;: COLOR 14, 0: PRINT j: COLOR 7, 0
oldn$ = x$: oldd$ = d$
END IF
NEXT
REM CALL greatest_common_factor(x$, d$, limit&&) ' Too slow.
n$ = x$
a$ = x$: b$ = d$: op$ = "/"
' Speed up processing by liiting each calculated iteration t 16 places.
' Remove thiss condition to retain accuracy.
IF LEN(a$) > 16 THEN
j = LEN(a$)
k = LEN(b$)
i = j - k
a$ = MID$(a$, 1, 16 + i): b$ = MID$(b$, 1, 16)
END IF
CALL string_math(a$, op$, b$, x$, limit&&)
a$ = x$: b$ = "4": op$ = "*"
CALL string_math(a$, op$, b$, x$, limit&&)
PRINT: PRINT "pi = "; x$
END
SUB string_math (stringmatha$, operator$, stringmathb$, runningtotal$, limit&&)
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: 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
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$ = ""
IF stringmathb$ = "overflow" THEN divsign% = 0: operationdivision% = 0: EXIT SUB
runningtotal$ = stringmathb$: stringmathb$ = ""
IF divsign% THEN runningtotal$ = "-" + runningtotal$
IF stringmathround$ <> "" THEN runningtotal$ = runningtotal$ + stringmathround$
operationdivision% = 0
EXIT SUB
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 charater 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$ = ""
IF stringmathb$ = "overflow" THEN EXIT SUB
runningtotal$ = stringmathb$: stringmathb$ = ""
IF m_sign% THEN runningtotal$ = "-" + runningtotal$: m_sign% = 0
EXIT SUB
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)
GOSUB string_comp
IF gl% < 0 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)
GOSUB string_comp
IF gl% < 0 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)
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
IF stringmathb$ = "overflow" THEN n2sign$ = "": EXIT SUB
runningtotal$ = n2sign$ + stringmathb$: n2sign$ = ""
EXIT SUB
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
string_comp:
DO
REM Remove trailing zeros after a decimal point.
IF INSTR(acomp$, ".") THEN
DO UNTIL RIGHT$(acomp$, 1) <> "0" AND RIGHT$(acomp$, 1) <> "." AND RIGHT$(acomp$, 1) <> "-"
acomp$ = MID$(acomp$, 1, LEN(acomp$) - 1)
LOOP
END IF
IF INSTR(bcomp$, ".") THEN
DO UNTIL RIGHT$(bcomp$, 1) <> "0" AND RIGHT$(bcomp$, 1) <> "." AND RIGHT$(bcomp$, 1) <> "-"
bcomp$ = MID$(bcomp$, 1, LEN(bcomp$) - 1)
LOOP
END IF
IF MID$(acomp$, 1, 2) = "-0" OR acomp$ = "" OR acomp$ = "-" THEN acomp$ = "0"
IF MID$(bcomp$, 1, 2) = "-0" OR bcomp$ = "" OR bcomp$ = "-" THEN bcomp$ = "0"
' A - and +
IF LEFT$(acomp$, 1) = "-" THEN j% = -1
IF LEFT$(bcomp$, 1) = "-" THEN k% = -1
IF k% = 0 AND j% THEN gl% = -1: EXIT DO
IF j% = 0 AND k% THEN gl% = 1: EXIT DO
' A decimal and non-decimal.
j% = INSTR(acomp$, ".")
k% = INSTR(bcomp$, ".")
IF j% = 0 AND k% THEN
IF acomp$ = "0" THEN gl% = -1 ELSE gl% = 1
EXIT DO
END IF
IF k% = 0 AND j% THEN
IF bcomp$ = "0" THEN gl% = 1 ELSE gl% = -1
EXIT DO
END IF
' Both decimals.
IF j% THEN
IF acomp$ > bcomp$ THEN
gl% = 1
ELSEIF acomp$ = bcomp$ THEN gl% = 0
ELSEIF acomp$ < bcomp$ THEN gl% = -1
END IF
EXIT DO
END IF
' Both positive or both negative whole numbers.
SELECT CASE LEN(acomp$)
CASE IS < LEN(bcomp$)
gl% = -1
CASE IS = LEN(bcomp$)
IF acomp$ = bcomp$ THEN
gl% = 0
ELSEIF acomp$ > bcomp$ THEN gl% = 1
ELSEIF acomp$ < bcomp$ THEN gl% = -1
END IF
CASE IS > LEN(bcomp$)
gl% = 1
END SELECT
EXIT DO
LOOP
RETURN
END SUB
SUB greatest_common_factor (gfca$, gfcb$, limit&&)
hold_gfca$ = gfca$
hold_gfcb$ = gfcb$
numerator$ = gfca$: denominator$ = gfcb$
' Make both numbers positive.
IF MID$(gfca$, 1, 1) = "-" THEN gfca$ = MID$(gfca$, 2)
IF MID$(gfcb$, 1, 1) = "-" THEN gfcb$ = MID$(gfcb$, 2)
GOSUB string_comp
IF gl% THEN SWAP gfca$, gfcb$
DO
stringmatha$ = gfca$: stringmathb$ = gfcb$
operator$ = "/": CALL string_math(stringmatha$, operator$, stringmathb$, runningtotal$, limit&&)
IF INSTR(runningtotal$, ".") THEN runningtotal$ = MID$(runningtotal$, 1, INSTR(runningtotal$, ".") - 1)
stringmatha$ = runningtotal$: stringmathb$ = gfcb$
operator$ = "*": CALL string_math(stringmatha$, operator$, stringmathb$, runningtotal$, limit&&)
stringmatha$ = gfca$: stringmathb$ = runningtotal$
operator$ = "-": CALL string_math(stringmatha$, operator$, stringmathb$, runningtotal$, limit&&)
SWAP gfca$, gfcb$: gfcb$ = runningtotal$
IF runningtotal$ = "0" THEN EXIT DO
LOOP
stringmatha$ = numerator$: stringmathb$ = gfca$
operator$ = "/": CALL string_math(stringmatha$, operator$, stringmathb$, runningtotal$, limit&&)
numerator$ = runningtotal$
stringmatha$ = denominator$: stringmathb$ = gfca$
operator$ = "/": CALL string_math(stringmatha$, operator$, stringmathb$, runningtotal$, limit&&)
denominator$ = runningtotal$
IF betatest% THEN
PRINT "GFC = "; gfca$; ": Previous fraction: "; hold_gfca$; " / "; hold_gfcb$, "Reduced: "; numerator$; " / "; denominator$
END IF
gfca$ = numerator$: gfcb$ = denominator$
EXIT SUB
string_comp:
DO
REM Remove trailing zeros after a decimal point.
IF INSTR(a$, ".") THEN
DO UNTIL RIGHT$(a$, 1) <> "0" AND RIGHT$(a$, 1) <> "." AND RIGHT$(a$, 1) <> "-"
a$ = MID$(a$, 1, LEN(a$) - 1)
LOOP
END IF
IF INSTR(b$, ".") THEN
DO UNTIL RIGHT$(b$, 1) <> "0" AND RIGHT$(b$, 1) <> "." AND RIGHT$(b$, 1) <> "-"
b$ = MID$(b$, 1, LEN(b$) - 1)
LOOP
END IF
IF MID$(a$, 1, 2) = "-0" OR a$ = "" OR a$ = "-" THEN a$ = "0"
IF MID$(b$, 1, 2) = "-0" OR b$ = "" OR b$ = "-" THEN b$ = "0"
' A - and +
IF LEFT$(a$, 1) = "-" THEN j% = -1
IF LEFT$(b$, 1) = "-" THEN k% = -1
IF k% = 0 AND j% THEN gl% = -1: EXIT DO
IF j% = 0 AND k% THEN gl% = 1: EXIT DO
' A decimal and non-decimal.
j% = INSTR(a$, ".")
k% = INSTR(b$, ".")
IF j% = 0 AND k% THEN
IF a$ = "0" THEN gl% = -1 ELSE gl% = 1
EXIT DO
END IF
IF k% = 0 AND j% THEN
IF b$ = "0" THEN gl% = 1 ELSE gl% = -1
EXIT DO
END IF
' Both decimals.
IF j% THEN
IF a$ > b$ THEN
gl% = 1
ELSEIF a$ = b$ THEN gl% = 0
ELSEIF a$ < b$ THEN gl% = -1
END IF
EXIT DO
END IF
' Both positive or both negative whole numbers.
SELECT CASE LEN(a$)
CASE IS < LEN(b$)
gl% = -1
CASE IS = LEN(b$)
IF a$ = b$ THEN
gl% = 0
ELSEIF a$ > b$ THEN gl% = 1
ELSEIF a$ < b$ THEN gl% = -1
END IF
CASE IS > LEN(b$)
gl% = 1
END SELECT
EXIT DO
LOOP
RETURN
END SUB
The slowest part of the string math is division. It would be nice to find a way to divide with fewer steps.
Note: For more accuracy, increase the limit&& to 500 or more.
EDIT: Forgot to mention I put in condition to spped it up after 70 iteratins, but the trade off is loss of accuracy. Remove this condition if accuracy is desired over speed, but wow, after a few hundred loops the numbers get so large the calculations take a lot of time.
' Speed up processing by liiting each calculated iteration t 16 places.
' Remove thiss condition to retain accuracy.
IF LEN(a$) > 16 THEN
j = LEN(a$)
k = LEN(b$)
i = j - k
a$ = MID$(a$, 1, 16 + i): b$ = MID$(b$, 1, 16)
END IF
Pete
|
|
|
|
| How to fill-in a diamond without PAINT |
|
Posted by: SierraKen - 08-14-2022, 02:19 AM - Forum: Utilities
- Replies (19)
|
|
After trial and error, I figured out a way to make filled-in diamonds using the LINE command and loops and without PAINT. I'm going to add this in my Explorer game.
If anyone needs this, you can use this code. Feel free to make it any size, shape, whatever. 
Code: (Select All) Screen _NewImage(800, 600, 32)
x = 400
y = 300
For xx = 0 To 20 Step .25
Line (x + xx, y + xx)-(x - xx, y + xx)
Next xx
For yy = 20 To 0 Step -.25
Line (x + yy, y - yy + 40)-(x - yy, y - yy + 40)
Next yy
|
|
|
|
| Paranoia |
|
Posted by: bartok - 08-13-2022, 03:47 PM - Forum: Help Me!
- Replies (8)
|
 |
Hi,
I followed this forum in the old web-site.
Starting from 0, after having done the Terry Ritchies's tutorials, I created, little by little, a quite articulated program, that I have finished since some months, leaving out some little improvementS.
Currently, in order to maximize a kind of formal elegance in the code, I'm starting to suspect to be going towards a paranoia. I wonder things like that: "in a SELECT CASE, is it better to provide each CASE, even the most important part of the code, or it would be better to have the code outside the SELECT CASE, like a flow?
For example:
First paranoia.
Is it better like this:
Code: (Select All) DO
_LIMIT 30
KeyPress$ = INKEY$
LOOP UNTIL KeyPress$ = "1" OR KeyPress$ = "2" OR KeyPress$ = CHR$(27) OR KeyPress$ = CHR$(9) OR KeyPress$ = CHR$(0) + CHR$(59)
SELECT CASE KeyPress$
CASE "1", "2"
[A LOT OF CODE 1] <---------------------------------------------
DO
_LIMIT 30
KeyPress$ = INKEY$
LOOP UNTIL KeyPress$ = CHR$(27) OR KeyPress$ = CHR$(9) OR KeyPress$ = CHR$(0) + CHR$(59) OR KeyPress$ = CHR$(0) + CHR$(77)
SELECT CASE KeyPress$
CASE CHR$(27)
esc~` = 1
CASE CHR$(9)
riavvio~` = 1
CASE CHR$(0) + CHR$(59)
menu~` = 1
CASE CHR$(0) + CHR$(77)
[A LOT OF CODE 2] <---------------------------------------------
END SELECT
CASE CHR$(27)
esc~` = 1
CASE CHR$(9)
riavvio~` = 1
CASE CHR$(0) + CHR$(59)
menu~` = 1
END SELECT
Or like that:
Code: (Select All) DO
_LIMIT 30
KeyPress$ = INKEY$
LOOP UNTIL KeyPress$ = "1" OR KeyPress$ = "2" OR KeyPress$ = CHR$(27) OR KeyPress$ = CHR$(9) OR KeyPress$ = CHR$(0) + CHR$(59)
SELECT CASE KeyPress$
CASE CHR$(27)
esc~` = 1
CASE CHR$(9)
riavvio~` = 1
CASE CHR$(0) + CHR$(59)
menu~` = 1
END SELECT
[A LOT OF CODE 1] <---------------------------------------------
DO
_LIMIT 30
KeyPress$ = INKEY$
LOOP UNTIL KeyPress$ = CHR$(27) OR KeyPress$ = CHR$(9) OR KeyPress$ = CHR$(0) + CHR$(59) OR KeyPress$ = CHR$(0) + CHR$(77)
SELECT CASE KeyPress$
CASE CHR$(27)
esc~` = 1
CASE CHR$(9)
riavvio~` = 1
CASE CHR$(0) + CHR$(59)
menu~` = 1
END SELECT
[A LOT OF CODE 2] <---------------------------------------------
That's absolutely the same! But the structure completely changes in a conceptual way. I have take a little example, but it is not difficult to figure how the structure of a greater program could changes in a way, or in the other one. In the second example, the code is more simular to a flow. In the first, the logical structure is strictly respected, but nonetheless the program in it self, leaving out the possibility to navigate in it going back or ahead, it actually is a flow which begins from a start, until the end.
What is the better one, according to the "art of coding"?
Second paranoia.
About the the main code. As we know, the main code is the real tree of the program, which contains its structure, calling routines and subroutines which make specific things. That said, is it better to maximize the possibility to can understand the logical structure of the program at the expense of the logical comprehension of what the program actually does, or is it better the contrary.
I put 2 examples, that have the absolutely same structures and made absolutley the same things. In the first, it is avoided ALL is not strictly required in order to have the structure working, above all discursive parts, but not only.
Is it better this:
Code: (Select All) DO
CLEAR
DIM SHARED DESKTOPWIDTH%, DESKTOPHEIGHT%
DIM SHARED i%, n%%, z%%, p%%
DIM SHARED ieto%%
DIM SHARED VisualizzaIeto%%
DIM SHARED tipo%%
DIM SHARED esc~`, riavvio~`, menu~`, TornaAlGrafico~`
DIM SHARED interrompi~`(2)
DIM SHARED inputs$(8)
DIM SHARED KeyPress$
DIM SHARED CoefficientiDiscretizzazioneTemporale(24) AS CoefficientiDiscretizzazioneTemporale
DIM SHARED TempiRitorno(10) AS TempiRitorno
DIM SHARED idrogrammi1a24(2, 24, 50, 1) AS idrogramma
DIM SHARED MassimiIdrogrammi1a24(2, 24, 1) AS idrogramma
DIM SHARED MassimiAssolutiIeto(2) AS idrogramma
DIM SHARED IdroMaxieto%%(2)
DIM SHARED FinePioggiaIdrogrammi1a24(2, 24, 1) AS idrogramma
DIM SHARED FinePioggiaIdrogrammi1e2(2) AS idrogramma
DIM SHARED PassiFinePioggia1a24%%(24)
DIM SHARED ore!(3), portata!(3)
REDIM SHARED IdroPixel1(1) AS idrogramma
REDIM SHARED IdroPixel2(1) AS idrogramma
DIM L%, H%
DIM posizione%
DIM OriginaleGrafico&
DIM schermo&
DIM unitari&
DIM quadro&
DIM ComplessivoIeto1e2(2) AS composizione
DIM idrogramma1e2(2) AS composizione
DIM MatriciIeto1e2(2, 24)
DIM mockus(50) AS mockus
DIM matrice1(2, 24, 50, 1) AS matrice1
DIM matrice2!(2, 24, 50, 50)
DIM MinimiMatriciQuadrante1(2, 24, 1) AS idrogramma
DIM MinimiMatriciQuadrante2(2, 24, 1) AS idrogramma
DIM MassimiQuadrante2(2, 24, 1) AS idrogramma
DIM k!
DIM a1!
DIM n1!
DIM A2&
DIM L~%
DIM s1!
DIM CNII%%
DIM CoeffPerditeIniziali!
DIM CNIII!
DIM tl!
DIM S2!
DIM Ia!
DIM tc!
DIM ta!
DIM qp!
DIM dt!(24)
RESTORE TempiRitorno
FOR i% = 1 TO 20
IF i% <= 10 THEN READ TempiRitorno(i%).T
IF i% > 10 THEN READ TempiRitorno(i% - 10).k
NEXT i%
RESTORE CoefficientiIdrogrammaUnitarioMockus
FOR i% = 1 TO 100
IF i% <= 50 THEN READ mockus(i%).tSUta
IF i% > 50 THEN READ mockus(i% - 50).qSUqp
NEXT i%
RESTORE CoefficientiDiscretizzazioneTemporale
FOR i% = 1 TO 48
IF i% <= 24 THEN READ CoefficientiDiscretizzazioneTemporale(i%).N
IF i% > 24 THEN READ CoefficientiDiscretizzazioneTemporale(i% - 24).tSUta
NEXT i%
DESKTOPWIDTH% = _DESKTOPWIDTH
DESKTOPHEIGHT% = _DESKTOPHEIGHT
'DESKTOPWIDTH% = 1280 'limite inferiore della risoluzione dello schermo in pixel per il funzionamento del programma.
'DESKTOPHEIGHT% = 720
'DESKTOPWIDTH% = 1366 'valore intermedio della risoluzione dello schermo in pixel per il funzionamento del programma.
'DESKTOPHEIGHT% = 768
'DESKTOPWIDTH% = 1024 'sotto il limite inferiore della risoluzione dello schermo in pixel per il funzionamento del programma.
'DESKTOPHEIGHT% = 768
IF DESKTOPWIDTH% < 1280 THEN
esc~` = 1 'il programma è avviato verso la chiusura.
PRINT "Il programma Š incompatibile con schermi larghi meno di 1280 pixel."
PRINT "Questo schermo Š largo"; DESKTOPWIDTH%; "pixel."
PRINT "Premere un tasto per uscire."
BEEP
SLEEP
EXIT DO
ELSE
_FULLSCREEN
L% = DESKTOPWIDTH%: H% = L% \ 1.62
END IF
DO
menu~` = 0
VisualizzaIeto%% = 0
inizio:
IF _DIREXISTS(".\RisultatiQB64") THEN
ON ERROR GOTO cancel1
KILL (".\RisultatiQB64\*.*")
ON ERROR GOTO cancel2
RMDIR (".\RisultatiQB64")
END IF
ON ERROR GOTO 0
REDIM SHARED idrogramma1(1) AS idrogramma
REDIM SHARED idrogramma2(1) AS idrogramma
ERASE idrogrammi1a24, MassimiIdrogrammi1a24, FinePioggiaIdrogrammi1a24, MassimiAssolutiIeto, IdroMaxieto%%, FinePioggiaIdrogrammi1e2, PassiFinePioggia1a24%%, IdroPixel1, IdroPixel2, dt!, matrice1, matrice2!,_
MinimiMatriciQuadrante1, MinimiMatriciQuadrante2, MassimiQuadrante2
FOR ieto%% = 1 TO 2
ComplessivoIeto1e2(ieto%%).grafico = _NEWIMAGE(L% - 48 * 8, H%, 32)
ComplessivoIeto1e2(ieto%%).composizione = _NEWIMAGE(L%, H%, 32)
idrogramma1e2(ieto%%).grafico = _NEWIMAGE(L% - 59 * 8, H%, 32)
idrogramma1e2(ieto%%).composizione = _NEWIMAGE(L%, H%, 32)
FOR z%% = 1 TO 24
MatriciIeto1e2(ieto%%, z%%) = _NEWIMAGE(L%, H%, 32)
NEXT z%%
NEXT ieto%%
schermo& = _NEWIMAGE(DESKTOPWIDTH%, DESKTOPHEIGHT%, 32)
unitari& = _NEWIMAGE(L%, H%, 32)
quadro& = _NEWIMAGE(L% - 97 * 8, H% \ 2, 32)
GOSUB IstruzioniMenu
CALL InserimentoDati(k!, a1!, n1, A2&, L~%, s1!, CNII%%, CoeffPerditeIniziali!)
IF esc~` = 1 OR riavvio~` = 1 THEN EXIT DO
GOSUB Richiesta
DO
_LIMIT 30
KeyPress$ = INKEY$
LOOP UNTIL KeyPress$ = "1" OR KeyPress$ = "2" OR KeyPress$ = CHR$(27) OR KeyPress$ = CHR$(9) OR KeyPress$ = CHR$(0) + CHR$(59)
SELECT CASE KeyPress$
CASE "1", "2"
GOSUB CalcoloDatiPartenza
IF esc~` = 1 OR riavvio~` = 1 THEN EXIT SELECT
GOSUB IstruzioniIdrogrammi
DO
_LIMIT 30
KeyPress$ = INKEY$
LOOP UNTIL KeyPress$ = CHR$(27) OR KeyPress$ = CHR$(9) OR KeyPress$ = CHR$(0) + CHR$(59) OR KeyPress$ = CHR$(0) + CHR$(77)
SELECT CASE KeyPress$
CASE CHR$(27)
esc~` = 1
IF VisualizzaIeto%% = 2 THEN
CALL CalcolaIdrogramma(MassimiIdrogrammi1a24(VisualizzaIeto%%, 24, 1).ore, idrogrammi1a24(VisualizzaIeto%%, 24, 50, 1).ore, MassimiAssolutiIeto(VisualizzaIeto%%).ore,_
MassimiAssolutiIeto(VisualizzaIeto%%).portata, ComplessivoIeto1e2(VisualizzaIeto%%).grafico, ComplessivoIeto1e2(VisualizzaIeto%%).composizione)
GOSUB DisegnaIdrogramma
END IF
CASE CHR$(9)
riavvio~` = 1
CASE CHR$(0) + CHR$(59)
menu~` = 1
CASE CHR$(0) + CHR$(77)
GOSUB Visualizza
END SELECT
CASE CHR$(27)
esc~` = 1
CASE CHR$(9)
riavvio~` = 1
CASE CHR$(0) + CHR$(59)
menu~` = 1
END SELECT
IF riavvio~` = 0 AND menu~` = 0 THEN
_DEST shermo&
VIEW PRINT
CLS
IF VisualizzaIeto%% <> 0 THEN
IF interrompi~`(1) = 0 OR interrompi~`(2) = 0 THEN
GOSUB RichiestaSalvataggio
DO
_LIMIT 30
KeyPress$ = INKEY$
LOOP UNTIL KeyPress$ = "1" OR KeyPress$ = "2" OR KeyPress$ = CHR$(27) OR KeyPress$ = CHR$(9) OR KeyPress$ = CHR$(0) + CHR$(59)
SELECT CASE KeyPress$
CASE "1", "2"
GOSUB Salva
DO
_LIMIT 30
KeyPress$ = INKEY$
LOOP UNTIL KeyPress$ = CHR$(27) OR KeyPress$ = CHR$(9) OR KeyPress$ = CHR$(0) + CHR$(59)
SELECT CASE KeyPress$
CASE CHR$(27)
esc~` = 1
CASE CHR$(9)
riavvio~` = 1
CASE CHR$(0) + CHR$(59)
menu~` = 1
END SELECT
CASE CHR$(27)
esc~` = 1
CASE CHR$(9)
riavvio~` = 1
CASE CHR$(0) + CHR$(59)
menu~` = 1
END SELECT
END IF
END IF
END IF
IF riavvio~` = 1 OR menu~` = 1 THEN GOSUB freeimage
LOOP UNTIL esc~` = 1 OR riavvio~` = 1
LOOP UNTIL esc~` = 1
freeimage:
IF DESKTOPWIDTH% >= 1280 THEN
FOR ieto%% = 1 TO 2
_FREEIMAGE ComplessivoIeto1e2(ieto%%).grafico
_FREEIMAGE ComplessivoIeto1e2(ieto%%).composizione
_FREEIMAGE idrogramma1e2(ieto%%).grafico
_FREEIMAGE idrogramma1e2(ieto%%).composizione
FOR z%% = 1 TO 24
_FREEIMAGE MatriciIeto1e2(ieto%%, z%%)
NEXT z%%
NEXT ieto%%
_FREEIMAGE unitari&
_FREEIMAGE quadro&
ON ERROR GOTO cancel1: _FREEIMAGE OriginaleGrafico&: ON ERROR GOTO 0
END IF
IF riavvio~` = 1 OR menu~` = 1 THEN RETURN
SYSTEM
Or that:
Code: (Select All) DO
CLEAR
DIM SHARED DESKTOPWIDTH%, DESKTOPHEIGHT%
DIM SHARED i%, n%%, z%%, p%%
DIM SHARED ieto%%
DIM SHARED VisualizzaIeto%%
DIM SHARED tipo%%
DIM SHARED esc~`, riavvio~`, menu~`, TornaAlGrafico~`
DIM SHARED interrompi~`(2)
DIM SHARED inputs$(8)
DIM SHARED KeyPress$
DIM SHARED CoefficientiDiscretizzazioneTemporale(24) AS CoefficientiDiscretizzazioneTemporale
DIM SHARED TempiRitorno(10) AS TempiRitorno
DIM SHARED idrogrammi1a24(2, 24, 50, 1) AS idrogramma
DIM SHARED MassimiIdrogrammi1a24(2, 24, 1) AS idrogramma
DIM SHARED MassimiAssolutiIeto(2) AS idrogramma
DIM SHARED IdroMaxieto%%(2)
DIM SHARED FinePioggiaIdrogrammi1a24(2, 24, 1) AS idrogramma
DIM SHARED FinePioggiaIdrogrammi1e2(2) AS idrogramma
DIM SHARED PassiFinePioggia1a24%%(24)
DIM SHARED ore!(3), portata!(3)
REDIM SHARED IdroPixel1(1) AS idrogramma
REDIM SHARED IdroPixel2(1) AS idrogramma
DIM L%, H%
DIM posizione%
DIM OriginaleGrafico&
DIM schermo&
DIM unitari&
DIM quadro&
DIM ComplessivoIeto1e2(2) AS composizione
DIM idrogramma1e2(2) AS composizione
DIM MatriciIeto1e2(2, 24)
DIM mockus(50) AS mockus
DIM matrice1(2, 24, 50, 1) AS matrice1
DIM matrice2!(2, 24, 50, 50)
DIM MinimiMatriciQuadrante1(2, 24, 1) AS idrogramma
DIM MinimiMatriciQuadrante2(2, 24, 1) AS idrogramma
DIM MassimiQuadrante2(2, 24, 1) AS idrogramma
DIM k!
DIM a1!
DIM n1!
DIM A2&
DIM L~%
DIM s1!
DIM CNII%%
DIM CoeffPerditeIniziali!
DIM CNIII!
DIM tl!
DIM S2!
DIM Ia!
DIM tc!
DIM ta!
DIM qp!
DIM dt!(24)
RESTORE TempiRitorno
FOR i% = 1 TO 20
IF i% <= 10 THEN READ TempiRitorno(i%).T
IF i% > 10 THEN READ TempiRitorno(i% - 10).k
NEXT i%
RESTORE CoefficientiIdrogrammaUnitarioMockus
FOR i% = 1 TO 100
IF i% <= 50 THEN READ mockus(i%).tSUta
IF i% > 50 THEN READ mockus(i% - 50).qSUqp
NEXT i%
RESTORE CoefficientiDiscretizzazioneTemporale
FOR i% = 1 TO 48
IF i% <= 24 THEN READ CoefficientiDiscretizzazioneTemporale(i%).N
IF i% > 24 THEN READ CoefficientiDiscretizzazioneTemporale(i% - 24).tSUta
NEXT i%
DESKTOPWIDTH% = _DESKTOPWIDTH
DESKTOPHEIGHT% = _DESKTOPHEIGHT
'DESKTOPWIDTH% = 1280 'limite inferiore della risoluzione dello schermo in pixel per il funzionamento del programma.
'DESKTOPHEIGHT% = 720
'DESKTOPWIDTH% = 1366 'valore intermedio della risoluzione dello schermo in pixel per il funzionamento del programma.
'DESKTOPHEIGHT% = 768
'DESKTOPWIDTH% = 1024 'sotto il limite inferiore della risoluzione dello schermo in pixel per il funzionamento del programma.
'DESKTOPHEIGHT% = 768
IF DESKTOPWIDTH% < 1280 THEN
esc~` = 1 'il programma è avviato verso la chiusura.
PRINT "Il programma Š incompatibile con schermi larghi meno di 1280 pixel."
PRINT "Questo schermo Š largo"; DESKTOPWIDTH%; "pixel."
PRINT "Premere un tasto per uscire."
BEEP
SLEEP
EXIT DO
ELSE
_FULLSCREEN
L% = DESKTOPWIDTH%: H% = L% \ 1.62
END IF
DO
menu~` = 0
VisualizzaIeto%% = 0
inizio:
IF _DIREXISTS(".\RisultatiQB64") THEN
ON ERROR GOTO cancel1
KILL (".\RisultatiQB64\*.*")
ON ERROR GOTO cancel2
RMDIR (".\RisultatiQB64")
END IF
ON ERROR GOTO 0
REDIM SHARED idrogramma1(1) AS idrogramma
REDIM SHARED idrogramma2(1) AS idrogramma
ERASE idrogrammi1a24, MassimiIdrogrammi1a24, FinePioggiaIdrogrammi1a24, MassimiAssolutiIeto, IdroMaxieto%%, FinePioggiaIdrogrammi1e2, PassiFinePioggia1a24%%, IdroPixel1, IdroPixel2, dt!, matrice1, matrice2!,_
MinimiMatriciQuadrante1, MinimiMatriciQuadrante2, MassimiQuadrante2
FOR ieto%% = 1 TO 2
ComplessivoIeto1e2(ieto%%).grafico = _NEWIMAGE(L% - 48 * 8, H%, 32)
ComplessivoIeto1e2(ieto%%).composizione = _NEWIMAGE(L%, H%, 32)
idrogramma1e2(ieto%%).grafico = _NEWIMAGE(L% - 59 * 8, H%, 32)
idrogramma1e2(ieto%%).composizione = _NEWIMAGE(L%, H%, 32)
FOR z%% = 1 TO 24
MatriciIeto1e2(ieto%%, z%%) = _NEWIMAGE(L%, H%, 32)
NEXT z%%
NEXT ieto%%
schermo& = _NEWIMAGE(DESKTOPWIDTH%, DESKTOPHEIGHT%, 32)
unitari& = _NEWIMAGE(L%, H%, 32)
quadro& = _NEWIMAGE(L% - 97 * 8, H% \ 2, 32)
SCREEN schermo&
CLS
COLOR giallo&: PRINT " C A L C O L O D E L L ' I D R O G R A M M A D I P I E N A D I P R O G E T T O T R A M I T E I L M E T O D O S C S - C N"
COLOR grigio&: PRINT " - I N G . C A R L O B A R T O L I N I -"
COLOR bianco&
PRINT "Questo programma calcola:"
PRINT "- l'idrogramma di piena di progetto (e relativa portata di picco);"
PRINT "- se voluto, l'idrogramma di piena corrispondente ad un'ora di picco a scelta,"
PRINT "per un dato tempo di ritorno tramite l'idrogramma unitario adimensionale di Mockus,il metodo afflussi-deflussi SCS-CN, ietogrammi "; CHR$(34); "Chicago"; CHR$(34); " e "; CHR$(34); "costanti"; CHR$(34); "."
PRINT "Sar… possibile scegliere se visualizzare i risultati in base a l'uno o all'altro tipo di ietogramma, ma anche quello non visualizzato, sar… comunque"
PRINT "calcolato ed eventualmente salvato nei risultati dal programma che, dopo l'elaborazione e premendo ESC o al suo termine, chieder… se salvarli nella"
PRINT "seguente directory:"
PRINT
PRINT CHR$(34); _CWD$; "\RisultatiQB64"; CHR$(34); "."
PRINT
PRINT "Nel caso si vogliano salvare i risultati,Š consigliato che il programma si trovi sul computer locale,nel qual caso l'operazione di salvataggio richieder…"
PRINT "pochi secondi o 1-2 minuti, a seconda che si salvino solo i tabulati o anche le immagini. Da rete, invece, possono occorrere molti minuti solo per i"
PRINT "tabulati."
PRINT "I file salvati saranno di 3 tipi:"
PRINT "- immagini dei grafici, con estensione "; CHR$(34); "BMP"; CHR$(34); ";"
PRINT "- tabulati, con estensione "; CHR$(34); "CSV"; CHR$(34); ". Possono essere aperti con Excel, ma per essere visualizzati correttamente, nelle impostazioni di Windows il separatore"
PRINT " dell'elenco dev'essere la virgola. Le celle dei fogli di lavoro dei file relativi al calcolo di ogni idrogramma contengono le formule,per cui in essi Š"
PRINT " esemplificata la procedura di calcolo del programma stesso;"
PRINT "- un file con estensione "; CHR$(34); "TXT"; CHR$(34); " in cui Š riportato il codice del programma commentato, comprese le procedure di calcolo."
PRINT "Rieseguendo o riavviando il programma [TAB], o tornando al menu degli input qui di seguito [F1], la directory "; CHR$(34); "RisultatiQB64"; CHR$(34); "sar… cancellata, quindi se"
PRINT "s'intende preservare i risultati, sar… prima necessario o rinominarla o spostarla."
PRINT "---------------------------------------------------------------------------------------------------------------------------------------------------------"
PRINT "Di seguito,si dovranno inserire i valori della curva di possibilit… climatica "; CHR$(34); "h = Ktúaúd^n"; CHR$(34); ". Se si dispone dei valori del Centro Funzionale, digitare il"
PRINT "valore "; CHR$(34); "Kt"; CHR$(34); " relativo al tempo di ritorno "; CHR$(34); "T"; CHR$(34); " d'interesse, con i relativi valori "; CHR$(34); "a"; CHR$(34); " e "; CHR$(34); "n"; CHR$(34); ". Se invece si ha una propria curva di possibilit… climatica,in"
PRINT "corrispondenza di "; CHR$(34); "Kt"; CHR$(34); ", digitare "; CHR$(34); "INVIO"; CHR$(34); ", o "; CHR$(34); "1"; CHR$(34); ".In tal caso "; CHR$(34); "Kt"; CHR$(34); " sar… considerato pari a "; CHR$(34); "1"; CHR$(34); " e "; CHR$(34); "T"; CHR$(34); " come "; CHR$(34); "definito dall'utente"; CHR$(34); "."
PRINT
PRINT "- Kt [-] (INVIO per 1) = "
PRINT "- a [mm/d^n] = "
PRINT "- n [-] (0ö1) = "
PRINT "- Area in pianta del bacino idrografico [mý] (>=1) = "
PRINT "- Lunghezza dell'asta principale del bacino idrografico [m] (>=1) = "
PRINT "- Pendenza media del bacino idrografico [%] (>=1) = "
PRINT "- CN(II) [-] (1ö100) = "
PRINT "- Coefficiente delle perdite inziali [-] (0ö0.2 - INVIO per 0.1) = "
LOCATE CSRLIN + 2,
COLOR giallo&: PRINT " [ESC]: esci; [TAB]: riavvia.": COLOR bianco&
CALL InserimentoDati(k!, a1!, n1, A2&, L~%, s1!, CNII%%, CoeffPerditeIniziali!)
IF esc~` = 1 OR riavvio~` = 1 THEN EXIT DO
LOCATE PosizioneCursore%% + 9, 1
COLOR giallo&
PRINT " [1]: utilizza lo ietogramma Chicago; [2]: utilizza lo ietogramma costante;"
PRINT " [ESC]: esci; [TAB]: riavvia; [F1]: torna agli input iniziali."
COLOR bianco&
DO
_LIMIT 30
KeyPress$ = INKEY$
LOOP UNTIL KeyPress$ = "1" OR KeyPress$ = "2" OR KeyPress$ = CHR$(27) OR KeyPress$ = CHR$(9) OR KeyPress$ = CHR$(0) + CHR$(59)
SELECT CASE KeyPress$
CASE "1", "2"
VisualizzaIeto%% = VAL(KeyPress$)
CNIII! = (23 * CNII%%) / (10 + 0.13 * CNII%%) ' ¿
tl! = 0.342 * ((L~% / 1000) ^ 0.8 / s1! ^ 0.5) * (1000 / CNIII! - 9) ^ 0.7 '* formula di Mockus. ³ dati immediatamente discendenti dagli input iniziali, che fungono da input interni al programma per le elaborazioni.
S2! = 25.4 * (1000 / CNIII! - 10) '* ³
Ia! = CoeffPerditeIniziali! * S2! '* coeff.=0.03-0.2. 'perdite iniziali ³ * La sistemazione dei bacini montani - Vito Ferro - Seconda edizione - cap. 3.4.7. "Il metodo SCS" - pp. 195-205.
tc! = tl! / 0.6 '** ³
ta! = tl! / 0.9 '* ³ ** ibid. cap. 3.4.4. "Il tempo di corrivazione di un bacino" - p. 188.
qp! = 0.208 * ((A2& / 1000000) / ta!) '* Ù
FOR ieto%% = 1 TO 2
interrompi~`(ieto%%) = 0
continua1:
IF interrompi~`(1) = 1 THEN IF ieto%% = 1 THEN _CONTINUE
continua2:
IF interrompi~`(2) = 1 THEN EXIT FOR
IF ieto%% = 1 THEN ON ERROR GOTO salta1
IF ieto%% = 2 THEN ON ERROR GOTO salta2
FOR z%% = 1 TO 24
GOSUB CalcolaMatriciIeto1e2
GOSUB DisegnaMatriciIeto1e2
NEXT z%%
IF interrompi~`(ieto%%) = 0 THEN GOSUB DisegnaComplessivoIeto1e2
NEXT ieto%%
ON ERROR GOTO 0
GOSUB TerminaSeErrore
IF esc~` = 1 OR riavvio~` = 1 THEN EXIT SELECT
GOSUB DisegnaUnitari
_DEST schermo&
PRINT "---------------------------------------------------------------------------------------------------------------------------------------------------------"
PRINT "Sono stati calcolati 24 idrogrammi di piena con relative portate di picco,per durate della pioggia fino a 32 volte il tempo di corrivazione. Nella pagina"
PRINT "successiva, saranno visualizzati insieme alla spezzata (in";: COLOR giallo&: PRINT " giallo";: COLOR bianco&: PRINT ") congiungente le portate di picco dei vari idrogrammi. Per determinare l'idrogramma di"
PRINT "progetto e relativa portata di picco, sar… possibile avvalersi dei suddetti risultati (per esempio tramite Excel), oppure proseguire su questo programma."
PRINT
SELECT CASE VisualizzaIeto%%
CASE IS = 1
PRINT "In tal caso, il programma chieder… 2 input:"
PRINT "- una soglia percentuale S, per il calcolo dell'idrogramma di progetto."
PRINT " Per esempio, scrivendo 10%, viene verificato se, sulla spezzata gialla, la portata di picco corrispondente all'ora 1 aumentata del 10%, Š minore della"
PRINT " portata di picco corrispondente all'ora 2. Se Š minore, l'algoritmo prosegue finch‚ non trova la portata di picco di un'ora "; CHR$(34); "i"; CHR$(34); " che, aumentata del 10%,"
PRINT " risulta maggiore della portata di picco dell'ora "; CHR$(34); "i+1"; CHR$(34); ". Sar… considerato come idrogramma di progetto quello relativo all'ultima ora la cui portata di"
PRINT " picco risulta essere superiore alla portata di picco dell'ora precedente aumentata del 10%."
PRINT " Qualora la soglia percentuale digitata sia troppo bassa per determinare, nel corso delle iterazioni, un superamento della portata di picco dell'ora"
PRINT " successiva, viene computato, come idrogramma di progetto, quello che presenta la massima portata di picco tra i 24 calcolati;"
PRINT "- un'ora di picco a scelta, di cui viene calcolata la corrispondente portata di picco e relativo idrogramma."
CASE IS = 2
PRINT "In tal caso, il programma chieder… 1 input:"
PRINT "- un'ora di picco a scelta, di cui viene calcolata la corrispondente portata di picco e relativo idrogramma."
PRINT "Come idrogramma di progetto, Š computato quello che presenta la massima portata di picco tra i 24 calcolati."
END SELECT
PRINT
COLOR giallo&: PRINT " [ESC]: salva; [TAB]: riavvia; [F1]: torna agli input iniziali; []: prosegui.": COLOR bianco&
LOCATE CSRLIN + 1,
DO
_LIMIT 30
KeyPress$ = INKEY$
LOOP UNTIL KeyPress$ = CHR$(27) OR KeyPress$ = CHR$(9) OR KeyPress$ = CHR$(0) + CHR$(59) OR KeyPress$ = CHR$(0) + CHR$(77)
SELECT CASE KeyPress$
CASE CHR$(27)
esc~` = 1
IF VisualizzaIeto%% = 2 THEN
CALL CalcolaIdrogramma(MassimiIdrogrammi1a24(VisualizzaIeto%%, 24, 1).ore, idrogrammi1a24(VisualizzaIeto%%, 24, 50, 1).ore, MassimiAssolutiIeto(VisualizzaIeto%%).ore,_
MassimiAssolutiIeto(VisualizzaIeto%%).portata, ComplessivoIeto1e2(VisualizzaIeto%%).grafico, ComplessivoIeto1e2(VisualizzaIeto%%).composizione)
GOSUB DisegnaIdrogramma
END IF
CASE CHR$(9)
riavvio~` = 1
CASE CHR$(0) + CHR$(59)
menu~` = 1
CASE CHR$(0) + CHR$(77)
CLS
VIEW PRINT 1 TO 4
DO
TornaAlGrafico~` = 0
ERASE IdroPixel1, IdroPixel2, idrogramma1, idrogramma2
FOR ieto%% = 1 TO 2
_DEST idrogramma1e2(ieto%%).grafico: CLS
_DEST idrogramma1e2(ieto%%).composizione: CLS
NEXT ieto%%
GOSUB VisualizzaComplessivo
CALL CalcolaIdrogramma(MassimiIdrogrammi1a24(VisualizzaIeto%%, 24, 1).ore, idrogrammi1a24(VisualizzaIeto%%, 24, 50, 1).ore, MassimiAssolutiIeto(VisualizzaIeto%%).ore,_
MassimiAssolutiIeto(VisualizzaIeto%%).portata, ComplessivoIeto1e2(VisualizzaIeto%%).grafico, ComplessivoIeto1e2(VisualizzaIeto%%).composizione)
GOSUB DisegnaIdrogramma
GOSUB VisualizzaIdrogramma
IF TornaAlGrafico~` = 1 THEN _CONTINUE
IF esc~` = 1 OR riavvio~` = 1 OR menu~` = 1 THEN EXIT DO
GOSUB VisualizzaUnitari
IF TornaAlGrafico~` = 1 THEN _CONTINUE
IF esc~` = 1 OR riavvio~` = 1 OR menu~` = 1 THEN EXIT DO
GOSUB VisualizzaMatrici
IF TornaAlGrafico~` = 1 THEN _CONTINUE
IF esc~` = 1 OR riavvio~` = 1 OR menu~` = 1 THEN EXIT DO
LOOP
END SELECT
CASE CHR$(27)
esc~` = 1
CASE CHR$(9)
riavvio~` = 1
CASE CHR$(0) + CHR$(59)
menu~` = 1
END SELECT
IF riavvio~` = 0 AND menu~` = 0 THEN
_DEST shermo&
VIEW PRINT
CLS
IF VisualizzaIeto%% <> 0 THEN
IF interrompi~`(1) = 0 OR interrompi~`(2) = 0 THEN
esc~` = 0
PRINT
COLOR giallo&
PRINT "[1]: salva su disco tabulati e immagini (richiede pi— tempo);"
PRINT "[2]: salva solo tabulati;"
PRINT "[ESC]: esci; [TAB]: riavvia; [F1]: torna agli input iniziali."
PRINT
COLOR R&: PRINT "Si ricorda che se il programma non si trova sul computer locale, ma in rete, il salvataggio potrebbe richiedere molti minuti."
COLOR bianco&
PRINT
DO
_LIMIT 30
KeyPress$ = INKEY$
LOOP UNTIL KeyPress$ = "1" OR KeyPress$ = "2" OR KeyPress$ = CHR$(27) OR KeyPress$ = CHR$(9) OR KeyPress$ = CHR$(0) + CHR$(59)
SELECT CASE KeyPress$
CASE "1", "2"
MKDIR "RisultatiQB64"
CHDIR ".\RisultatiQB64"
PRINT "Attendere, salvataggio in corso nella directory:"
PRINT CHR$(34); _CWD$; CHR$(34); "."
PRINT
PRINT "Si ricorda che:"
PRINT "- rieseguendo o riavviando il programma [TAB], o tornando al menu degli input [F1], la directory "; CHR$(34); "RisultatiQB64"; CHR$(34); " sar… cancellata, quindi se s'intende"
PRINT " preservare i risultati, sar… prima necessario o rinominarla o spostarla;"
PRINT "- per i file di estensione "; CHR$(34); "CSV"; CHR$(34); ", affinch‚ siano visualizzati correttamente in Excel,";: COLOR R&: PRINT " Š necessario che nelle impostazioni di Windows il separatore dello"
PRINT " elenco sia la virgola";: COLOR bianco&: PRINT "."
SLEEP 3
PRINT
COLOR giallo&: PRINT "Per terminare il salvataggio cliccare su questa schermata, premere [ESC] e attendere qualche istante."
SHELL _CWD$
GOSUB Risultati
CHDIR "..\"
LOCATE CSRLIN - 1,: PRINT STRING$(115, 32)
COLOR giallo&
LOCATE CSRLIN - 1,: PRINT "Cliccare su questa schermata e [ESC]: esci; [TAB]: riavvia; [F1]: torna agli input iniziali."
BEEP
DO
_LIMIT 30
KeyPress$ = INKEY$
LOOP UNTIL KeyPress$ = CHR$(27) OR KeyPress$ = CHR$(9) OR KeyPress$ = CHR$(0) + CHR$(59)
SELECT CASE KeyPress$
CASE CHR$(27)
esc~` = 1
CASE CHR$(9)
riavvio~` = 1
CASE CHR$(0) + CHR$(59)
menu~` = 1
END SELECT
CASE CHR$(27)
esc~` = 1
CASE CHR$(9)
riavvio~` = 1
CASE CHR$(0) + CHR$(59)
menu~` = 1
END SELECT
END IF
END IF
END IF
IF riavvio~` = 1 OR menu~` = 1 THEN GOSUB freeimage
LOOP UNTIL esc~` = 1 OR riavvio~` = 1
LOOP UNTIL esc~` = 1
freeimage:
IF DESKTOPWIDTH% >= 1280 THEN
FOR ieto%% = 1 TO 2
_FREEIMAGE ComplessivoIeto1e2(ieto%%).grafico
_FREEIMAGE ComplessivoIeto1e2(ieto%%).composizione
_FREEIMAGE idrogramma1e2(ieto%%).grafico
_FREEIMAGE idrogramma1e2(ieto%%).composizione
FOR z%% = 1 TO 24
_FREEIMAGE MatriciIeto1e2(ieto%%, z%%)
NEXT z%%
NEXT ieto%%
_FREEIMAGE unitari&
_FREEIMAGE quadro&
ON ERROR GOTO cancel1: _FREEIMAGE OriginaleGrafico&: ON ERROR GOTO 0
END IF
IF riavvio~` = 1 OR menu~` = 1 THEN RETURN
SYSTEM
|
|
|
|
|
