dodicat
your parser gives the following error: syntax error, at ''
your original code works ok, if you want to give the QD another try here are QD binaries compiled with g++.
[edit] I had added the function exp10 to the source in the vc project which is not included here.
shellexecute, how to?
Re: shellexecute, how to?
OK I managed to get the 64 bit fb running.
But c_dd_exp10 was causing a compile fail, so I had to comment it out in the .bi files.
The parser problem is you have an e in the numbers.
like
+3.141592653589793238462643383279503e+00
The parser only accepts ordinary numbers
.00000877555
-3.999999999
...
...
But c_dd_exp10 was causing a compile fail, so I had to comment it out in the .bi files.
The parser problem is you have an e in the numbers.
like
+3.141592653589793238462643383279503e+00
The parser only accepts ordinary numbers
.00000877555
-3.999999999
...
...
Re: shellexecute, how to?
thank you dodicat, I added 32-bit version in case you want it, like I mentioned, exp10 is not included.
thanks for seeing this through.
thanks for seeing this through.
Re: shellexecute, how to?
Thanks srvaldez.
Can yo change your formats i.e. no + or e in the strings.
+5.886 -- NO
5.886 -- OK
I could perhaps write a formatting method.
Quick try:
poly.bas
I have set in shell "cmd", so just click the poly.exe to get started.
Something is amiss when using ^
poly "-3,3,x^3-x^2"
gives a log error
but
poly "3,6,x^3-x^2
seems OK (+ve values)
Can yo change your formats i.e. no + or e in the strings.
+5.886 -- NO
5.886 -- OK
I could perhaps write a formatting method.
Quick try:
poly.bas
Code: Select all
#include "dd.bi"
#include "qd.bi"
#include "qd_overload.bi" 'this will overload the trig and exp functions
sub list()
? " abs()"
? " atn()"
? " cos()"
? " exp()"
? " fix()"
? " int()"
? " log()"
? " rnd()"
? " sgn()"
? " sin()"
? " sqr()"
? " tan()"
? " haversine()"
? " cosec()"
? " sec()"
? " cot()"
? " asin()"
? " acos()"
? " atn()"
? " arcsec()"
? " arccosec()"
? " arccot()"
? " sinh()"
? " cosh()"
? " tanh()"
? " sech()"
? " cosech()"
? " coth()"
? " arcsinh()"
? " arccoth()"
? " arctanh()"
? " arcsech()"
? " arccosech()"
? " pi()"
end sub
#include "crt/io.bi"
Declare Sub GaussJordan(() As qd,() As qd,() As qd)
Declare Sub Interpolate(() As qd,() As qd,() As qd)
Declare Function poly(() As qd,Byval As qd) As qd
Declare Sub automateY(As qd,As qd,Byref As qd,Byref As qd)
Declare Function eval(Byref sp As String ) As qd
Declare Function FindAndReplace(Byref instring As String,Byref ReplaceThis As String,Byref WithThis As String) As String
Declare Sub string_split(Byval s As String,chars As String,result() As String)
declare function format ( Byval Number As string ) as string
Dim Shared e_input As String
Dim Shared e_tok As String
Dim Shared e_spelling As String
Dim Shared e_error As Integer
Dim Pi As qd = 4 * Atn(qd(1))
Dim As qd lower,upper
Dim As qd MinY,MaxY
'================================================================
Dim Shared As String fn
Function func(Byval x As qd) As qd
static as string v,f
v=format(x)
if instr(v,"e")=0 then
f=FindAndReplace(fn,"x",v)
end if
Return eval(f)
End Function
Dim As String g=Command(1)
g=lcase(g)
Cls
if len(g)=0 then
print
print
print "Poly Needs an instruction"
print "type poly help at the command prompt"
shell "cmd"
end
end if
If g=Lcase("help") Then
Print "poly ""start x value, finish x value, function (in x)"" "
print "Everything must be inside quotes"
Print "No spaces allowed, use a comma to seperate flags"
print "operators ^ ( ) / * + - mod "
Print "available functions :"
list()
Print "Example"
Print "poly ""-3,3,sin(x)"" "
End
End If
Redim As String a()
string_split(g,",",a())
If Ubound(a)<>3 Then Print "Input error":End
if eval(a(1))>=eval(a(2)) then Print "Input error on range":End
a(1)=rtrim(a(1),"q")
a(2)=rtrim(a(2),"q")
a(3)=rtrim(a(3),"q")
lower=eVal(a(1)) '<-------lower x range here
upper=eVal(a(2)) '<-------upper x range here
a(3)=Lcase(a(3))
Dim As String copy=a(3)
If Instr(a(3),"exp") Then
a(3)= FindAndReplace(a(3),"exp","ezp")
End If
fn=a(3)
'var tmp=FindAndReplace(a(3),"x",a(1))
'print tmp
'sleep
'var tempd=eval(tmp)
e_error=0
'Automate Y range by the sub automate
automateY(lower,upper,MinY,MaxY)
'=======================================================
'============== PARSER START ==================================
Function SEC(Byval x As qd) As qd
SEC = 1 / Cos(x)
End Function
Function COSEC(Byval x As qd) As qd
COSEC = 1 / Sin(x)
End Function
Function COT(Byval x As qd) As qd
COT = 1 / Tan(x)
End Function
Function ARCSEC(Byval x As qd) As qd
ARCSEC = Atn(x / Sqr(x * x - 1)) + Sgn((x) -1) * (2 * Atn(qd(1)))
End Function
Function ARCCOSEC(Byval x As qd) As qd
ARCCOSEC = Atn(x / Sqr(x * x - 1)) + (Sgn(x) - 1) * (2 * Atn(qd(1)))
End Function
Function ARCCOT(Byval x As qd) As qd
ARCCOT = Atn(x) + 2 * Atn(qd(1))
End Function
Function sech(Byval x As qd) As qd
sech = 2 / (Exp(x) + Exp(-x))
End Function
Function cosech(Byval x As qd) As qd
cosech = 2 / (Exp(x) - Exp(-x))
End Function
Function coth(Byval x As qd) As qd
coth = (Exp(x) + Exp(-x)) / (Exp(x) - Exp(-x))
End Function
Function arcsinh(Byval x As qd) As qd
arcsinh = Log(x + Sqr(x * x + 1))
End Function
Function arccosh(Byval x As qd) As qd
arccosh = Log(x + Sqr(x * x - 1))
End Function
Function arctanh(Byval x As qd) As qd
arctanh = Log((1 + x) / (1 - x)) / 2
End Function
Function arcsech(Byval x As qd) As qd
arcsech = Log((Sqr(-x * x + 1) + 1) / x)
End Function
Function arccosech(Byval x As qd) As qd
arccosech = Log((Sgn(x) * Sqr(x * x + 1) +1) / x)
End Function
Function arccoth(Byval x As qd) As qd
arccoth = Log((x + 1) / (x - 1)) / 2
End Function
Function HAVERSINE(Byval x As qd) As qd
HAVERSINE = (Sin(x/2))^2
End Function
function pie(byval x as qd=1) as qd
return (4*Atn(qd(1)))*x
end function
Function e_function(Byref fun As String,Byval arg As qd) As qd
Dim n As qd
Select Case Lcase(fun)
Case "abs": n = Abs(arg)
Case "atn": n = Atn(arg)
Case "cos": n = Cos(arg)
Case "exp": n = Exp(arg)
Case "ezp": n = Exp(arg)
Case "fix": n = Fix(arg)
Case "int": n = Int(arg)
Case "log": n = Log(arg)
Case "rnd": n = Rnd(arg)
Case "sgn": n = Sgn(arg)
Case "sin": n = Sin(arg)
Case "sqr": n = Sqr(arg)
Case "tan": n = Tan(arg)
Case "haversine":n=haversine(arg)
Case "cosec":n=cosec(arg)
Case "sec":n=sec(arg)
Case "cot": n=cot(arg)
Case "asin":n=Asin(arg)
Case "acos":n=Acos(arg)
Case "atn":n=Atn(arg)
Case "arcsec":n=arcsec(arg)
Case "arccosec":n=arccosec(arg)
Case "arccot":n=arccot(arg)
Case "sinh":n=sinh(arg)
Case "cosh":n=cosh(arg)
Case "tanh":n=tanh(arg)
Case "sech":n=sech(arg)
Case "cosech":n=cosech(arg)
Case "coth":n=coth(arg)
Case "arcsinh":n=arcsinh(arg)
Case "arccoth":n=arccoth(arg)
Case "arctanh":n=arctanh(arg)
Case "arcsech":n=arcsech(arg)
Case "arccosech":n=arccosech(arg)
Case "pi" :n=pie(arg)
Case Else
If Not e_error Then
Locate 1,1
Print "UNDEFINED FUNCTION " + fun
Print
e_error = -1
End If
End Select
e_function = n
End Function
Sub e_nxt()
Dim is_keyword As Integer
Dim c As String
e_tok = ""
e_spelling = ""
Do
c = Left(e_input, 1)
e_input = Mid(e_input, 2)
Loop While c = " " Or c = Chr(9) Or c = Chr(13) Or c = Chr(10)
Select Case Lcase(c)
Case "0" To "9", "."
e_tok = "num"
Do
e_spelling = e_spelling + c
c = Left(e_input, 1)
e_input = Mid(e_input, 2)
Loop While (c >= "0" And c <= "9") Or c = "."
e_input = c + e_input
Case "a" To "z", "_"
Dim As Integer is_id
e_tok = "id"
Do
e_spelling = e_spelling + c
c = Lcase(Left(e_input, 1))
e_input = Mid(e_input, 2)
is_id = (c >= "a" And c <= "z")
is_id = is_id Or c = "_" Or (c >= "0" And c <= "9")
Loop While is_id
e_input = c + e_input
is_keyword = -1
Select Case Lcase(e_spelling)
Case "and"
Case "eqv"
Case "imp"
Case "mod"
Case "not"
Case "or"
Case "xor"
Case Else: is_keyword = 0
End Select
If is_keyword Then
e_tok = Lcase(e_spelling)
End If
Case "<", ">"
e_tok = c
c = Left(e_input, 1)
If c = "=" Or c = ">" Then
e_tok = e_tok + c
e_input = Mid$(e_input, 2)
End If
Case Else
e_tok = c
End Select
If e_spelling = "" Then
e_spelling = e_tok
End If
End Sub
Sub e_match (Byref token As String)
If Not e_error And e_tok <> token Then
Locate 1,1
Print "EXPECTED " + token + ", got '" + e_spelling + "'"
e_error = -1':end
End If
e_nxt()
End Sub
Function e_prs (Byval p As Integer) As qd
Dim n As qd
Dim fun As String
If e_tok = "num" Then
n = Val(e_spelling)
e_nxt()
Elseif e_tok = "-" Then
e_nxt()
n = -e_prs(12) '' 11 before
Elseif e_tok = "not" Then
e_nxt()
n = Not e_prs(6)
Elseif e_tok = "(" Then
e_nxt()
n = e_prs(1)
e_match(")")
Elseif e_tok = "id" Then
fun = e_spelling
e_nxt()
e_match("(")
n = e_prs(1)
e_match(")")
n = e_function(fun, n)
Else
If Not e_error Then
Locate 1,1
Print "syntax error, at '" + e_spelling + "'"
e_error = -1':end
End If
End If
Do While Not e_error
If p <= 11 And e_tok = "^" Then
e_nxt(): n = n ^ e_prs(12)
Elseif p <= 10 And e_tok = "*" Then
e_nxt(): n = n * e_prs(11)
Elseif p <= 10 And e_tok = "/" Then
e_nxt(): n = n / e_prs(11)
Elseif p <= 9 And e_tok = "\" Then
e_nxt(): n = n \ e_prs(10)
Elseif p <= 8 And e_tok = "mod" Then
e_nxt(): n = n Mod e_prs(9)
Elseif p <= 7 And e_tok = "+" Then
e_nxt(): n = n + e_prs(8)
Elseif p <= 7 And e_tok = "-" Then
e_nxt(): n = n - e_prs(8)
Elseif p <= 6 And e_tok = "=" Then
e_nxt(): n = n = e_prs(7)
Elseif p <= 6 And e_tok = "<" Then
e_nxt(): n = n < e_prs(7)
Elseif p <= 6 And e_tok = ">" Then
e_nxt(): n = n > e_prs(7)
Elseif p <= 6 And e_tok = "<>" Then
e_nxt(): n = n <> e_prs(7)
Elseif p <= 6 And e_tok = "<=" Then
e_nxt(): n = n <= e_prs(7)
Elseif p <= 6 And e_tok = ">=" Then
e_nxt(): n = n >= e_prs(7)
Elseif p <= 5 And e_tok = "and" Then
e_nxt(): n = n And e_prs(6)
Elseif p <= 4 And e_tok = "or" Then
e_nxt(): n = n Or e_prs(5)
Elseif p <= 3 And e_tok = "xor" Then
e_nxt(): n = n Xor e_prs(4)
Elseif p <= 2 And e_tok = "eqv" Then
e_nxt(): n = n Eqv e_prs(3)
Elseif p <= 1 And e_tok = "imp" Then
e_nxt(): n = n Imp e_prs(2)
Else
Exit Do
End If
Loop
e_prs = n
End Function
Function eval(Byref sp As String ) As qd
Dim As qd value
e_error = 0
e_input = sp
e_nxt()
value = e_prs(1)
If Not e_error Then Return value else e_error=0
End Function
Function FindAndReplace(Byref instring As String,Byref ReplaceThis As String,Byref WithThis As String) As String
Var lens1=Len(ReplaceThis),lens2=Len(WithThis)
If lens1=lens2 Then lens1=0
Dim As String s=instring
Dim As Integer position=Instr(s,ReplaceThis)
While position>0
If lens1 Then
s=Left(s,position-1) & WithThis & Mid(s,position+Lens1)
Else
Mid(s,position) = WithThis
End If
position=Instr(position+Lens2,s,ReplaceThis)
Wend
Function=s
End Function
'=================== END OF PARSER =======================
Sub string_split(Byval s As String,chars As String,result() As String)
Redim result(0)
Dim As String var1,var2
Dim As Long pst
#macro split(stri)
pst=Instr(stri,chars)
var1="":var2=""
If pst<>0 Then
var1=Mid(stri,1,pst-1)
var2=Mid(stri,pst+1)
Else
var1=stri
End If
If Len(var1) Then
Redim Preserve result(1 To Ubound(result)+1)
result(Ubound(result))=var1
End If
#endmacro
Do
split(s):s=var2
Loop Until var2=""
End Sub
Sub GaussJordan(matrix() As qd,rhs() As qd,ans() As qd)
Dim As Long n=Ubound(matrix,1)
Redim ans(0):Redim ans(1 To n)
Dim As qd b(1 To n,1 To n),r(1 To n)
For c As Long=1 To n 'take copies
r(c)=rhs(c)
For d As Long=1 To n
b(c,d)=matrix(c,d)
Next d
Next c
#macro pivot(num)
For p1 As Long = num To n - 1
For p2 As Long = p1 + 1 To n
If Abs(b(p1,num))<Abs(b(p2,num)) Then
Swap r(p1),r(p2)
For g As Long=1 To n
Swap b(p1,g),b(p2,g)
Next g
End If
Next p2
Next p1
#endmacro
For k As Long=1 To n-1
pivot(k) 'full pivoting each run
For row As Long =k To n-1
If b(row+1,k)=0 Then Exit For
Var f=b(k,k)/b(row+1,k)
r(row+1)=r(row+1)*f-r(k)
For g As Long=1 To n
b((row+1),g)=b((row+1),g)*f-b(k,g)
Next g
Next row
Next k
'back substitute
For z As Long=n To 1 Step -1
ans(z)=r(z)/b(z,z)
For j As Long = n To z+1 Step -1
ans(z)=ans(z)-(b(z,j)*ans(j)/b(z,z))
Next j
Next z
End Sub
'Interpolate through point via a polynomial (spline)
Sub Interpolate(x_values() As qd,y_values() As qd,p() As qd)
Var n=Ubound(x_values)
Redim p(0):Redim p(1 To n)
Dim As qd matrix(1 To n,1 To n),rhs(1 To n)
For a As Long=1 To n
rhs(a)=y_values(a)
For b As Long=1 To n
matrix(a,b)=x_values(a)^(b-1)
Next b
Next a
'Solve the linear equations
GaussJordan(matrix(),rhs(),p())
End Sub
'************** evaluate a polynomial ***********************
Function poly(Coefficients() As qd,Byval x As qd) As qd
Dim As qd acc
For i As Long=Ubound(Coefficients) To Lbound(Coefficients) Step -1
acc=acc*x+Coefficients(i)
Next i
Return acc
End Function
'get chebyshev points for (MinMax) error.
Sub chebypoints(min As qd,max As qd,order As Long,c()As qd)
Redim c(1 To order)
Dim pi As qd=4*Atn(qd(1))
Dim count As Long
For k As Long=order To 1 Step -1
count=count+1
c(count)= Cos((pi/2)*(2*k-1)/order)
c(count)=(max-min)*(c(count)+1)/2+min
Next k
End Sub
Sub automateY(Lx As qd,Ux As qd,Byref ly As qd,Byref uy As qd)
ly=1e10:uy=-1e10
For n As qd=lx To ux Step(ux-lx)/100
Dim As qd f=func(n)
If ly>f Then ly=f
If uy<f Then uy=f
Next n
End Sub
function format ( Byval Number As string ) as string
Dim As String NumberPart, sign,var1,var2
Dim As Integer Epart,pst
var s = trim(Number)
#macro splice(stri,char,var1,var2)
pst=Instr(stri,char)
var1="":var2=""
If pst<>0 Then
var1=Mid(stri,1,pst-1)
var2=Mid(stri,pst+1)
Else
var1=stri
End if
#endmacro
if chr(s[0])="-" then sign="-":s=ltrim(s,"-")
if instr(s,"+") then s=ltrim(s,"+")
if Instr(s, Any "eEdD")=0 then return s
splice(s,any "eEdD",var1,var2)
Epart = valint(var2)
NumberPart = var1
if instr(NumberPart,".") then
var DecPos = Instr(NumberPart, ".")
splice(NumberPart,".",var1,var2)
Epart = Epart + DecPos - Len(NumberPart)
NumberPart=var1+var2
End If
select case Epart
case 0:s=NumberPart
case is>0:s = NumberPart+String(Epart,"0")
case else
Epart=abs(Epart)
If Epart > Len(NumberPart) Then ' insert leading zeros
s = "." + String(Epart-Len(NumberPart),"0")+NumberPart
Else ' insert a decimal point
s = Left(NumberPart,Len(NumberPart)-Epart )+"."+Right(NumberPart,Epart)
End If
end select
s = Ltrim(s, "0")
If s = "." or s="" Then s = "0"
if instr(s,".") then s=rtrim(s,"0")
return sign+s
End function
'EXAMPLE SET UP
Redim _
As qd pol(0),x_values(0),points(0),func_at_x(0)
Dim As String s
#macro set(num)
Scope
Dim order As Long=num
Redim x_values(1 To order)
Redim func_at_x(1 To order)
Redim pol(0)
Redim points(0)
chebypoints(lower,upper,order,points()) 'get the chebychev points for the range
'**** set up the x and f(x) at chebychev points.
For n As Long=Lbound(points) To Ubound(points)
x_values(n)=points(n) '<--------GET X values here
func_at_x(n)=func(points(n)) '<--------GET F(x) here
Next n
INTERPOLATE x_values(),func_at_x(),pol() 'find the interpolating polynomium, pol()
' print (String(Loword(Width)*Hiword(Width)," ")+Chr(10)) 'clear console
puts ("_____________________________")
puts (!"Approxomating Polynomial\n")
dim as string sh=copy + " [" +format(lower) + " To " + format(upper) + "]"
puts (sh)
#define GAP(x) String(25-Len(Str(x))+dn," ")
'print interpolating polynomial to console, refresh graphics to keep in focus
For a As Long=Lbound(pol) To Ubound (pol)
Dim As String op
Dim As qd p=pol(a)
If Sgn(p)>=0 Then op="+" Else op=""
Dim As Long dn:If op="+" Then dn=0 Else dn=1
Var dd_=Iif(a=1,"","*x^"&str(cast(long,a-1)))
s=op &p &GAP(p) &dd_
puts (s)
Next a
Dim As Integer x,y
Dim As Single diff
Screencontrol 0,x,y
Screen 19,32,,&h20
Screencontrol 100,x,y
Draw String (10,10)," Function()",Rgb(200,0,0)
Draw String (10,30),"Polynomial()",Rgb(0,0,200)
For n As Single=lower To upper Step(upper-lower)/1000
diff+=Abs(func(n)-poly(pol(),n))
Next n
Draw String (10,50),"Error factor " &diff,Rgb(100,100,100)
Draw String(10,550),"Press a key or <esc>"
End Scope
#endmacro
Dim As Integer xres,yres
Dim As qd PLOT_grade=500
#macro sketch(_function,minx,maxx,miny,maxy,col)
For x As qd=minx To maxx Step (maxx-minx)/PLOT_GRADE
Dim As qd x1=(xres)*(x-minx)/(maxx-minx)
Dim As qd y1=(yres)*(_function-maxy)/(miny-maxy)
If x=minx Then Pset(x1,y1),col Else Line -(x1,y1),col
Next x
#endmacro
#macro sketchpoint(_function,minx,maxx,miny,maxy,col,x)
Dim As qd x1=(xres)*(x-minx)/(maxx-minx)
Dim As qd y1=(yres)*(_function-maxy)/(miny-maxy)
Circle(x1,y1),2,col,,,,f
#endmacro
#macro _axis(colour)
Scope
Dim As Long flagx,flagy
If Sgn(miny)<>Sgn(maxy) Then
flagx=1
Line(0,(yres-(miny/(miny-maxy))*yres))-(xres,(yres-(miny/(miny-maxy))*yres)),colour 'x axis
Endif
If Sgn(minx)<>Sgn(maxx) Then
flagy=1
Line(((minx/(minx-maxx))*xres),0)-(((minx/(minx-maxx))*xres),yres),colour 'y axis
End If
If flagx=1 Then
Draw String(0,(yres-(miny/(miny-maxy))*yres)),format(minx),colour
Draw String(xres-8-8*(Len(format(maxx))),(yres-(miny/(miny-maxy))*yres)),format(maxx),colour
Else
Draw String(0,yres/2),format(minx),colour
Draw String(xres-8-8*(Len(format(maxx))),yres/2),format(maxx),colour
End If
If flagy=1 Then
Draw String(((minx/(minx-maxx))*xres),0),format(maxy),colour
Draw String(((minx/(minx-maxx))*xres),yres-16),format(miny),colour
Else
Draw String(xres/2,0),format(maxy),colour
Draw String(xres/2,yres-16),format(miny),colour
End If
End Scope
#endmacro
Screen 19,32,,&h20
Screeninfo xres,yres
Dim As Long z=1
Do
z+=1
Cls
set(z)
sketch(func(x),lower,upper,MinY,Maxy,Rgb(200,0,0))
sketch(poly(pol(),x),lower,upper,MinY,MaxY,Rgb(0,0,200))
Var minx=lower,maxx=upper
_axis(Rgb(200,200,200))
'show chebychev points
For z2 As Long=Lbound(points) To Ubound(points)
sketchpoint(func_at_x(z2),lower,upper,MinY,MaxY,Rgb(200,100,0),x_values(z2))
Next z2
Sleep
Loop Until Inkey=Chr(27)
' Sleep
Something is amiss when using ^
poly "-3,3,x^3-x^2"
gives a log error
but
poly "3,6,x^3-x^2
seems OK (+ve values)
Re: shellexecute, how to?
thanks dodicat
it seems to work ok, I am confused about your question: "Can yo change your formats i.e. no + or e in the strings.
+5.886 -- NO"
there should only be a space as first character on positive numbers, however it can be changed in the cast-to-string procedure.
I need to do some kind of number format routine, but it will have to wait till tomorrow.
it seems to work ok, I am confused about your question: "Can yo change your formats i.e. no + or e in the strings.
+5.886 -- NO"
there should only be a space as first character on positive numbers, however it can be changed in the cast-to-string procedure.
I need to do some kind of number format routine, but it will have to wait till tomorrow.