326 lines
7.7 KiB
Plaintext
326 lines
7.7 KiB
Plaintext
' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
|
|
' Lychrel Numbers V1.0 '
|
|
' '
|
|
' Developed by A. David Garza Marín in QB64 for '
|
|
' RosettaCode. December 2, 2016. '
|
|
' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
|
|
|
|
OPTION _EXPLICIT ' Change to OPTION EXPLICIT in VB-DOS or PDS 7.1. Remove in QB and QBASIC
|
|
|
|
' SUBs and FUNCTIONs
|
|
DECLARE SUB doAddLychrel (WhichNumber AS LONG)
|
|
DECLARE SUB doAddRelated (WhichNumber AS LONG)
|
|
DECLARE SUB doFindLychrelPalyndromes ()
|
|
DECLARE FUNCTION CalculateMaxRes& (WhichNumber AS LONG)
|
|
DECLARE FUNCTION IsLychrel% (WhichNumber AS LONG)
|
|
DECLARE FUNCTION Reverse$ (WhatToReverse AS STRING)
|
|
DECLARE FUNCTION Sum$ (N1 AS STRING, N2 AS STRING)
|
|
|
|
' Var
|
|
DIM sN1 AS STRING, sN2 AS STRING, sLychrel AS STRING
|
|
DIM i AS LONG, iLychrel AS INTEGER, iCount AS INTEGER, l AS INTEGER
|
|
DIM c1 AS INTEGER, l1 AS INTEGER, c2 AS INTEGER, l2 AS INTEGER
|
|
DIM lMC AS LONG, lT AS LONG
|
|
DIM lLC AS LONG, lRL AS LONG, lPN AS LONG
|
|
CONST MaxNumbers = 10000, MaxIterations = 500, False = 0, True = NOT False
|
|
|
|
' Init
|
|
REDIM lLC(1, 0) AS LONG, lRL(0) AS LONG, lPN(0) AS LONG
|
|
lMC = CalculateMaxRes&(MaxNumbers)
|
|
lT = TIMER
|
|
|
|
' ------------------ Main program -----------------------------------------
|
|
CLS
|
|
PRINT "Lychrel Numbers 1.0"
|
|
PRINT
|
|
PRINT "Calculating numbers from 1 to"; MaxNumbers;
|
|
c1 = POS(1)
|
|
l1 = CSRLIN
|
|
COLOR 7 + 16: PRINT "...": PRINT
|
|
COLOR 7
|
|
c2 = POS(1)
|
|
l2 = CSRLIN
|
|
FOR i = 1 TO MaxNumbers
|
|
sN1 = LTRIM$(STR$(i))
|
|
sN2 = Reverse$(sN1)
|
|
iCount = 0
|
|
LOCATE l2, 1: PRINT "Analyzing number"; i;
|
|
COLOR 7 + 16: PRINT "...": COLOR 7
|
|
DO
|
|
iCount = iCount + 1
|
|
sN1 = Sum$(sN1, sN2)
|
|
sN2 = Reverse$(sN1)
|
|
LOOP UNTIL iCount >= MaxIterations OR sN1 = sN2
|
|
|
|
IF sN1 <> sN2 THEN
|
|
IF IsLychrel%(i) THEN
|
|
doAddLychrel i
|
|
ELSE
|
|
doAddRelated i
|
|
END IF
|
|
PRINT "Potential Lychrel numbers:"; UBOUND(lLC, 2); "{";
|
|
FOR l = 1 TO UBOUND(lLC, 2)
|
|
PRINT lLC(1, l);
|
|
NEXT
|
|
PRINT "}"
|
|
|
|
IF UBOUND(lRL) > 0 THEN
|
|
PRINT "Kin Lychrel numbers found:"; UBOUND(lRL)
|
|
END IF
|
|
END IF
|
|
NEXT i
|
|
|
|
' Look for palyndromes
|
|
IF UBOUND(lLC, 2) > 0 THEN
|
|
doFindLychrelPalyndromes
|
|
END IF
|
|
|
|
' Shows the results
|
|
CLS
|
|
PRINT "Lychrel numbers 1.0 in QB64"
|
|
PRINT
|
|
PRINT "Lychrel numbers found: "; UBOUND(lLC, 2)
|
|
PRINT "Lychrel numbers: {";
|
|
FOR i = 1 TO UBOUND(lLC, 2)
|
|
PRINT lLC(1, i);
|
|
NEXT
|
|
PRINT "}"
|
|
PRINT
|
|
PRINT "Kin numbers found: "; UBOUND(lRL)
|
|
' You can uncomment the following lines if you want to see the
|
|
' Kin or Related numbers found.
|
|
'PRINT "Kin numbers: {";
|
|
'FOR i = 1 TO UBOUND(lRL)
|
|
' PRINT lRL(i);
|
|
'NEXT i
|
|
'PRINT "}"
|
|
PRINT
|
|
PRINT "Palyndrome Lychrel numbers found:"; UBOUND(lPN); "{";
|
|
FOR i = 1 TO UBOUND(lPN)
|
|
PRINT lPN(i);
|
|
NEXT i
|
|
PRINT "}"
|
|
lT = TIMER - lT
|
|
PRINT
|
|
PRINT USING "Calculation took ##:## seconds."; FIX(lT / 60), (lT MOD 60)
|
|
PRINT "End of program."
|
|
' ------------------ End of Main program --------------------------------------
|
|
END
|
|
|
|
FUNCTION CalculateMaxRes& (WhichNumber AS LONG)
|
|
' Var
|
|
IF (WhichNumber MOD 10) <> 0 THEN
|
|
CalculateMaxRes& = WhichNumber + VAL(Reverse$(LTRIM$(STR$(WhichNumber))))
|
|
ELSE
|
|
CalculateMaxRes& = (WhichNumber - 1) + VAL(Reverse$(LTRIM$(STR$(WhichNumber - 1))))
|
|
END IF
|
|
END FUNCTION
|
|
|
|
SUB doAddLychrel (WhichNumber AS LONG)
|
|
' Var
|
|
DIM iMaxC AS INTEGER, iMaxR AS INTEGER
|
|
DIM lRes AS LONG, iRow AS INTEGER
|
|
DIM sN1 AS STRING, sN2 AS STRING
|
|
DIM lNum(1 TO 10) AS LONG
|
|
SHARED lLC() AS LONG, lMC AS LONG
|
|
|
|
'
|
|
lNum(1) = WhichNumber
|
|
iRow = 1
|
|
iMaxR = 10
|
|
lRes = WhichNumber
|
|
DO
|
|
iRow = iRow + 1
|
|
IF iRow > iMaxR THEN
|
|
' Change to REDIM PRESERVE for VB-DOS, QB, QBASIC and PDS 7.1
|
|
REDIM _PRESERVE lNum(1 TO iMaxR + 10) AS LONG
|
|
END IF
|
|
sN1 = LTRIM$(STR$(lRes))
|
|
sN2 = Reverse$(sN1)
|
|
lRes = VAL(Sum$(sN1, sN2))
|
|
lNum(iRow) = lRes
|
|
LOOP UNTIL lRes > lMC
|
|
|
|
' Change to REDIM PRESERVE for VB-DOS, QB, QBASIC and PDS 7.1
|
|
REDIM _PRESERVE lNum(1 TO iRow) AS LONG
|
|
|
|
' Now, Gathers the size of the lLC table
|
|
iMaxC = UBOUND(lLC, 2) + 1
|
|
IF iMaxC = 1 THEN
|
|
ERASE lLC
|
|
iMaxR = iRow
|
|
ELSE
|
|
iMaxR = UBOUND(lLC, 1)
|
|
END IF
|
|
|
|
IF iMaxC = 1 THEN
|
|
REDIM lLC(1 TO iMaxR, 1 TO iMaxC) AS LONG
|
|
ELSE
|
|
' Change to REDIM PRESERVE for VB-DOS, QB, QBASIC and PDS 7.1
|
|
REDIM _PRESERVE lLC(1 TO iMaxR, 1 TO iMaxC) AS LONG
|
|
END IF
|
|
|
|
' Assigns the result to the table
|
|
FOR lRes = 1 TO iRow
|
|
lLC(lRes, iMaxC) = lNum(lRes)
|
|
NEXT lRes
|
|
|
|
ERASE lNum
|
|
END SUB
|
|
|
|
SUB doAddRelated (WhichNumber AS LONG)
|
|
' Var
|
|
DIM iMax AS INTEGER
|
|
SHARED lRL() AS LONG
|
|
|
|
iMax = UBOUND(lRL) + 1
|
|
IF iMax = 1 THEN
|
|
ERASE lRL
|
|
END IF
|
|
' Change to REDIM PRESERVE for VB-DOS, QB, QBASIC and PDS 7.1
|
|
REDIM _PRESERVE lRL(1 TO iMax) AS LONG
|
|
lRL(iMax) = WhichNumber
|
|
END SUB
|
|
|
|
SUB doFindLychrelPalyndromes ()
|
|
' Var
|
|
DIM iMaxC AS INTEGER, i AS INTEGER, iCount AS INTEGER
|
|
DIM sN1 AS STRING, sN2 AS STRING
|
|
SHARED lLC() AS LONG, lRL() AS LONG, lPN() AS LONG
|
|
|
|
' Verify seeds
|
|
iMaxC = UBOUND(lLC, 2)
|
|
FOR i = 1 TO iMaxC
|
|
IF lLC(1, i) > 0 THEN
|
|
sN1 = LTRIM$(STR$(lLC(1, i)))
|
|
sN2 = Reverse$(sN1)
|
|
IF sN1 = sN2 THEN
|
|
iCount = iCount + 1
|
|
GOSUB AddSpaceForItem
|
|
lPN(iCount) = VAL(sN1)
|
|
END IF
|
|
END IF
|
|
NEXT i
|
|
|
|
' Verify Kins
|
|
iMaxC = UBOUND(lRL)
|
|
FOR i = 1 TO iMaxC
|
|
IF lRL(i) > 0 THEN
|
|
sN1 = LTRIM$(STR$(lRL(i)))
|
|
sN2 = Reverse$(sN1)
|
|
IF sN1 = sN2 THEN
|
|
iCount = iCount + 1
|
|
GOSUB AddSpaceForItem
|
|
lPN(iCount) = VAL(sN1)
|
|
END IF
|
|
END IF
|
|
NEXT i
|
|
|
|
' Change to REDIM PRESERVE for VB-DOS, QB, QBASIC and PDS 7.1
|
|
REDIM _PRESERVE lPN(1 TO iCount) AS LONG
|
|
|
|
EXIT SUB
|
|
|
|
AddSpaceForItem:
|
|
IF UBOUND(lPN) < iCount THEN
|
|
IF UBOUND(lPN) = 0 THEN
|
|
ERASE lPN
|
|
END IF
|
|
' Change to REDIM PRESERVE for VB-DOS, QB, QBASIC and PDS 7.1
|
|
REDIM _PRESERVE lPN(1 TO iCount + 9) AS LONG
|
|
END IF
|
|
RETURN
|
|
|
|
|
|
END SUB
|
|
|
|
FUNCTION IsLychrel% (WhichNumber AS LONG)
|
|
' Var
|
|
DIM iMaxC AS INTEGER, iMaxR AS INTEGER
|
|
DIM iCol AS INTEGER, iRow AS INTEGER
|
|
DIM lToCompare AS LONG
|
|
DIM YesItIs AS INTEGER
|
|
DIM sN1 AS STRING, sN2 AS STRING
|
|
SHARED lLC() AS LONG, lMC AS LONG
|
|
|
|
iMaxC = UBOUND(lLC, 2)
|
|
iMaxR = UBOUND(lLC, 1)
|
|
lToCompare = WhichNumber
|
|
IF iMaxC > 0 THEN
|
|
DO
|
|
sN1 = LTRIM$(STR$(lToCompare))
|
|
sN2 = Reverse$(sN1)
|
|
lToCompare = VAL(Sum$(sN1, sN2))
|
|
iCol = 0
|
|
DO
|
|
iCol = iCol + 1
|
|
iRow = 0
|
|
DO
|
|
iRow = iRow + 1
|
|
LOOP UNTIL iRow = iMaxR OR lToCompare = lLC(iRow, iCol)
|
|
LOOP UNTIL iCol = iMaxC OR lToCompare = lLC(iRow, iCol)
|
|
LOOP UNTIL lToCompare >= lMC OR lToCompare = lLC(iRow, iCol)
|
|
YesItIs = (lToCompare <> lLC(iRow, iCol))
|
|
ELSE
|
|
YesItIs = True
|
|
END IF
|
|
|
|
IsLychrel = YesItIs
|
|
|
|
END FUNCTION
|
|
|
|
FUNCTION Reverse$ (WhatToReverse AS STRING)
|
|
' Var
|
|
DIM sChar AS STRING
|
|
DIM sRes AS STRING
|
|
DIM i AS INTEGER, l AS INTEGER
|
|
|
|
l = LEN(WhatToReverse)
|
|
sRes = ""
|
|
FOR i = 1 TO l
|
|
sRes = MID$(WhatToReverse, i, 1) + sRes
|
|
NEXT i
|
|
|
|
Reverse$ = sRes
|
|
END FUNCTION
|
|
|
|
FUNCTION Sum$ (N1 AS STRING, N2 AS STRING)
|
|
' Var
|
|
DIM iN1 AS INTEGER, iN2 AS INTEGER, iSum AS INTEGER
|
|
DIM i AS INTEGER, l AS INTEGER, iCarry AS INTEGER, lM AS LONG
|
|
DIM sRes AS STRING
|
|
|
|
IF LEN(N1) > LEN(N2) THEN
|
|
l = LEN(N1)
|
|
ELSE
|
|
l = LEN(N2)
|
|
END IF
|
|
lM = 2147483647 / 2
|
|
|
|
' Add trailing zeroes (uncomment in case strings have not equal number of digits)
|
|
' N1 = STRING$(l - LEN(N1), 48) + N1
|
|
' N2 = STRING$(l - LEN(N2), 48) + N2
|
|
|
|
' Hace la suma
|
|
IF VAL(N1) < lM THEN
|
|
sRes = LTRIM$(STR$(VAL(N1) + VAL(N2)))
|
|
ELSE
|
|
|
|
FOR i = l TO 1 STEP -1
|
|
iN1 = VAL(MID$(N1, i, 1))
|
|
iN2 = VAL(MID$(N2, i, 1))
|
|
|
|
iSum = iN1 + iN2 + iCarry
|
|
|
|
iCarry = FIX(iSum / 10)
|
|
iSum = iSum MOD 10
|
|
|
|
sRes = LTRIM$(STR$(iSum)) + sRes
|
|
NEXT i
|
|
IF iCarry > 0 THEN sRes = LTRIM$(STR$(iCarry)) + sRes
|
|
END IF
|
|
|
|
Sum$ = sRes
|
|
|
|
END FUNCTION
|