PureBoard

Code: Alles auswählen

#XAPM_Ident = 42
Enumeration 0 ; XAPM Error Codes
  #XAPM_E_OutOfMem
  #XAPM_E_InvalidXAPM
  #XAPM_E_NonDigitChar
  #XAPM_E_ExpOverflow
EndEnumeration

Structure ByteArray
  b.b[0]
EndStructure
Structure XAPM
  ident.b
  sign.b
  *bcd.ByteArray
  exp.l
  memLen.l
  digits.l
  state.b
EndStructure
Global XAPMG_Precision
Global *wc1.XAPM, *wc2.XAPM
Global *MulDiv.ByteArray
Global *MulRem.ByteArray
Global *MulDiv10.ByteArray
Global *MulRem10.ByteArray
Dim XAPMPA_Msg.s(10)

XIncludeFile "myXAPM.pb.declare"

Procedure.s XAPMD_Digits(*x.XAPM)
  For i = 0 To *x\digits - 1
    s.s + Chr(*x\bcd\b[i] + '0')
  Next
  ProcedureReturn s
EndProcedure

Procedure XAPM_Init()                         ; init various Variables for internal use
  ; Error Messages
  XAPMPA_Msg(#XAPM_E_OutOfMem)     = "Out of Memory"
  XAPMPA_Msg(#XAPM_E_InvalidXAPM)  = "Not a valid XAPM-Variable"
  XAPMPA_Msg(#XAPM_E_NonDigitChar) = "Non-digit char found in String"
  XAPMPA_Msg(#XAPM_E_ExpOverflow)  = "Overflow: Exponent is too large"
  
  ; Globals
  XAPMG_Precision = 80
  
  ; Working Copies
  *wc1 = XAPM_New()
  *wc2 = XAPM_New()
  
  ; LUTs
  *MulDiv10 = AllocateMemory(100)
  *MulRem10 = AllocateMemory(100)
  *MulDiv = AllocateMemory(10000)
  *MulRem = AllocateMemory(10000)
  If *MulDiv = NULL Or *MulRem = #Null Or *MulDiv10 = #Null Or *MulRem10 = #Null
    XAPMP_Error(#XAPM_E_OutOfMem, #True)
  EndIf
  ndiv = 0
  nrem = 0
  For k=0 To 99
    *MulDiv10\b[k] = ndiv
    *MulRem10\b[k] = nrem
    nrem + 1
    If nrem = 10
      nrem = 0
      ndiv + 1
    EndIf
  Next
  
  ndiv = 0
  nrem = 0
  For k=0 To 9999
    *MulDiv\b[k] = ndiv
    *MulRem\b[k] = nrem
    nrem + 1
    If nrem = 100
      nrem = 0
      ndiv + 1
    EndIf
  Next
EndProcedure
Procedure XAPMP_Error(e_nr.l, fatal.b)
  MessageRequester("Error", XAPMPA_Msg(e_nr))
  If fatal
    End
  EndIf
EndProcedure
Procedure XAPM_New()                          ; Create a new dynamic XAPM; Pointer to XAPM is returned
  *x.XAPM = AllocateMemory(SizeOf(XAPM))
  If *x = #Null
    XAPMP_Error(#XAPM_E_OutOfMem, #True)
  EndIf
  *x\bcd = AllocateMemory(XAPMG_Precision)
  If *x\bcd = #Null
    XAPMP_Error(#XAPM_E_OutOfMem, #True)
  EndIf
  *x\ident    = #XAPM_Ident
  *x\sign     =  0
  *x\exp      =  0
  *x\memLen   = XAPMG_Precision
  *x\digits   =  1
  *x\bcd\b[0] =  0
  ProcedureReturn *x
EndProcedure
Procedure XAPM_Free(*x.XAPM)                  ; Frees all Memory of *x
  If *x\ident = 0 Or *x\bcd = #Null Or *x = #Null
    XAPMP_Error(#XAPM_E_InvalidXAPM, #False)
  Else
    *x\ident    = 0
    *x\digits   = 0
    *x\bcd\b[0] = 0
    FreeMemory(*x\bcd)
    *x\bcd = #Null
    FreeMemory(*x)
    *x = #Null
  EndIf
EndProcedure
Procedure XAPM_SetPrecision(precision.l)      ; Sets the used Precision
  XAPMG_Precision = precision
EndProcedure
Procedure XAPM_GetPrecision(precision.l)      ; Returns the currently used Precision
  ProcedureReturn XAPMG_Precision
EndProcedure
Procedure XAPMP_Resize(*x.XAPM, newsize.l)    ; Reallocates the Memory used for the digits
  *x\bcd = ReAllocateMemory(*x\bcd, newsize)
  If *x\bcd = #Null
    XAPMP_Error(#XAPM_E_OutOfMem, #True)
  EndIf
  If newsize < *x\digits
    *x\digits = newsize
  EndIf
  *x\memLen   = newsize
EndProcedure
Procedure XAPM_CleanMem(*x.XAPM)              ; Frees not used Memory of *x
  If *x\memLen > *x\digits
    XAPMP_Resize(*x, *x\digits)
  EndIf
EndProcedure
Procedure XAPM_SetToZero(*x.XAPM)             ; Sets *x to 0
  *x\digits   = 0
  *x\exp      = 0
  *x\sign     = 0
  *x\bcd\b[0] = 0
EndProcedure
Procedure XAPM_Abs(*x.XAPM)                   ; Calculates the absolute Value of *x
  *x\sign = 1
EndProcedure
Procedure XAPM_Negate(*x.XAPM)                ; Multiplies *x with -1
  *x\sign = -*x\sign
EndProcedure
Procedure XAPM_Normalize(*x.XAPM)             ; Removes trailing and leading zeros  (0.xxxxE+/-yy)
  If *x\sign
    lz = 0              ; leading zeros
    tz = *x\digits - 1  ; trailing zeros
    
    While *x\bcd\b[lz] = 0
      lz + 1
    Wend
    While *x\bcd\b[tz] = 0
      tz - 1
    Wend
    tz = (*x\digits - 1) - tz
    digits = *x\digits - lz - tz
    
    dm = AllocateMemory(digits)
    CopyMemory(*x\bcd + lz, dm, digits)
    CopyMemory(dm, *x\bcd, digits)
    FreeMemory(dm)
    *x\digits = digits
    *x\exp = *x\exp - lz
  EndIf
EndProcedure
Procedure XAPMP_Scale(*x.XAPM, newlength.l)   ; Pads *x with leading zeros to newlength
  If newlength > *x\digits
    d = newlength - *x\digits
    If newlength > *x\memLen
      XAPMP_Resize(*x, newlength + 32)
    EndIf
    dm = AllocateMemory(*x\digits)
    CopyMemory(*x\bcd, dm, *x\digits)
    CopyMemory(dm, *x\bcd + d, *x\digits)
    FreeMemory(dm)
    
    *x\exp = *x\exp + d
    *x\digits = newlength
    
    ; initialise BCD-Data with 0 [memset / fillmemory]
    d - 1
    For i = 0 To d
      *x\bcd\b[i] = 0
    Next
  EndIf
EndProcedure
Procedure XAPMP_Pad(*x.XAPM, newlength.l)     ; Pads *x with trailing zeros to newlength
  If newlength > *x\digits
    If newlength > *x\memLen
      XAPMP_Resize(*x, newlength + 32)
    EndIf
    d = newlength - 1
    For i = *x\digits To d
      *x\bcd\b[i] = 0
    Next
    *x\digits = newlength
  EndIf
EndProcedure
Procedure XAPM_Val(*x.XAPM, s.s)              ; Converts a String to XAPM
  s = Trim(s)
  s = RemoveString(s, ",")
  *s.ByteArray = @s
  
  If *s\b[0] = '+'
    sign = 1
    i = 1
  Else
    If *s\b[0] = '-'
      sign = -1
      i = 1
    Else
      sign = 1
      i = 0
    EndIf
  EndIf
  While *s\b[i] = '0'
    i + 1
  Wend
  s = Right(s, Len(s)-i)
  
  ep = FindString(s, "e", 1)
  If ep
    sd.s = Right(s, Len(s) - ep)
    exp = Val(sd)
    s = Left(s, ep - 1)
  EndIf
  
  dp = FindString(s, ".", 1)
  If dp
    *s = @s
    i = Len(s)-1
    While *s\b[i] = '0' And i >= 0
      i - 1
    Wend
    s = Left(s, i+1)
    s = RemoveString(s, ".")
    dp - 1
  Else
    dp = Len(s)
  EndIf
  
  *s = @s
  i = 0
  While *s\b[i] = '0'
    i + 1
  Wend
  s = Right(s, Len(s)-i)
  
  If i <= 1
    i = 0
  EndIf
  exp + dp - i
  
  l = Len(s)
  If l > *x\memLen
    XAPMP_Resize(*x, l + 32)
  EndIf
  
  l - 1
  
  If l < 0
    XAPM_SetToZero(*x)
    ProcedureReturn
  EndIf
  
  *s = @s
  For i = 0 To l
    *x\bcd\b[i] = *s\b[i] - '0'
    If *x\bcd\b[i] > 9
      XAPMP_Error(#XAPM_E_NonDigitChar, #False)
      XAPM_SetToZero(*x)
      ProcedureReturn
    EndIf
  Next
  *x\sign = sign
  *x\exp = exp
  *x\digits = l + 1
EndProcedure
Procedure.s XAPM_Str(*x.XAPM)                 ; Converts a XAPM to String
  If *x\sign = 0
    s.s = "0"
  Else
    If *x\exp = 0
      s.s = "0." + Space(*x\digits)
      *s.ByteArray = @s
      l = *x\digits + 1
      For i=2 To l
        *s\b[i] = *x\bcd\b[i-2] + '0'
      Next
    ElseIf *x\exp > 0
      s.s = Space(*x\digits + 1)
      *s.ByteArray = @s
      l = *x\digits-1
      For i=0 To l
        *s\b[ii] = *x\bcd\b[i] + '0'
        ii + 1
        If ii = *x\exp
          *s\b[ii] = '.'
          ii + 1
        EndIf
      Next
      *s\b[ii] = 0
      If l < *x\exp
        s = LSet(s, *x\exp, "0")
      EndIf
    Else
      s.s = LSet("0.", -*x\exp + 2 + *x\digits, "0")
      *s.ByteArray = @s + -*x\exp + 2
      l = *x\digits-1
      For i=0 To l
        *s\b[i] = *x\bcd\b[i] + '0'
      Next
      *s\b[i] = 0
    EndIf
  EndIf
  If *x\sign < 0
    s = "-" + s
  EndIf
  ProcedureReturn s
EndProcedure
Procedure XAPM_Copy(*s.XAPM, *d.XAPM)         ; Copies *s to *d
  If *s\digits > *d\memLen
    XAPMP_Resize(*d, *s\digits + 32)
  EndIf
  *d\digits = *s\digits
  *d\exp    = *s\exp
  *d\sign   = *s\sign
  *d\state  = *s\state
  CopyMemory(*s\bcd, *d\bcd, *s\digits)
EndProcedure
Procedure XAPM_Compare(*l.XAPM, *r.XAPM)      ; Compares *l with *r and returns 0 if *l = *r or 1 if *l > *r or -1 if *l < *r
  If *r\sign = 0
    ProcedureReturn *l\sign
  EndIf
  If *l\sign = 0
    ProcedureReturn *r\sign
  EndIf
  If *l\sign = -*r\sign
    ProcedureReturn *l\sign
  EndIf
  
  If *l\exp > *r\exp
    ProcedureReturn *l\sign
  ElseIf *l\exp < *r\exp
    ProcedureReturn -*l\sign
  EndIf
  
  If *l\digits < *r\digits
    j = *l\digits - 1
  Else
    j = *r\digits - 1
  EndIf
  
  For i=0 To j
    If *l\bcd\b[i] > *r\bcd\b[i]
      ProcedureReturn *l\sign
    EndIf
    If *l\bcd\b[i] < *r\bcd\b[i]
      ProcedureReturn -*l\sign
    EndIf
  Next
  
  If *l\digits = *r\digits
    ProcedureReturn 0
  Else
    If *l\digits > *r\digits
      ProcedureReturn *l\sign
    Else
      ProcedureReturn -*l\sign
    EndIf
  EndIf
EndProcedure
Procedure XAPM_Add(*a.XAPM, *b.XAPM, *r.XAPM) ; Adds *b to *a
  If *a\sign = 0
    XAPM_Copy(*b, *r)
    ProcedureReturn
  EndIf
  If *b\sign = 0
    XAPM_Copy(*a, *r)
    ProcedureReturn
  EndIf
  
  If *a\sign = 1 And *b\sign = -1
    *b\sign = 1
    XAPM_Sub(*a, *b, *r)
    *b\sign = -1
    ProcedureReturn
  EndIf
  If *a\sign = -1 And *b\sign = 1
    *a\sign = 1
    XAPM_Sub(*b, *a, *r)
    *a\sign = -1
    ProcedureReturn
  EndIf
  
  XAPM_Copy(*a, *wc1)
  XAPM_Copy(*b, *wc2)
  
  If *wc1\exp > *wc2\exp
    XAPMP_Scale(*wc1, *a\digits + 1)
    XAPMP_Scale(*wc2, *b\digits + (*a\exp - *b\exp) + 1)
  ElseIf *wc1\exp < *wc2\exp
    XAPMP_Scale(*wc1, *a\digits + (*b\exp - *a\exp) + 1)
    XAPMP_Scale(*wc2, *b\digits + 1)
  Else
    XAPMP_Scale(*wc1, *a\digits + 1)
    XAPMP_Scale(*wc2, *b\digits + 1)
  EndIf
  
  If *wc1\digits >= *wc2\digits
    XAPM_Copy(*wc1, *r)
  Else
    XAPM_Copy(*wc2, *r)
    d = *wc1
    *wc1 = *wc2
    *wc2 = d
  EndIf
  
  j = *wc2\digits
  Repeat
    j - 1
    *r\bcd\b[j] + carry + *wc2\bcd\b[j]
    If *r\bcd\b[j] >= 10
      *r\bcd\b[j] - 10
      carry = 1
    Else
      carry = 0
    EndIf
    If j = 0
      Break
    EndIf
  ForEver
  XAPM_Normalize(*r)
EndProcedure
Procedure XAPM_Sub(*a.XAPM, *b.XAPM, *r.XAPM) ; Subtracts *b from *a
  If *b\sign = 0
    XAPM_Copy(*a, *r)
    ProcedureReturn
  EndIf
  If *a\sign = 0
    XAPM_Copy(*b, *r)
    *r\sign = -*r\sign
    ProcedureReturn
  EndIf
  If *a\sign = 1 And *b\sign = -1
    *b\sign = 1
    XAPM_Add(*a, *b, *r)
    *b\sign = -1
    ProcedureReturn
  EndIf
  If *a\sign = -1 And *b\sign = 1
    *b\sign = -1
    XAPM_Add(*a, *b, *r)
    *b\sign = 1
    ProcedureReturn
  EndIf
  
  XAPM_Copy(*a, *wc1)
  XAPM_Copy(*b, *wc2)
  *wc1\sign = 1
  *wc2\sign = 1
  
  icompare = XAPM_Compare(*wc1, *wc2)
  If icompare = 0
    XAPM_SetToZero(*r)
    ProcedureReturn
  ElseIf icompare = 1  ; a - b
    sign = *wc1\sign
  Else                 ; b - a
    sign = -*wc1\sign
    d = *wc1
    *wc1 = *wc2
    *wc2 = d
  EndIf
  
  If *wc1\exp > *wc2\exp
    XAPMP_Scale(*wc2, *wc2\digits + *wc1\exp - *wc2\exp)
  ElseIf *wc1\exp < *wc2\exp
    XAPMP_Scale(*wc1, *wc1\digits + *wc2\exp - *wc1\exp)
  EndIf
  
  If *wc1\digits > *wc2\digits
    XAPMP_Pad(*wc2, *wc1\digits)
  ElseIf *wc1\digits < *wc2\digits
    XAPMP_Pad(*wc1, *wc2\digits)
  EndIf
  
  XAPM_Copy(*wc1, *r)
  j = *r\digits
  *r\sign = sign
  Repeat
    j - 1
    itmp = *r\bcd\b[j] - (*wc2\bcd\b[j] + borrow)
    If itmp >= 0
      *r\bcd\b[j] = itmp
      borrow = 0
    Else
      *r\bcd\b[j] = 10 + itmp
      borrow = 1
    EndIf
    If j = 0
      Break
    EndIf
  ForEver

  XAPM_Normalize(*r)
EndProcedure
Procedure XAPM_Mul(*a.XAPM, *b.XAPM, *r.XAPM) ; Multiply *a with *b
  sign = *a\sign * *b\sign
  If sign = 0
    XAPM_SetToZero(*r)
    ProcedureReturn
  EndIf
  
  nexp = *a\exp + *b\exp
  numdigits = *a\digits + *b\digits
  indexa = *a\digits
  indexb = *b\digits
  
  If indexa >= 96 And indexb >= 96
    ;M_fast_multiply(r, a, b)
    ProcedureReturn
  EndIf
  
  numdigits = *a\digits + *b\digits
  If numdigits > *r\memLen
    XAPMP_Resize(*r, numdigits + 32)
  EndIf
  index0 = indexa + indexb
  ; initialise BCD-Data with 0 [memset / fillmemory]
  For i = 0 To index0 - 1
    *r\bcd\b[i] = 0
  Next
  
  ii = indexa
  
  Repeat
    index0 - 1
    *cpr.BYTE = *r\bcd + index0
    jj  = indexb
    ii - 1
    ai  = *a\bcd\b[ii]
    
    Repeat
      jj - 1
      itmp = ai * *b\bcd\b[jj]
      
      *cpr - 1
      *cpr\b + *MulDiv10\b[itmp]
      *cpr + 1
      *cpr\b + *MulRem10\b[itmp]
      
      If *cpr\b >= 10
        *cpr\b - 10
        *cpr - 1
        *cpr\b + 1
        *cpr + 1
      EndIf
      
      *cpr - 1
      
      If *cpr\b >= 10
        *cpr\b - 10
        *cpr - 1
        *cpr\b + 1
        *cpr + 1
      EndIf
      
      If jj = 0
        Break
      EndIf
    ForEver
    If ii = 0
      Break
    EndIf
  ForEver
  
  *r\sign   = sign
  *r\exp    = nexp
  *r\digits = numdigits
  XAPM_Normalize(*r)
EndProcedure

XAPM_Init()
*a.XAPM = XAPM_New()
*b.XAPM = XAPM_New()
*c.XAPM = XAPM_New()

XAPM_Val(*a, "1213.25")
XAPM_Val(*b, "12.123000007")
XAPM_Mul(*a, *b, *c)
Debug XAPM_Str(*c)