FreeBASIC LolRemez

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
Post Reply
dodicat
Posts: 7983
Joined: Jan 10, 2006 20:30
Location: Scotland

FreeBASIC LolRemez

Post by dodicat »

Member srvaldez introduced the LolRemez function approximator a few days ago.
https://github.com/samhocevar/lolremez/releases
But he had a severe crash while running it.
I ran it only twice and escaped the crash.
Here is the fb thread
http://www.freebasic.net/forum/viewtopi ... =2&t=25875

I have made up an alternative FreeBASIC approximator, but with some graphics added.
Compile the file poly.bas to .exe
Click it to get the command prompt.
It runs thus:
At the prompt something like:

poly "-6,8,cos(x)*sin(x)"
Remember to use the double quotes as above!
meaning from x = -6 to 8 the function cos(x)*sin(x) is approximated.
Press the spacebar to build up the approximation until you are happy that the curves are similar.
The standard way of showing the approximation coefficients is shown on the console, but you have the option (upon exit by pressing <esc>), to save to a .bas file, the nested method, which is much faster arithmetically for the computer.

Poly.bas

Code: Select all

 




 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.bi"

Declare Sub GaussJordan(() As Double,() As Double,() As Double)
Declare Sub Interpolate(() As Double,() As Double,() As Double)
Declare Function poly(() As Double,Byval  As Double) As Double
Declare Sub automateY(As Double,As Double,Byref As Double,Byref As Double)
Declare Function eval(Byref sp As String ) As Double
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)

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 Double = 4 * Atn(1)
Dim As Double lower,upper
Dim As Double MinY,MaxY


'================================================================
Dim Shared As String fn


Function func(Byval x As Double) As Double
    static as string v,f
     v=str(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


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)

e_error=0
'Automate Y range by the sub automate
automateY(lower,upper,MinY,MaxY)
'=======================================================
'==============  PARSER START  ==================================
Function SEC(Byval x As Double) As Double
    SEC = 1 / Cos(x)
End Function

Function COSEC(Byval x As Double) As Double
    COSEC = 1 / Sin(x)
End Function

Function COT(Byval x As Double) As Double
    COT = 1 / Tan(x)
End Function

Function ARCSEC(Byval x As Double) As Double ''''''
    ARCSEC = Atn(x / Sqr(x * x - 1)) + Sgn((x) -1) * (2 * Atn(1))
End Function

Function ARCCOSEC(Byval x As Double) As Double
    ARCCOSEC = Atn(x / Sqr(x * x - 1)) + (Sgn(x) - 1) * (2 * Atn(1))
End Function

Function ARCCOT(Byval x As Double) As Double
    ARCCOT = Atn(x) + 2 * Atn(1)
End Function

Function sech(Byval x As Double) As Double
    sech = 2 / (Exp(x) + Exp(-x))
End Function

Function cosech(Byval x As Double) As Double
    cosech = 2 / (Exp(x) - Exp(-x))
End Function

Function coth(Byval x As Double) As Double
    coth = (Exp(x) + Exp(-x)) / (Exp(x) - Exp(-x))
End Function

Function arcsinh(Byval x As Double) As Double
    arcsinh = Log(x + Sqr(x * x + 1))
End Function

Function arccosh(Byval x As Double) As Double
    arccosh = Log(x + Sqr(x * x - 1))
End Function

Function arctanh(Byval x As Double) As Double
    arctanh = Log((1 + x) / (1 - x)) / 2 
End Function

Function arcsech(Byval x As Double) As Double
    arcsech = Log((Sqr(-x * x + 1) + 1) / x)
End Function

Function arccosech(Byval x As Double) As Double
    arccosech = Log((Sgn(x) * Sqr(x * x + 1) +1) / x)
End Function

Function arccoth(Byval x As Double) As Double
    arccoth = Log((x + 1) / (x - 1)) / 2
End Function

Function HAVERSINE(Byval x As Double) As Double
    HAVERSINE = (Sin(x/2))^2
End Function

function pie(byval x as double=1) as double
    return (4*atn(1))*x
    end function

Function e_function(Byref fun As String,Byval arg As Double) As Double
    Dim n As Double
    
    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 Double
    Dim n   As Double  
    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 Double
    Dim As Double 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 Double,rhs() As Double,ans() As Double)
    Dim As Long n=Ubound(matrix,1)
    Redim ans(0):Redim ans(1 To n)
    Dim As Double 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 Double,y_values() As Double,p() As Double)
    Var n=Ubound(x_values)
    Redim p(0):Redim p(1 To n)
    Dim As Double 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 Double,Byval x As Double) As Double
    Dim As Double 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 Double,max As Double,order As Long,c()As Double)
    Redim c(1 To order)
    Dim pi As Double=4*Atn(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 Double,Ux As Double,Byref  ly As Double,Byref uy As Double)
    ly=1e10:uy=-1e10
    For n As Double=lx To ux Step(ux-lx)/100
        Dim As Double f=func(n)
        If ly>f Then ly=f
        If uy<f Then uy=f
    Next n
End Sub

sub save(ch as string,sh as string,copy as string,lower as double,upper as double,MinY as double,MaxY as double,xres as long,yres as long)
    dim as long f=freefile
    open "functions.bas" for output as #f
    print #f," "
    
    
   print #f, "Function SEC(Byval x As Double) As Double"
   print #f, " SEC = 1 / Cos(x)"
print #f, "End Function"
print #f, " "
print #f, "Function COSEC(Byval x As Double) As Double"
    print #f, "COSEC = 1 / Sin(x)"
print #f, "End Function"
print #f, " "
print #f, "Function COT(Byval x As Double) As Double"
    print #f, "COT = 1 / Tan(x)"
print #f, "End Function"
print #f, " "
print #f, "Function ARCSEC(Byval x As Double) As Double" 
    print #f, "ARCSEC = Atn(x / Sqr(x * x - 1)) + Sgn((x) -1) * (2 * Atn(1))"
print #f, "End Function"
print #f, " "
print #f, "Function ARCCOSEC(Byval x As Double) As Double"
   print #f, " ARCCOSEC = Atn(x / Sqr(x * x - 1)) + (Sgn(x) - 1) * (2 * Atn(1))"
print #f, "End Function"
print #f, " "
print #f, "Function ARCCOT(Byval x As Double) As Double"
   print #f, " ARCCOT = Atn(x) + 2 * Atn(1)"
print #f, "End Function"
print #f, " "
print #f, "Function sech(Byval x As Double) As Double"
   print #f, " sech = 2 / (Exp(x) + Exp(-x))"
print #f, "End Function"
print #f, " "
print #f, "Function cosech(Byval x As Double) As Double"
   print #f, " cosech = 2 / (Exp(x) - Exp(-x))"
print #f, "End Function"
print #f, " "
print #f, "Function coth(Byval x As Double) As Double"
    print #f, "coth = (Exp(x) + Exp(-x)) / (Exp(x) - Exp(-x))"
print #f, "End Function"
print #f, " "
print #f, "Function arcsinh(Byval x As Double) As Double"
    print #f, "arcsinh = Log(x + Sqr(x * x + 1))"
print #f, "End Function"
print #f, " "
print #f, "Function arccosh(Byval x As Double) As Double"
    print #f, "arccosh = Log(x + Sqr(x * x - 1))"
print #f, "End Function"
print #f, " "
print #f, "Function arctanh(Byval x As Double) As Double"
    print #f, "arctanh = Log((1 + x) / (1 - x)) / 2" 
print #f,"End Function"
print #f, " "
print #f, "Function arcsech(Byval x As Double) As Double"
    print #f, "arcsech = Log((Sqr(-x * x + 1) + 1) / x)"
print #f, "End Function"
print #f, " "
print #f, "Function arccosech(Byval x As Double) As Double"
    print #f, "arccosech = Log((Sgn(x) * Sqr(x * x + 1) +1) / x)"
print #f, "End Function"
print #f, " "
print #f, "Function arccoth(Byval x As Double) As Double"
   print #f, " arccoth = Log((x + 1) / (x - 1)) / 2"
print #f, "End Function"
print #f, " "
print #f, "Function HAVERSINE(Byval x As Double) As Double"
    print #f, "HAVERSINE = (Sin(x/2))^2"
print #f, "End Function"
print #f, " "
print #f, "Function pie(byval x as double=1) as double"
    print #f, "return (4*atn(1))*x"
print #f, "End function"
print #f, " "
    print #f,"Screen 19,32"
    print #f,"#include ""crt.bi"""
    print #f,"print ""Red -- function , blue -- approximation"""
    print #f, " "
    print #f,"Dim as double x"
    print #f," "
    print #f," #macro sketch(_function,minx,maxx,miny,maxy,col)"
    print #f,"For x As Double=minx To maxx Step (maxx-minx)/500"
    print #f," Dim As Double x1=("+str(xres)+")*(x-minx)/(maxx-minx)"
    print #f," Dim As Double y1=("+str(yres)+")*(_function-maxy)/(miny-maxy)"
    print #f," If x=minx Then Pset(x1,y1),col Else Line -(x1,y1),col"
    print #f,"Next x"
    print #f,"#endmacro"
    print #f, " "
    print #f,"function original(x as double) as double"
    
    print #f, "Return " +copy
    
    print #f, "end function"
    print #f, " "
    
    print #f,"function f(x as double) as double"
    print #f,"' approximating "+sh
    print #f, "Return _ "
    print #f,ch
    print #f, "end function"
    print #f," "
    print #f,"sketch(original(x),"+str(lower)+","+str(upper)+","+str(MinY)+","+str(Maxy)+",Rgb(200,0,0))"
    print #f, "sketch(f(x),"+str(lower)+","+str(upper)+","+str(MinY)+","+str(MaxY)+",Rgb(0,0,200))"
    print #f,"sleep"
    close #f
end sub


'EXAMPLE SET UP
Redim _
As Double pol(0),x_values(0),points(0),func_at_x(0)

Dim As String s,ch,sh

#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()
    
    
   ' puts (String(Loword(Width)*Hiword(Width)," ")+Chr(10)) 'clear console 
    puts("_____________________________")
    puts(!"Approxomating Polynomial\n")
     sh=copy + "  [" +str(lower) + " To " + str(upper) + "]"
   
    puts(sh)
    #define GAP(x) String(25-Len(Str(x))+dn," ")
    'print interpolating polynomial to console, refresh graphics to keep in focus
    ch=""
    dim as string tmp,xx="*x"
    For a As Long=Lbound(pol) To Ubound (pol)
        Dim As String op
        Dim As Double 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(a-1))
        s=op &p &GAP(p) &dd
        puts(s)
    Next a
    'nested form
    for a as long=ubound(pol) to lbound(pol) step -1
          Dim As String op
        if a=lbound(pol) then xx="" else xx="*x"
         Dim As Double p=pol(a)
        If Sgn(p)>=0 Then op="+" Else op=""
          tmp="("+ch+op+str(p)+")"+xx
        ch="("+ch+op+str(p)+")"+xx
         if len(tmp)>80 then ch=ch+" _ " +chr(10)
        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 Double PLOT_grade=500

#macro sketch(_function,minx,maxx,miny,maxy,col)
For x As Double=minx To maxx Step (maxx-minx)/PLOT_GRADE
    Dim As Double x1=(xres)*(x-minx)/(maxx-minx)
    Dim As Double 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 Double x1=(xres)*(x-minx)/(maxx-minx)
Dim As Double 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)),Str(minx),colour
            Draw String(xres-8-8*(Len(Str(maxx))),(yres-(miny/(miny-maxy))*yres)),Str(maxx),colour
        Else
            Draw String(0,yres/2),Str(minx),colour
            Draw String(xres-8-8*(Len(Str(maxx))),yres/2),Str(maxx),colour
        End If 
        If flagy=1 Then
            Draw String(((minx/(minx-maxx))*xres),0),Str(maxy),colour
            Draw String(((minx/(minx-maxx))*xres),yres-16),Str(miny),colour
        Else
            Draw String(xres/2,0),Str(maxy),colour
            Draw String(xres/2,yres-16),Str(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)
    screen 0
    dim as string t
    print "The polynomial can be saved in nested form"
    do
    print "Do want to save to file? y/n"
    t=input(1)
    t=lcase(t)
    loop until t="y" or t="n"
    if t="y" then
        save (ch,sh,copy,lower,upper,MinY,MaxY,xres,yres)
        print "saved to functions.bas"
        print "press a key"
        end if
    
    sleep
    
     

    
      
Good luck.
Windows, because of shell "cmd" in the code.
I don't know the Linux shell command to get a terminal.
(You can comment out the shell "cmd" and just use the console from scratch).
It will probably take a few seconds to work on the first run (the anti-virus check on a new executable).
jj2007
Posts: 2326
Joined: Oct 23, 2016 15:28
Location: Roma, Italia
Contact:

Re: FreeBASIC LolRemez

Post by jj2007 »

Hi dodicat,

Guga revived this project. It compiles fine after eliminating the $ in e_input = Mid$(e_input, 2).

With your suggested input lolremez.exe poly "-6,8,cos(x)*sin(x)" it says input error.
With lolremez.exe "poly -6,8,cos(x)*sin(x)" it says EXPECTED (, got '-' but proceeds afterwards with nice graphs.

I know it's three years ago, but do you still remember why this input throws an error?

P.S.: I've studied the code, the FB help file, and looked for screen-related commands. How the hell can you tell the window to move further right, so that it doesn't cover the console output...?
dodicat
Posts: 7983
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: FreeBASIC LolRemez

Post by dodicat »

Hi jj2007.
It is OK here.
Answer(to a few iterations to get the error small)

Code: Select all

 
Function SEC(Byval x As Double) As Double
 SEC = 1 / Cos(x)
End Function
 
Function COSEC(Byval x As Double) As Double
COSEC = 1 / Sin(x)
End Function
 
Function COT(Byval x As Double) As Double
COT = 1 / Tan(x)
End Function
 
Function ARCSEC(Byval x As Double) As Double
ARCSEC = Atn(x / Sqr(x * x - 1)) + Sgn((x) -1) * (2 * Atn(1))
End Function
 
Function ARCCOSEC(Byval x As Double) As Double
 ARCCOSEC = Atn(x / Sqr(x * x - 1)) + (Sgn(x) - 1) * (2 * Atn(1))
End Function
 
Function ARCCOT(Byval x As Double) As Double
 ARCCOT = Atn(x) + 2 * Atn(1)
End Function
 
Function sech(Byval x As Double) As Double
 sech = 2 / (Exp(x) + Exp(-x))
End Function
 
Function cosech(Byval x As Double) As Double
 cosech = 2 / (Exp(x) - Exp(-x))
End Function
 
Function coth(Byval x As Double) As Double
coth = (Exp(x) + Exp(-x)) / (Exp(x) - Exp(-x))
End Function
 
Function arcsinh(Byval x As Double) As Double
arcsinh = Log(x + Sqr(x * x + 1))
End Function
 
Function arccosh(Byval x As Double) As Double
arccosh = Log(x + Sqr(x * x - 1))
End Function
 
Function arctanh(Byval x As Double) As Double
arctanh = Log((1 + x) / (1 - x)) / 2
End Function
 
Function arcsech(Byval x As Double) As Double
arcsech = Log((Sqr(-x * x + 1) + 1) / x)
End Function
 
Function arccosech(Byval x As Double) As Double
arccosech = Log((Sgn(x) * Sqr(x * x + 1) +1) / x)
End Function
 
Function arccoth(Byval x As Double) As Double
 arccoth = Log((x + 1) / (x - 1)) / 2
End Function
 
Function HAVERSINE(Byval x As Double) As Double
HAVERSINE = (Sin(x/2))^2
End Function
 
Function pie(byval x as double=1) as double
return (4*atn(1))*x
End function
 
Screen 19,32
#include "crt.bi"
print "Red -- function , blue -- approximation"
 
Dim as double x
 
 #macro sketch(_function,minx,maxx,miny,maxy,col)
For x As Double=minx To maxx Step (maxx-minx)/500
 Dim As Double x1=(800)*(x-minx)/(maxx-minx)
 Dim As Double y1=(600)*(_function-maxy)/(miny-maxy)
 If x=minx Then Pset(x1,y1),col Else Line -(x1,y1),col
Next x
#endmacro
 
function original(x as double) as double
Return cos(x)*sin(x)
end function
 
function f(x as double) as double
' approximating cos(x)*sin(x)  [-6 To 8]
Return _ 
((((((((((((((((((((((-9.112737161868667e-016)*x+3.534404588617586e-014)*x-2.156673720413297e-013)*x _ 
-6.530323609842852e-012)*x _ 
+7.456082721905285e-011)*x _ 
+5.150619576340638e-010)*x _ 
-8.636112116294205e-009)*x _ 
-2.26091599195452e-008)*x _ 
+5.703183766515731e-007)*x _ 
+6.03447319440271e-007)*x _ 
-2.44223085926033e-005)*x _ 
-1.003973194624167e-005)*x _ 
+0.0006950241509247266)*x _ 
+0.0001025144724426364)*x _ 
-0.01264925131759549)*x _ 
-0.000606645229577334)*x _ 
+0.1332248344857728)*x _ 
+0.001840557604616905)*x _ 
-0.6665934751220229)*x _ 
-0.002187167698055603)*x _ 
+1.000005528790585)*x _ 
+0.000432798081059893) _ 

end function
 
sketch(original(x),-6,8,-0.4996836508806247,0.4999855181650122,Rgb(200,0,0))
sketch(f(x),-6,8,-0.4996836508806247,0.4999855181650122,Rgb(0,0,200))
sleep
 
poly is the executable when you compile poly.bas and run poly.exe from a shell.
poly "-6,8,cos(x)*sin(x)"

lolremez.bas -> lolremez.exe I didnt use, just poly.bas -> poly.exe.
Remember to keep pressing a key until a good approximation shows on the sketch.
jj2007
Posts: 2326
Joined: Oct 23, 2016 15:28
Location: Roma, Italia
Contact:

Re: FreeBASIC LolRemez

Post by jj2007 »

dodicat wrote:It is OK here.
Hi dodicat,
You are using an IDE? With -lang QB in the settings? Here it complains about the Mid$()
I wonder why I get that input error...
dodicat
Posts: 7983
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: FreeBASIC LolRemez

Post by dodicat »

Make it mid, as you said in your first post.
I hardly ever use lang qb, the code is straight fb.
mid$ was allowed until recently
Call the code poly.bas, compile it and click the executable.
It is a command line tool to keep in line with lolremez, but I have allowed the program to start by clicking poly.exe rather than using a command shell to run it.
It will also start via command shell if preferred.
Remember poly is not inside quotes.
poly "-6,8,cos(x)*sin(x)"
My ide is fbide, has been for years now.
Good luck.
jj2007
Posts: 2326
Joined: Oct 23, 2016 15:28
Location: Roma, Italia
Contact:

Re: FreeBASIC LolRemez

Post by jj2007 »

dodicat wrote:Remember poly is not inside quotes
Then it won't work - input error...
Post Reply