' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
' 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