Resolved: Decimals to Fractions

[VictorB212]

Does anyone know of any good code to convert decimals to fractions? I've come up with a way, but it's kind of sloppy...

Any help would be appreciated.

[NotLKH]

Up to How Many Decimal Places?

-Lou

[VictorB212]

To VB's limit of accuracy. For example, it could figure out the fraction from the VB's result of 123/234. In other words, if I get the solution from 123/234 in the immediate window, and fed it to the function, it would give me the fraction back (reduced form of course ). Is that clear enough?

[Kaverin]

I don't know how how sloppy your idea of sloppy is (I can sure guess, being guilty of making slop myself), but this works just to get a fraction. It might even be the a similar thing to what you do. It won't do the LCD on the numerator and denominator though. I thought I had LCD/GCF functions around somewhere, but I can't find em anymore .

Public Function GetFraction(ByVal dblDecimal As Double) As String
   Dim lngCount As Long
   GetFraction = ""
   lngCount = 0
   Do While InStr(CStr(dblDecimal), ".")
      dblDecimal = dblDecimal * 10
      lngCount = lngCount + 1
   Loop
   GetFraction = CStr(dblDecimal) & "/" & CStr(10 ^ lngCount)
End Function

This will handle something with up to 14 decimal places, and then it goes screwy and puts in the scientific notation. The fraction is still accurate though, but not in a pretty form anymore

[VictorB212]

That's too sloppy. If I give it .666666666666 it doesn't give me 2/3.

Here's my code:

Public Function QuickSort(vData As Variant, Low As Long, Hi As Long)
  If Not IsArray(vData) Then Exit Function
 
  Dim lTmpLow As Long
  Dim lTmpHi As Long
  Dim lTmpMid As Long
  Dim vTempVal As Variant
  Dim vTmpHold As Variant
  
  lTmpLow = Low
  lTmpHi = Hi
  
  If Hi <= Low Then Exit Function
 
  lTmpMid = (Low + Hi) \ 2
      
  vTempVal = vData(lTmpMid)
      
  Do While (lTmpLow <= lTmpHi)
 
     Do While (vData(lTmpLow) < vTempVal And lTmpLow < Hi)
           lTmpLow = lTmpLow + 1
     Loop
      
     Do While (vTempVal < vData(lTmpHi) And lTmpHi > Low)
           lTmpHi = lTmpHi - 1
     Loop
            
     If (lTmpLow <= lTmpHi) Then
         vTmpHold = vData(lTmpLow)
         vData(lTmpLow) = vData(lTmpHi)
         vData(lTmpHi) = vTmpHold
         lTmpLow = lTmpLow + 1
         lTmpHi = lTmpHi - 1
     End If
     
  Loop
          
  If (Low < lTmpHi) Then
      QuickSort vData, Low, lTmpHi
  End If
          
  If (lTmpLow < Hi) Then
       QuickSort vData, lTmpLow, Hi
  End If
  
End Function
 
Public Function cFrac(Expr As Double) As String
 
    Dim i As Long, j As Long
    Dim v As Variant
    Dim x As Double
    Dim curVal As Double
    Dim minVal As Double
    Dim intVal As Double
    Dim idx As Long
    Dim s As String
    Dim arr() As String
    Dim arrIdx As Long
    
    ReDim arr(0)
    
    x = Expr
    intVal = Int(x)
    x = x - intVal
    For i = 1 To 3000
        For j = 1 To i
            If Abs(x - j / i) < 0.00001 Then
                arr(arrIdx) = String$(4 - Len(CStr(j)), "0") & j & "/" & i
                arrIdx = arrIdx + 1
                ReDim Preserve arr(arrIdx)
            End If
        Next
    Next
    
    
    arrIdx = arrIdx - 1
    ReDim Preserve arr(arrIdx)
    
    QuickSort arr, 0, arrIdx
    
    minVal = 0.0001
    For i = 0 To arrIdx
        v = Split(arr(i), "/")
        curVal = Abs(v(0) / v(1) - x)
        If curVal < minVal Then
            minVal = curVal
            idx = i
        End If
    Next
    
    s = arr(idx)
    i = 1
    Do Until Mid(s, i, 1) > 0
        s = Right$(s, Len(s) - 1)
    Loop
    v = Split(s, "/")
    v(0) = v(0) + v(1) * intVal
    s = v(0) & "/" & v(1)
    cFrac = s
    Beep
End Function

The decimal 0.00001 can be adjusted.

[Kaverin]

I messed with it some more, and fixed that SF weirdness. The fix is in bright blue:

Public Function GetFraction(ByVal dblDecimal As Double) As String
   Dim lngCount As Long
   [color=blue]Dim strDenominator As String
   Dim intNumZeroes As Integer[/color]
   GetFraction = ""
   lngCount = 0
   Do While InStr(CStr(dblDecimal), ".")
      dblDecimal = dblDecimal * 10
      lngCount = lngCount + 1
   Loop
[color=blue]   strDenominator = CStr(10 ^ lngCount)
   If InStr(1, strDenominator, "E", vbTextCompare) Then
      intNumZeroes = Val(Right$(strDenominator, Len(strDenominator) - InStr(strDenominator, "+")))
      strDenominator = "1" & String$(intNumZeroes, "0")
   End If[/color]
   GetFraction = CStr(dblDecimal) & "/" & [color=blue]strDenominator[/color]
End Function

[VictorB212]

That won't give you "2/3" for .666666666666 though...

[Kaverin]

You do have a point there about the 2/3 thing, but when you do that mentally, you've changed the value. I know mathematically that 0.666666... = 2/3 though. It's very easy to prove with some algebra. The thing I mentioned though does it exactly. I just wish I could remember a fast way to get the LCD of the numbers, then what I mentioned might be usable . I just did some other checking, and if you're going for the best significance, yours gets a little fudgy past 6 places. 4*atn(1) (3.14159265358979 - as significant as VB will report pi) will come out as 355/113 with your function. But if you do that expression, you get only 3.141593 back.

[VictorB212]

Did you try the code I posted?

[VictorB212]

Check this code out (adjust the constant for accuracy/speed):

Public Function CFrac2(ByVal X As Double) As String
 
    Dim Q As Double 'Quotient
    Dim D As Long   'Denominator
    Dim N As Long   'Numberator
    
    D = 1
    N = 1
    
    Q = N / D
    
    Do While Abs(Q - X) > 0.00000000001
       If (Q < X) Then
          N = N+ 1
       Else
          D = D + 1
       End If
       Q = N / D
    Loop
   
    CFrac2 = CStr(N) & "/" & CStr(D)
End Function

[Nucleus]

Nice Vic

Just added support for negative fractions and zero.

Public Function CFrac2(ByVal Y As Double) As String
 
    Dim Q As Double 'Quotient
    Dim D As Long   'Denominator
    Dim N As Long   'Numerator
    Dim X As Double
    
    If Y <> 0 Then
        
        X = Abs(Y)
    
        D = 1
        N = 1
    
        Q = D / N
    
        Do While Abs(Q - X) > 0.00000000001
            If (Q < X) Then
                D = D + 1
            Else
                N = N + 1
            End If
            Q = D / N
        Loop
   
        If Y < 0 Then CFrac2 = "-"
        CFrac2 = CFrac2 & CStr(D) & "/" & CStr(N)
        
    Else
    
        CFrac2 = 0
        
    End If
        
End Function

[Kaverin]

That's probably the best way to do it. After playing with mine, I managed to get it to give exact fractions, but I ended up having to make up other functions to get around some limits I was using Mod in my function to get the GCF in order to reduce the fraction, and needed to make something to handle doubles. After that then, I could get the scientific notation thing to creep up in the numerator with values with enough decimal places, so I figured the effort was starting to outweigh the use. Running along side each other though, and timing with GetTickCount, I kept getting 0 out of mine, and up to .5 s with yours. I would save the GTC, then do the function, and immediately get GTC once more for the timing. This is what I ended up using as mine (without the SF removal part). If anything, at least you may find the GCF function useful later. It uses Euclid's algorithm.

Public Function GetFraction(ByVal dblDecimal As Double) As String
   Dim lngCount As Long
   Dim dblDenominator As Double, dblNumerator As Double
   Dim dblGCF As Double
   GetFraction = ""
   lngCount = 0
   Do While InStr(CStr(dblDecimal), ".")
      dblDecimal = dblDecimal * 10
      lngCount = lngCount + 1
   Loop
   dblDenominator = 10 ^ lngCount
   dblGCF = GCF(dblDecimal, dblDenominator)
   dblDenominator = dblDenominator / dblGCF
   dblNumerator = dblDecimal / dblGCF
   GetFraction = CStr(dblNumerator) & "/" & CStr(dblDenominator)
End Function
 
Public Function GCF(ByVal dblX As Double, ByVal dblY As Double) As Double
   Dim dblPass As Double
   dblX = Abs(dblX)
   dblY = Abs(dblY)
   Do While dblX > 0
      dblPass = dblX
      dblX = DBLMod(dblY, dblX)
      dblY = dblPass
   Loop
   GCF = dblPass
End Function
 
Public Function DBLMod(ByVal dblNumber As Double, ByVal dblDivisor As Double) As Double
   DBLMod = dblNumber - (Int(dblNumber / dblDivisor) * dblDivisor)
End Function

It seems to work for around 10-12 decimal places or so with some variance. Then the SF creeps in.

[VictorB212]

This code came to me once I looked at the above code I had made. My original code was testing a lot of stuff multiple times (2/3,4/6,6/9, etc.), so I looked for a way to speed it up, and this "zeroing in" method works beautifully. I wonder if putting it in C++ will make it faster...

I found a pretty good fraction for pi using a precision of 1E-16:

245850922/78256779

I think I can mark this problem resolved. Maybe I could start a trend; it could help when searching for stuff (to know if the problem in the thread was resolved).

[ALFWare]

This code is lightning fast, I mean like it doesn't even take a second, I have tried lots of code all that do loop and counts down by one and all this, but this is freaky.

Try it I promise you it works also
.33333 returns 33333/100000
whereas
.333333 return 1/3
same for all your reoccurances like:
.123123123..... returns 41/33

' Converts a decimal value into fractional parts as integers
' (based on the concept of Continued Fractions)

' Examples of usage:

' Call DeclToFrac(0.125, a, b)   ' 1 and 8 are returned in a & b
' Call DecToFrac(5/40, a, b)     ' 1 and 8 are also returned
' Call DecToFrac(2/3, a, b)      ' 2 and 3 are returned



' Since more than one value needs to be returned, they are returned
' to variables which are passed by reference as arguments (Numerator
' and Denom) to the DecToFrac Sub procedure

Sub DecToFrac(DecimalNum As Double, Numerator As Long, Denom As Long)

   ' The BigNumber constant can be adjusted to handle larger fractional parts
   Const BigNumber = 50000
   Const SmallNumber = 1E-16

   Dim Inverse As Double, FractionalPart As Double
   Dim WholePart As Long, SwapTemp As Long

   Inverse = 1 / DecimalNum
   WholePart = Int(Inverse)
   FractionalPart = Frac(Inverse)

   If 1 / (FractionalPart + SmallNumber) < BigNumber Then
        ' Notice that DecToFrac is called recursively.  
        Call DecToFrac(FractionalPart, Numerator, Denom)
        Numerator = Denom * WholePart + Numerator

        SwapTemp = Numerator
        Numerator = Denom
        Denom = SwapTemp
   Else ' If 1 / (FractionalPart + SmallNumber) > BigNumber
        ' Recursion stops when the final value of FractionalPart is 0 or
        ' close enough.  SmallNumber is added to prevent division by 0.
        Numerator = 1
        Denom = Int(Inverse)
   End If
End Sub

' This function is used by DecToFrac and DecToProperFact

Function Frac(x As Double) As Double
    Frac = Abs(Abs(x) - Int(Abs(x)))
End Function

' This additional procedure handles "improper" fractions and returns
' them in mixed form (a b/c) when the numerator is larger than the denominator

Sub DecToProperFrac(x As Double, a As Long, b As Long, c As Long)
   If x > 1 Then a = Int(x)
   If Frac(x) <> 0 Then 
      Call DecToFrac(Frac(x), b, c)
   End If
End Sub

'#####################################################################
'#
'# This item has been brought to you by Daniel Corbier, the author of
'# UCalc Fast Math Parser, a component which allows programs to
'# evaluate expressions that are defined at runtime. You can learn
'# more and download a fully functional copy at www.ucalc.com/mathparser
'#
'#####################################################################

[Guv]

If you are willing to write code that checks for repeating patterns, it is easy to generate the formula which will convert to rational numbers. Patterns like the following are pretty straight forward.

1/3 = .3333 (3/10)/.9 = 3/9
2/3 = .66666 (6/10)/.9 = 6/9
4/33 = .12121212 (12/100)/.99 = 12/99
1/7 = .142857142857 (142857/1000000)/.999999 = 142857/999999

You need a function which can find common factors and divide them out.

If there is no pattern, the best you can do is the following

abc/1000 = .abc
abcd/10000 = .abcd
abcde/100000 = .abcde

[ALFWare]

That code isn't just for reoccuring decimals... it converts any fraction and does it very well, with the Lowest Common Denominator.