Alternative Complex Algebra for Excel

in VBAProject.Modules.Module1
_{PS! not 100% verified}

---

Option Explicit
Option Base 0

Private Type zComplex
x As Double
y As Double
m As Double
a As Double
d As String ' ~ ~ ~~ was used for Debugging the Parser ~~ ~ ~
End Type

Public Const zTanPi6# = 0.577350269189626
Public Const zArgSqi# = 3.14159265358979

Public Function LRound&(ByVal x#)
Dim s&, a&
s = 1 + 2 * (x < 0) + (x = 0)
If s <> 0 Then
  x = Abs(x)
  a = Fix(x)
  x = x - a
  a = s * (a - Not (x < 0.5))
Else
  a = s
End If
LRound = a
End Function

Public Function dec2str$(ByVal x#)
Dim s&, r$, rr$
Dim e#, ee&
s = 1 + 2 * (x < 0) + (x = 0)
If s <> 0 Then
  x = Abs(x)
  e = Log(x) / Log(10)
  ee = Int(e)
  If ee = 0 Then
    rr = ""
  ElseIf ee < 0 Then
    x = x * Expo(-ee)
    rr = "E" & Trim(Str(ee))
  Else
    x = x * Expo(-ee)
    rr = "E+" & Trim(Str(ee))
  End If
  r = Trim(Str(x)) & rr
  If s < 0 Then r = "-" & r Else
Else
  r = "0"
End If
dec2str = r
End Function

Public Function zPi() As Double
zPi = Atn(zTanPi6) * 6
End Function

Public Function Sq(ByVal x As Double) As Double
Sq = x * x
End Function

' ----------------- .
' **** Complex **** .
' ----------------- .

' *   *  * ** *** the procedures that can be used in VBA *** ** *  *   *

' *(97)*
Public Function zRe(ByRef z As zComplex) As Double: zRe = z.x: End Function
' *(98)*
Public Function zIm(ByRef z As zComplex) As Double: zIm = z.y: End Function
' *(1)*
Public Function zArg(ByRef z As zComplex) As Double
Dim r As Double
If z.y = 0 Then
  If z.x < 0 Then
    r = zArgSqi
  Else
    r = 0
  End If
ElseIf z.x = 0 Then
  r = zArgSqi / 2
  If z.y < 0 Then
    r = -r
  End If
Else
  r = Atn(z.y / z.x)
  If z.x < 0 Then
    If z.y < 0 Then
      r = r - zArgSqi
    Else
      r = r + zArgSqi
    End If
  End If
End If
zArg = r
End Function
' *(2)*
Public Sub zEqu(ByRef z As zComplex, ByVal x As Double, ByVal y As Double): z.x = x: z.y = y: End Sub
' *(3)*
Public Sub zDup(ByRef z As zComplex, ByRef w As zComplex): z.x = w.x: z.y = w.y: End Sub
' *(4)*
Public Sub zNeg(ByRef z As zComplex): z.x = -z.x: z.y = -z.y: End Sub
' *(5)*
Public Sub zCon(ByRef z As zComplex): z.y = -z.y: End Sub
' *(6)*
Public Sub zAdd(ByRef z As zComplex, ByRef w As zComplex): z.x = z.x + w.x: z.y = z.y + w.y: End Sub
' *(7)*
Public Sub zSub(ByRef z As zComplex, ByRef w As zComplex): z.x = z.x - w.x: z.y = z.y - w.y: End Sub
' *(8)*
Public Sub zMul(ByRef z As zComplex, ByRef w As zComplex)
z.a = w.x * z.x - w.y * z.y: z.m = w.x * z.y + w.y * z.x
z.x = z.a: z.y = z.m: z.a = 0: z.m = 0
End Sub
' *(9)*
Public Sub zScl(ByRef z As zComplex, ByVal a As Double): z.x = z.x * a: z.y = z.y * a: End Sub
' *(10)*
Public Function zSqM(ByRef z As zComplex) As Double: zSqM = Sq(z.x) + Sq(z.y): End Function
' *(11)*
Public Function zMdl(ByRef z As zComplex) As Double: zMdl = Sqr(Sq(z.x) + Sq(z.y)): End Function
' *(12)*
Public Sub zDiv(ByRef z As zComplex, ByRef w As zComplex)
Dim a As Double: zCon w: zMul z, w: a = 1 / zSqM(w): zScl z, a
End Sub
' *(13)*
Public Sub zInv(ByRef z As zComplex)
Dim a As Double: zCon z: a = 1 / zSqM(z): zScl z, a
End Sub
' *(14)*
Public Sub zIntPow(ByRef z As zComplex, ByVal n As Double)
z.m = zMdl(z): z.a = zArg(z)
z.m = Exp(Log(z.m) * n): z.a = z.a * n
z.x = z.m * Cos(z.a): z.y = z.m * Sin(z.a)
z.m = 0: z.a = 0
End Sub
' *(15)*
Public Sub zIntRoot(ByRef z As zComplex, ByVal n As Double, ByVal k As Double)
z.m = zMdl(z): z.a = zArg(z)
z.m = Exp(Log(z.m) / n): z.a = (z.a + 2 * k * zArgSqi) / n
z.x = z.m * Cos(z.a): z.y = z.m * Sin(z.a)
z.m = 0: z.a = 0
End Sub
' *(16)*
Public Sub zPow(ByRef z As zComplex, ByRef w As zComplex)
z.m = Log(zMdl(z)): z.a = zArg(z)
w.m = Exp(w.x * z.m - w.y * z.a): w.a = w.y * z.m + w.x * z.a
z.x = w.m * Cos(w.a): z.y = w.m * Sin(w.a)
z.m = 0: z.a = 0: w.m = 0: w.a = 0
End Sub

' ----------------- .
' **** Complex **** .
' ----------------- .

Private Function unSpace(ByVal s As String) As String: Dim lg&, ii&, rr$, ss$
lg = Len(s): rr = "": For ii = 1 To lg: ss = Mid(s, ii, 1)
If ss <> " " Then rr = rr & ss Else
Next ii: unSpace = rr
End Function

Public Function Expo#(ByVal n As Double)
Dim p&, m&
Dim b#, r#
p = 1 + 2 * (n < 0) + (n = 0)
m = Fix(Abs(n))
b = 10#: r = 1#
If Not (p = 0) Then
  While m > 0
    If (m And 1) > 0 Then
      r = r * b
    End If
    If m > 1 Then
      b = b * b
    End If
    m = m \ 2
  Wend
  If p < 0 Then r = 1 / r Else
End If
Expo = r
End Function

Private Function pzGetSgn#(ByVal s$, ByVal p&)
pzGetSgn = 44 - Asc(Mid(s, p))
End Function

Private Sub parseComplex(ByRef z As zComplex, ByVal s As String)
Dim ls&, lgt&, ndx&(10), dxp
Dim ii&, ss$, cc, pc$, mk$, pm$, cm$, ix$
Dim a#, b#, c#
s = unSpace(s): s = UCase(s): ls = Len(s): pm = ""
dxp = 0: ix = "": pc = "~"
For ii = 1 To ls
  ss = Mid(s, ii, 1): cc = Asc(ss)
  If ((cc > 47) And (cc < 58)) Or (cc = 46) Then
    mk = "N"
  ElseIf (cc = 43) Or (cc = 45) Then
    mk = "S"
  ElseIf cc = 69 Then
    mk = "E"
  ElseIf cc = 73 Then
    mk = "D"
  Else
    mk = "X"
  End If
  If mk <> pc Then
    ndx(dxp) = ii
    ix = ix & Hex(ii) ' ~New ~New ~New ~New
    dxp = dxp + 1
  End If
  pm = pm & mk
  pc = mk
Next ii
lgt = Len(pm): cm = "": pc = 0
For ii = 1 To lgt
  ss = Mid(pm, ii, 1): cc = Asc(ss)
  If Not ((cc = 78) And (pc = 78)) Then
    cm = cm & ss
  End If
  pc = cc
Next ii
Select Case cm
Case "D"
  z.x = 0
  z.y = 1
Case "N"
  z.x = Val(s)
  z.y = 0
Case "ND"
  z.x = 0
  z.y = Val(Left(s, ndx(1) - 1))
Case "NESN"
  z.x = Val(Left(s, ndx(1) - 1)) * Expo(pzGetSgn(s, ndx(2)) * Val(Right(s, ls - ndx(3) + 1)))
  z.y = 0
Case "NESND"
  z.x = 0
  z.y = Val(Left(s, ndx(1) - ndx(0)))
  z.y = z.y * Expo(pzGetSgn(s, ndx(2)) * Val(Mid(s, ndx(3), ndx(4) - ndx(3))))
Case "NESNSD":
  z.x = Val(Left(s, ndx(1) - ndx(0)))
  z.x = z.x * Expo(pzGetSgn(s, ndx(2)) * Val(Mid(s, ndx(3), ndx(4) - ndx(3))))
  z.y = pzGetSgn(s, ndx(4))
Case "NESNSND":
  z.x = Val(Left(s, ndx(1) - ndx(0)))
  z.x = z.x * Expo(pzGetSgn(s, ndx(2)) * Val(Mid(s, ndx(3), ndx(4) - ndx(3))))
  z.y = pzGetSgn(s, ndx(4)) * Val(Mid(s, ndx(5), ndx(6) - ndx(5)))
Case "NESNSNESND":
  z.x = Val(Left(s, ndx(1) - ndx(0)))
  z.x = z.x * Expo(pzGetSgn(s, ndx(2)) * Val(Mid(s, ndx(3), ndx(4) - ndx(3))))
  z.y = pzGetSgn(s, ndx(4)) * Val(Mid(s, ndx(5), ndx(6) - ndx(5)))
  z.y = z.y * Expo(pzGetSgn(s, ndx(7)) * Val(Mid(s, ndx(8), ndx(9) - ndx(8))))
Case "NSD"
  z.x = Val(Left(s, ndx(1) - 1))
  z.y = pzGetSgn(s, ndx(1))
Case "NSND"
  z.x = Val(Left(s, ndx(1) - 1))
  z.y = pzGetSgn(s, ndx(1)) * Val(Mid(s, ndx(2), ndx(3) - ndx(2)))
Case "NSNESND"
  z.x = Val(Left(s, ndx(1) - 1))
  z.y = pzGetSgn(s, ndx(1)) * Val(Mid(s, ndx(2), ndx(3) - ndx(2)))
  z.y = z.y * Expo(pzGetSgn(s, ndx(4)) * Val(Mid(s, ndx(5), ndx(6) - ndx(5))))
Case "SD"
  z.x = 0
  z.y = pzGetSgn(s, ndx(0))
Case "SN"
  z.x = pzGetSgn(s, ndx(0)) * Val(Right(s, ls - ndx(0)))
  z.y = 0
Case "SND"
  z.x = 0
  z.y = pzGetSgn(s, ndx(0)) * Val(Mid(s, ndx(1), ndx(2) - ndx(1)))
Case "SNESN"
  z.x = pzGetSgn(s, ndx(0)) * Val(Mid(s, ndx(1), ndx(2) - ndx(1)))
  z.x = z.x * Expo(pzGetSgn(s, ndx(3)) * Val(Right(s, ls - ndx(3))))
  z.y = 0
Case "SNESND"
  z.x = 0
  z.y = pzGetSgn(s, ndx(0)) * Val(Mid(s, ndx(1), ndx(2) - ndx(1)))
  z.y = z.y * Expo(pzGetSgn(s, ndx(3)) * Val(Mid(s, ndx(4), ndx(5) - ndx(4))))
Case "SNESNSD"
  z.x = pzGetSgn(s, ndx(0)) * Val(Mid(s, ndx(1), ndx(2) - ndx(1)))
  z.x = z.x * Expo(pzGetSgn(s, ndx(3)) * Val(Mid(s, ndx(4), ndx(5) - ndx(4))))
  z.y = pzGetSgn(s, ndx(5))
Case "SNESNSND"
  z.x = pzGetSgn(s, ndx(0)) * Val(Mid(s, ndx(1), ndx(2) - ndx(1)))
  z.x = z.x * Expo(pzGetSgn(s, ndx(3)) * Val(Mid(s, ndx(4), ndx(5) - ndx(4))))
  z.y = pzGetSgn(s, ndx(5)) * Val(Mid(s, ndx(6), ndx(7) - ndx(6)))
Case "SNESNSNESND"
  z.x = pzGetSgn(s, ndx(0)) * Val(Mid(s, ndx(1), ndx(2) - ndx(1)))
  z.x = z.x * Expo(pzGetSgn(s, ndx(3)) * Val(Mid(s, ndx(4), ndx(5) - ndx(4))))
  z.y = pzGetSgn(s, ndx(5)) * Val(Mid(s, ndx(6), ndx(7) - ndx(6)))
  z.y = z.y * Expo(pzGetSgn(s, ndx(8)) * Val(Mid(s, ndx(9), ndx(10) - ndx(9))))
Case "SNSD"
  z.x = pzGetSgn(s, ndx(0)) * Val(Mid(s, ndx(1), ndx(2) - ndx(1)))
  z.y = pzGetSgn(s, ndx(2))
Case "SNSND"
  z.x = pzGetSgn(s, ndx(0)) * Val(Mid(s, ndx(1), ndx(2) - ndx(1)))
  z.y = pzGetSgn(s, ndx(2)) * Val(Mid(s, ndx(3), ndx(4) - ndx(3)))
Case "SNSNESND"
  z.x = pzGetSgn(s, ndx(0)) * Val(Mid(s, ndx(1), ndx(2) - ndx(1)))
  z.y = pzGetSgn(s, ndx(2)) * Val(Mid(s, ndx(3), ndx(4) - ndx(3)))
  z.y = z.y * Expo(pzGetSgn(s, ndx(5)) * Val(Mid(s, ndx(6), ndx(7) - ndx(6))))
Case Else:
  z.x = 0
  z.y = z.x
End Select
  ' z.d = cm & " ~ " & pm & " ~ " & ix ' ~ ~ ~~ was used for Debugging the Parser ~~ ~ ~
End Sub

Private Function pzTstUnty$(ByVal y As Double)
Dim rr$
If Abs(y) = 1# Then
  If y < 0# Then
    rr = "-"
  Else
    rr = ""
  End If
Else
  rr = "" & dec2str(y)
End If
pzTstUnty = rr
End Function

Private Function zToStr$(ByRef z As zComplex)
Dim rr$, ss$, aa$, bb$
ss = "+"
If z.y = 0 Then
  If z.x = 0 Then
    rr = "0"
  ElseIf z.x < 0 Then
    aa = dec2str(z.x)
    rr = unSpace(aa)
  Else
    aa = dec2str(z.x)
    rr = unSpace(aa)
  End If
ElseIf z.y < 0 Then
  If z.x = 0 Then
    rr = unSpace(pzTstUnty(z.y) & "i")
  ElseIf z.x < 0 Then
    aa = dec2str(z.x)
    rr = unSpace(aa & pzTstUnty(z.y) & "i")
  Else
    aa = dec2str(z.x)
    rr = unSpace(aa & pzTstUnty(z.y) & "i")
  End If
Else
  If z.x = 0 Then
    rr = unSpace(pzTstUnty(z.y) & "i")
  ElseIf z.x < 0 Then
    aa = dec2str(z.x)
    rr = unSpace(aa & ss & pzTstUnty(z.y) & "i")
  Else
    aa = dec2str(z.x)
    rr = unSpace(aa & ss & pzTstUnty(z.y) & "i")
  End If
End If
' rr = rr & " (" & z.d & ")" ' ~ ~ ~~ was used for Debugging the Parser ~~ ~ ~
zToStr = rr
End Function

Public Function zCnIoTst$(ByVal s$): Dim z As zComplex: parseComplex z, s: zCnIoTst = zToStr(z): End Function

' ----------------- .
' **** Complex **** .
' ----------------- .

' *   *  * ** *** the procedures that can be used in Excel Worksheet *** ** *  *   *

' *(97)*
Public Function imimRe(ByVal sz As String) As String
Dim zz As zComplex: parseComplex zz, sz: zz.a = zRe(zz): imimRe = dec2str(zz.a)
End Function
' *(98)*
Public Function imimIm(ByVal sz As String) As String
Dim zz As zComplex: parseComplex zz, sz: zz.a = zIm(zz): imimIm = dec2str(zz.a)
End Function
' *(1)*
Public Function imimArg(ByVal sz As String) As String
Dim zz As zComplex: parseComplex zz, sz: zz.a = zArg(zz): imimArg = dec2str(zz.a)
End Function
' *(2)*
Public Function imimEqu(ByVal x As Double, ByVal y As Double) As String
Dim zz As zComplex: zEqu zz, x, y: imimEqu = zToStr(zz)
End Function
' *(6)*
Public Function imimAdd(ByVal sz As String, ByVal sw As String) As String
Dim zz As zComplex, ww As zComplex: parseComplex zz, sz: parseComplex ww, sw
zAdd zz, ww: imimAdd = zToStr(zz)
End Function
' *(7)*
Public Function imimSub(ByVal sz As String, ByVal sw As String) As String
Dim zz As zComplex, ww As zComplex: parseComplex zz, sz: parseComplex ww, sw
zSub zz, ww: imimSub = zToStr(zz)
End Function
' *(8)*
Public Function imimMul(ByVal sz As String, ByVal sw As String) As String
Dim zz As zComplex, ww As zComplex: parseComplex zz, sz: parseComplex ww, sw
zMul zz, ww: imimMul = zToStr(zz)
End Function
' *(9)*
Public Function imimScl(ByVal sz As String, ByVal a As Double) As String
Dim zz As zComplex: parseComplex zz, sz: zScl zz, a: imimScl = zToStr(zz)
End Function
' *(11)*
Public Function imimMdl(ByVal sz As String) As String
Dim zz As zComplex: parseComplex zz, sz: zz.a = zMdl(zz): imimMdl = dec2str(zz.a)
End Function
' *(12)*
Public Function imimDiv(ByVal sz As String, ByVal sw As String) As String
Dim zz As zComplex, ww As zComplex: parseComplex zz, sz: parseComplex ww, sw
zDiv zz, ww: imimDiv = zToStr(zz)
End Function
' *(13)*
Public Function imimInv(ByVal sz As String) As String
Dim zz As zComplex: parseComplex zz, sz: zInv zz: imimInv = zToStr(zz)
End Function
' *(14)*
Public Function imintPow(ByVal sz As String, ByVal p As Double) As String
Dim zz As zComplex: parseComplex zz, sz: zIntPow zz, p: imintPow = zToStr(zz)
End Function
' *(15)*
Public Function imintRoot(ByVal sz As String, ByVal p As Double, ByVal q As Double) As String
Dim zz As zComplex: parseComplex zz, sz: zIntRoot zz, p, q: imintRoot = zToStr(zz)
End Function
' *(16)*
Public Function imimPow(ByVal sz As String, ByVal sw As String) As String
Dim zz As zComplex, ww As zComplex: parseComplex zz, sz: parseComplex ww, sw
zPow zz, ww: imimPow = zToStr(zz)
End Function

' ----------------- .
' **** Complex **** .
' ----------------- .

'[EOC]

---

[Eop]