Module Calc
    Const cer_Ok = 0, cer_Overflow = 1, cer_LowMemory = 2, cer_DivideBy0 = 3
    Const cer_Quit = 4, cer_Invalid = 5
    Const SIZE = 5000  'max. length of result
    '************************************************************************************
    '*                  A char based calculator program for huge integers               *
    '* -------------------------------------------------------------------------------- *
    '* SAMPLE RUNS:                                                                     *
    '* (Calculate 2 power 4096 and 600!).                                               *
    '*                                                                                  *
    '* First number : 2                                                                 *
    '* Operator     : ^                                                                 *
    '* Second number: 4096                                                              *
    '*                                                                                  *
    '*  POWER: 1,044,388,881,413,152,506,691,752,710,716,624,382,579,964,249,047,383,78 *
    '* 0,384,233,483,283,953,907,971,557,456,848,826,811,934,997,558,340,890,106,714,43 *
    '* 9,262,837,987,573,438,185,793,607,263,236,087,851,365,277,945,956,976,543,709,99 *
    '* 8,340,361,590,134,383,718,314,428,070,011,855,946,226,376,318,839,397,712,745,67 *
    '* 2,334,684,344,586,617,496,807,908,705,803,704,071,284,048,740,118,609,114,467,97 *
    '* 7,783,598,029,006,686,938,976,881,787,785,946,905,630,190,260,940,599,579,453,43 *
    '* 2,823,469,303,026,696,443,059,025,015,972,399,867,714,215,541,693,835,559,885,29 *
    '* 1,486,318,237,914,434,496,734,087,811,872,639,496,475,100,189,041,349,008,417,06 *
    '* 1,675,093,668,333,850,551,032,972,088,269,550,769,983,616,369,411,933,015,213,79 *
    '* 6,825,837,188,091,833,656,751,221,318,492,846,368,125,550,225,998,300,412,344,78 *
    '* 4,862,595,674,492,194,617,023,806,505,913,245,610,825,731,835,380,087,608,622,10 *
    '* 2,834,270,197,698,202,313,169,017,678,006,675,195,485,079,921,636,419,370,285,37 *
    '* 5,124,784,014,907,159,135,459,982,790,513,399,611,551,794,271,106,831,134,090,58 *
    '* 4,272,884,279,791,554,849,782,954,323,534,517,065,223,269,061,394,905,987,693,00 *
    '* 2,122,963,395,687,782,878,948,440,616,007,412,945,674,919,823,050,571,642,377,15 *
    '* 4,816,321,380,631,045,902,916,136,926,708,342,856,440,730,447,899,971,901,781,46 *
    '* 5,763,473,223,850,267,253,059,899,795,996,090,799,469,201,774,624,817,718,449,86 *
    '* 7,455,659,250,178,329,070,473,119,433,165,550,807,568,221,846,571,746,373,296,88 *
    '* 4,912,819,520,317,457,002,440,926,616,910,874,148,385,078,411,929,804,522,981,85 *
    '* 7,338,977,648,103,126,085,903,001,302,413,467,189,726,673,216,491,511,131,602,92 *
    '* 0,781,738,033,436,090,243,804,708,340,403,154,190,336                            *
    '*                                                                                  *
    '* First number : 600                                                               *
    '* Operator     : !                                                                 *
    '*                                                                                  *
    '*  FACTORIAL: 12,655,723,162,254,307,425,418,678,245,150,829,297,671,403,862,274,6 *
    '* 60,768,187,828,858,528,140,823,147,351,237,817,802,795,619,571,074,765,208,532,5 *
    '* 98,060,224,803,240,903,782,164,769,430,795,025,578,054,271,906,283,387,643,826,0 *
    '* 88,448,124,626,488,332,623,608,376,164,081,221,171,179,439,885,840,257,818,732,9 *
    '* 19,037,889,603,719,186,743,943,363,062,139,593,784,473,922,231,852,782,547,619,7 *
    '* 71,723,889,252,476,871,186,000,174,697,934,549,112,845,662,596,182,308,280,390,6 *
    '* 15,184,691,924,446,215,552,586,523,740,084,932,807,259,056,238,962,104,689,731,5 *
    '* 22,587,564,412,231,618,018,774,350,801,526,839,567,367,444,928,206,231,310,973,6 *
    '* 19,440,354,723,718,012,867,753,019,556,135,721,376,207,959,558,860,559,933,052,8 *
    '* 56,914,157,120,622,980,057,169,891,912,595,926,540,427,596,853,441,276,985,006,7 *
    '* 24,869,558,201,930,657,900,240,943,007,657,817,473,684,008,944,448,183,219,124,1 *
    '* 63,017,666,607,770,667,585,082,169,598,239,230,274,035,517,738,648,065,600,492,7 *
    '* 02,095,732,843,492,708,856,036,920,219,883,363,111,527,988,109,277,392,696,562,7 *
    '* 76,813,446,645,651,238,419,301,586,157,342,867,860,646,666,350,050,113,314,787,9 *
    '* 11,320,639,668,510,871,569,846,664,873,595,017,518,995,670,958,477,806,411,667,5 *
    '* 05,346,462,590,471,136,862,647,349,666,243,426,242,677,175,204,732,314,281,064,4 *
    '* 17,939,041,868,653,741,187,423,064,985,189,556,742,640,111,598,580,035,644,021,8 *
    '* 35,576,715,752,869,397,465,453,828,584,471,291,269,955,890,393,294,448,315,746,5 *
    '* 00,268,702,149,708,808,053,100,406,398,480,942,695,623,586,049,403,348,084,970,0 *
    '* 64,668,900,206,251,516,968,479,727,515,576,425,962,392,136,269,169,089,884,609,7 *
    '* 94,271,331,061,018,895,634,421,094,082,310,408,889,752,954,265,842,691,732,460,5 *
    '* 38,911,784,960,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,0 *
    '* 00,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,0 *
    '* 00,000,000,000,000,000,000,000,000,000,000,000,000                               *
    '* -------------------------------------------------------------------------------- *
    '* Ref.: "PC Magazine Turbo Pascal for Windows, Techniques and Utilities By Neil    *
    '*        J. Rubenking, Ziff Davis Press, 1992".                                    *
    '*                                                                                  *
    '*                                   VB 2008 Express Release By J-P Moreau, Paris.  *
    '************************************************************************************
    Sub Main()

        Dim s1 As String
        Dim op As String
        Dim s2 As String
        Dim tmp, remain As String
        Dim flag, Status As Integer

        s1 = "3954242643911239680000"
        op = "/"
        s2 = "635013559600"
        remain = "0"

        FileOpen(1, "pcalc.txt", OpenMode.Output)

        'select relevant operation according to operator
        If op = "+" Then
            add(s1, s2, SIZE, Status)
            PrintLine(1)
            PrintLine(1, " Sum:")
            Display(s1)
            PrintLine(1)
            PrintLine(1, " Status=" + Str$(Status))
        ElseIf op = "-" Then
            substr(s1, s2, SIZE, Status)
            PrintLine(1)
            PrintLine(1, " Diff:")
            Display(s1)
            PrintLine(1)
            PrintLine(1, " Status=" + Str$(Status))
        ElseIf op = "*" Then
            prod(s1, s2, SIZE, Status)
            PrintLine(1)
            PrintLine(1, " Product:")
            Display(s1)
            PrintLine(1)
            PrintLine(1, " Status=" + Str$(Status))
        ElseIf op = "/" Then
            divide(s1, s2, remain, SIZE, Status)
            PrintLine(1)
            PrintLine(1, " Quotient:")
            Display(s1)
            PrintLine(1)
            PrintLine(1, " Remainder:")
            Display(remain)
            PrintLine(1)
            PrintLine(1, " Status=" + Str$(Status))
        ElseIf op = "!" Then
            fact(s1, SIZE, Status)
            PrintLine(1)
            PrintLine(1, " Factorial:")
            Display(s1)
            PrintLine(1)
            PrintLine(1, " Status=" + Str$(Status))
        ElseIf op = "^" Then
            power(s1, s2, SIZE, Status)
            PrintLine(1)
            PrintLine(1, " Power:")
            Display(s1)
            PrintLine(1)
            PrintLine(1, " Status=" + Str$(Status))
        ElseIf op = "a" Then
            PrintLine(1)
            PrintLine(1, " PERMU: ") : flag = 0
            remain = s1 : tmp = s2
            substr(s1, s2, SIZE, Status)               ' s1  contains n-p
            If Mid$(s1, 1, 1) = " " Then Mid$(s1, 1, 1) = "0"
            If Status <> cer_Ok Then flag = 1
            fact(s1, SIZE, Status)                     ' s1 contains (n-p)!
            If Status <> cer_Ok Then flag = 1
            s2 = remain                                ' s2 contains n
            fact(s2, SIZE, Status)                     ' s2 contains n!
            If Status <> cer_Ok Then flag = 1
            divide(s2, s1, remain, SIZE, Status)
            s1 = s2                                    ' s1 contains A(n,p) = n! / (n-p)!
            If Status <> cer_Ok Then flag = 1
            Display(s1)
            PrintLine(1)
            PrintLine(1, " Status=" + Str$(flag))
        ElseIf op = "c" Then
            PrintLine(1)
            PrintLine(1, " COMBI: ") : flag = 0
            remain = s1 : tmp = s2
            substr(s1, s2, SIZE, Status)               ' s1  contains n-p
            If Mid$(s1, 1, 1) = " " Then Mid$(s1, 1, 1) = "0"
            If Status <> cer_Ok Then flag = 1
            fact(s1, SIZE, Status)                     ' s1 contains (n-p)!
            If Status <> cer_Ok Then flag = 1
            s2 = remain                                ' s2 contains n
            fact(s2, SIZE, Status)                     ' s2 contains n!
            If Status <> cer_Ok Then flag = 1
            divide(s2, s1, remain, SIZE, Status)
            s1 = s2                                    ' s1 contains A(n,p) = n! / (n-p)!
            If Status <> cer_Ok Then flag = 1
            fact(tmp, SIZE, Status)
            If Status <> cer_Ok Then flag = 1
            divide(s1, tmp, remain, SIZE, Status)      ' op contains C(n,p)
            Display(s1)
            PrintLine(1)
            PrintLine(1, " Status=" + Str$(flag))
        End If

        PrintLine(1)
        FileClose(1)

    End Sub 'main program

    Sub add(ByRef A As String, ByVal B As String, ByVal MaxLen As Integer, ByRef Status As Integer)
        Call addWTrail(A, B, 0, MaxLen, Status)
    End Sub

    Function AddChar$(ByVal C1 As String, ByVal C2 As String, ByRef carry As Integer)
        Dim tmp As Integer
        carry = 0 'FALSE
        'If C1 < "0" Or C1 > "9" Or C2 < "0" Or C2 > "9" Then Return "0"
        tmp = Asc(C1) + Asc(C2) - 96
        If (tmp >= 10) Then
            tmp = tmp - 10
            carry = 1 'TRUE
        End If
        AddChar$ = Chr(tmp + 48)
    End Function

    Sub AddComma(ByRef WW As String)
        Dim i, posn, MinLoc, newLen As Integer
        newLen = Len(WW)
        posn = newLen + 1
        MinLoc = 3
        If Left$(WW, 1) = "-" Then MinLoc = MinLoc + 1
        While posn > MinLoc And newLen < SIZE
            posn = posn - 3
            'StrMove(WW + succ(posn), WW + posn, succ(newLen - posn))
            WW = WW + " "
            For i = newLen + 1 To posn + 1 Step -1
                Mid$(WW, i, 1) = Mid$(WW, i - 1, 1)
            Next i
            Mid$(WW, posn, 1) = ","
            newLen = newLen + 1
        End While
        If Mid$(WW, 1, 1) = "," Then Mid$(WW, 1, 1) = " "
        If Mid$(WW, 1, 1) = "-" And Mid$(WW, 2, 1) = "," Then Mid$(WW, 1, 2) = " -"
    End Sub 'AddComma

    Sub addWTrail(ByRef A As String, ByVal B As String, ByVal TrailB As Integer, _
                  ByVal MaxLen As Integer, ByRef Status As Integer)
        Dim carry As Integer
        Dim L, LnA, LnB, PsnA, PsnB As Integer
        Dim C, ChA, ChB As String
        Dim TB As String

        LnA = Len(A)
        LnB = Len(B) + TrailB
        L = LnA
        If LnB > L Then L = LnB
        L = L + 1
        For i = 1 To L - LnA
            A = "0" + A
        Next i

        Status = cer_Overflow
        If LnA >= MaxLen - 1 Or LnB >= MaxLen - 1 Or LnA = 0 Or LnB = 0 Then Exit Sub

        Status = cer_Ok
        ' make copy of parameter B and pad with
        ' trailing 0s, if any are required.
        TB = B
        ' FillChar(TB[StrLen(B)], TrailB, '0')
        For i = 1 To TrailB
            TB = TB + "0"
        Next i
        carry = 0 'FALSE

        PsnA = L
        PsnB = LnB

        ' add digits from right to left
        While PsnB >= 0 Or PsnA > 0
            PsnB = PsnB - 1 : PsnA = PsnA - 1
            ChA = Mid$(A, PsnA + 1, 1)
            If (PsnB >= 0) Then
                ChB = Mid$(TB, PsnB + 1, 1)
            Else
                ChB = "0"
            End If
            If carry <> 0 Then
                If PsnA + 1 > 0 And PsnA + 1 <= Len(A) Then
                    Mid$(A, PsnA + 1, 1) = AddChar(Chr(Asc(ChA) + 1), ChB, carry)
                End If
            Else
                If PsnA + 1 > 0 And PsnA + 1 <= Len(A) Then
                    Mid$(A, PsnA + 1, 1) = AddChar(ChA, ChB, carry)
                End If
            End If
        End While
        If carry <> 0 Then Mid$(A, PsnA + 1, 1) = "1"
        Call TrimLead0(A)
    End Sub 'addWTrail

    Function Compare(ByVal X As String, ByVal Y As String) As Integer
        ' Returns -n if X < Y, 0 if equal, +n if X > Y 
        Dim Xl, Yl, Xs, Ys As Integer
        Xl = Len(X) : Xs = 1
        While (Xs <= Xl And Mid$(X, Xs, 1) = "0")
            Xs = Xs + 1
        End While
        Yl = Len(Y) : Ys = 1
        While (Ys <= Yl And Mid$(Y, Ys, 1) = "0")
            Ys = Ys + 1
        End While
        If (Xl - Xs) = (Yl - Ys) Then
            'return(strcmp(X + Xs, Y + Ys))
            If Chr(Asc(X) + Xs) < Chr(Asc(Y) + Ys) Then
                Compare = -1
            ElseIf Chr(Asc(X) + Xs) = Chr(Asc(Y) + Ys) Then
                Compare = 0
            Else
                Compare = 1
            End If
        ElseIf (Xl - Xs) > (Yl - Ys) Then
            Compare = 1
        Else
            Compare = -1
        End If
    End Function 'Compare

    Sub Display(ByVal s As String)
        Const NCAR = 120  'Max. characters per line
        Dim i, j, L As Integer
        AddComma(s)
        L = Len(s)
        j = 0
        For i = 1 To L
            j = j + 1
            Print(1, Mid$(s, i, 1))
            If j >= NCAR Then
                PrintLine(1) 'start a new line
                j = 0
            End If
        Next i
    End Sub

    Sub divide(ByRef A As String, ByVal B As String, ByRef remainder As String, _
               ByVal MaxLen As Integer, ByRef Status As Integer)
        Dim C, T1, T2 As String
        Dim psn1, psn2, LnTl As Integer

        Status = cer_Overflow

        If A = "" Or B = "" Then Return
        Status = cer_DivideBy0
        If Compare(B, "0") = 0 Then Return
        Status = cer_Ok

        If Compare(A, B) = 0 Then
            A = "1"
            remainder = "0"
        ElseIf (Compare(A, B) < 0) Then
            remainder = A
            A = "0"
        Else
            ' A is larger than B 
            LnTl = Len(A) + 3
            T1 = B
            T2 = "1"
            remainder = A
            Status = cer_Ok
            ' While dividend is > Tl. add 0s to Tl and to T2 
            While Compare(A, T1) > 0
                T1 = T1 + "0"
                T2 = T2 + "0"
            End While
            A = "0"
            psn1 = Len(T1) : psn2 = Len(T2)

            ' get individual digits of quotient by repeated 
            ' subtraction of T1. T1 is the divisor with a 
            ' steadily decreasing number of zeros after it. 
            While Compare(T1, B) <> 0 And psn1 > 0 And psn2 > 0
                psn1 = psn1 - 1 : psn2 = psn2 - 1
                T1 = Left$(T1, psn1) : T2 = Left$(T2, psn2)
                While Compare(remainder, T1) >= 0
                    substr(remainder, T1, MaxLen, Status)
                    C = Left$(remainder, 1)
                    If C < "0" Or C > "9" Then Mid$(remainder, 1, 1) = "0"
                    TrimLead0(remainder)
                    If Status <> cer_Ok Then Return
                    add(A, T2, MaxLen, Status)
                    If Status <> cer_Ok Then Return
                End While
            End While
        End If
    End Sub 'divide

    Sub fact(ByRef A As String, ByVal MaxLen As Integer, ByRef Status As Integer)
        Dim TA As String
        Dim LnA As Integer

        Status = cer_Overflow
        If A = "" Then Return

        LnA = Len(A) + 3

        Status = cer_Ok

        TA = A
        A = "1"

        If Compare(TA, "0") <> 0 Then
            While Compare(TA, "1") <> 0 And Status = cer_Ok
                prod(A, TA, MaxLen, Status)
                substr(TA, "1", LnA - 1, Status)
                If Left$(TA, 1) = " " Then Mid$(TA, 1, 1) = "0"
                TrimLead0(TA)
            End While
        End If

    End Sub 'fact 

    Sub power(ByRef B As String, ByVal E As String, ByVal MaxLen As Integer, ByRef Status As Integer)
        Dim TH, TR, TS As String
        Dim LnT, Ex, i As Integer

        Status = cer_Overflow
        If B = "" Or E = "" Then Return

        Status = cer_Ok
        If Mid$(B, 1, 1) = "0" Or Mid$(E, 1, 1) = "0" Then
            B = "1"
            Return
        End If
        LnT = Len(E) + 3

        TH = E : TS = B : TR = "" : B = "1"

        ' calculate power by halving and squaring
        While Compare(TH, "0") > 0 And Status = cer_Ok
            'halve the exponent
            divide(TH, "2", TR, LnT - 1, Status)
            'if it was odd, multiply T3 by current value of T1
            If Compare(TR, "1") = 0 Then
                prod(B, TS, MaxLen, Status)
            End If
            'square(T1)
            prod(TS, TS, MaxLen, Status)
        End While

    End Sub 'power

    Sub prod(ByRef A As String, ByVal B As String, ByVal MaxLen As Integer, ByRef Status As Integer)
        Dim TB, TA As String
        Dim i, PsnB, N, times, LnA, LnB, L As Integer

        If Status <> cer_Ok Then Return

        LnA = Len(A)
        LnB = Len(B)

        If LnA + LnB >= MaxLen Or LnA = 0 Or LnB = 0 Then Return
        ' multiply larger by smaller 
        If (Compare(A, B) < 0) Then
            TB = A : A = B
            L = LnA
            LnA = LnB
            LnB = L
        Else
            TB = B
        End If
        TA = A
        L = LnA + LnB

        A = "0"
        For i = 2 To L
            A = A + "0"
        Next

        ' for each digit of multiplier, right to left, 
        ' add together an appropriate number of copies 
        ' of multiplicand, tack the right number of 
        ' zeros on the end, and add the result to the 
        ' running total in T2.
        PsnB = LnB
        While PsnB > 0 And Status = cer_Ok
            PsnB = PsnB - 1
            times = Val(Mid$(TB, PsnB + 1, 1))
            For N = 1 To times
                addWTrail(A, TA, LnB - 1 - PsnB, MaxLen, Status)
            Next N
        End While

        TrimLead0(A)

    End Sub 'prod

    Sub substr(ByRef A As String, ByVal B As String, ByVal MaxLen As Integer, ByRef Status As Integer)
        Dim i, L, LnA, LnB As Integer
        Dim TB As String
        Dim PsnA, PsnB, borrow, minus As Integer
        Dim C, ChA, ChB As String

        LnA = Len(A)
        LnB = Len(B)

        If LnA >= MaxLen - 1 Or LnB >= MaxLen - 1 Or LnA = 0 Or LnB = 0 Then Return
        ' subtract smaller from larger 
        If Compare(A, B) < 0 Then
            TB = A : A = B
            L = LnA
            LnA = LnB
            LnB = L
            minus = 1 'TRUE
        Else
            TB = B
            minus = 0 'FALSE
        End If

        Status = cer_LowMemory
        If Len(TB) = 0 Then Return
        Status = cer_Ok
        borrow = 0 'FALSE 
        L = LnA

        If LnB > L Then L = LnB
        L = L + 1 : A = A + " "

        ' "Grow" A to hold result 
        ' memcpy(A+(Len-LnA), A, LnA+1)
        For i = L To L - LnA + 1 Step -1
            'A(i) = A(i-L+LnA)
            C = Mid$(A, i - L + LnA, 1)
            Mid$(A, i, 1) = C
        Next i

        ' FillChar(A^, Len-LnA, '0')
        For i = 1 To L - LnA
            'A(i)="0"
            Mid$(A, i, 1) = "0"
        Next i

        PsnA = L
        PsnB = LnB

        ' subtract digits fram right to left 
        While (PsnB >= 0 Or PsnA > 0)
            PsnA = PsnA - 1 : PsnB = PsnB - 1

            If (PsnA >= 0) Then
                ChA = Mid$(A, PsnA + 1, 1)
            Else
                ChA = "0"
            End If

            If (PsnB >= 0) Then
                ChB = Mid$(TB, PsnB + 1, 1)
            Else
                ChB = "0"
            End If
            If (borrow <> 0) Then
                Mid$(A, PsnA + 1, 1) = SubChar(Chr(Asc(ChA) - 1), ChB, borrow)
            Else
                Mid$(A, PsnA + 1, 1) = SubChar(ChA, ChB, borrow)
            End If
        End While
        PsnA = 0

        If (minus <> 0) Then
            Mid$(A, 1, 1) = "-"
        Else
            Mid$(A, 1, 1) = " "
        End If
        If A = "" Then A = "0"

        Call TrimLead0(A)

    End Sub

    Function SubChar$(ByVal C1 As String, ByVal C2 As String, ByRef borrow As Integer)
        Dim tmp As Integer
        borrow = 0 'FALSE
        tmp = Asc(C1) - Asc(C2)
        If (tmp < 0) Then
            tmp = tmp + 10
            borrow = 1 'TRUE
        End If
        SubChar$ = Chr(tmp + 48)
    End Function

    Sub TrimLead0(ByRef P As String)
        'Trims leading zeros from a string P
        Dim i, L As Integer
        i = 1
        L = Len(P)
        While i <= L And Mid$(P, i, 1) = "0"
            i = i + 1
        End While
        P = Right$(P, L - i + 1)
    End Sub

End Module 'Calc