| Welcome, Guest |
You have to register before you can post on our site.
|
| Latest Threads |
_CONSOLEINPUT is blocking
Forum: General Discussion
Last Post: mdijkens
47 minutes ago
» Replies: 7
» Views: 99
|
Audio storage, stereo swi...
Forum: Programs
Last Post: VikRam025
11 hours ago
» Replies: 3
» Views: 286
|
Who wants to PLAY?
Forum: QBJS, BAM, and Other BASICs
Last Post: a740g
Today, 12:09 AM
» Replies: 5
» Views: 112
|
Most efficient way to bui...
Forum: General Discussion
Last Post: ahenry3068
Yesterday, 11:36 PM
» Replies: 9
» Views: 128
|
QBJS - ANSI Draw
Forum: QBJS, BAM, and Other BASICs
Last Post: madscijr
Yesterday, 11:24 PM
» Replies: 4
» Views: 125
|
Fun with Ray Casting
Forum: a740g
Last Post: a740g
Yesterday, 05:50 AM
» Replies: 10
» Views: 235
|
Very basic key mapping de...
Forum: SMcNeill
Last Post: a740g
Yesterday, 02:33 AM
» Replies: 1
» Views: 53
|
Methods in types
Forum: General Discussion
Last Post: bobalooie
Yesterday, 01:02 AM
» Replies: 0
» Views: 60
|
Cautionary tale of open, ...
Forum: General Discussion
Last Post: doppler
01-16-2025, 10:23 AM
» Replies: 3
» Views: 120
|
Extended KotD #23 and #24...
Forum: Keyword of the Day!
Last Post: SMcNeill
01-16-2025, 09:51 AM
» Replies: 0
» Views: 56
|
|
|
| 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
|
|
|
|
| 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
|
|
|
|
|
