Squares

General FreeBASIC programming questions.
albert
Posts: 5533
Joined: Sep 28, 2006 2:41
Location: California, USA

Postby albert » Dec 07, 2011 2:49

@Dodicat

I've finished the parser sortof , I've put all your trig things in.
This code has real long inputs and takes 476 second on my machine.

I've got to find a way to optimise it more.

Code: Select all

'===============================================================================
'trig functions by Dodicat from Scotland (From Freebasic Forum)
'===============================================================================
'cosecants
declare function acosech(n as double) as double
declare function  cosech(n as double) as double
declare function  acosec(n as double) as double
declare function   cosec(n as double) as double
'secants
declare function   asech(n as double) as double
declare function    sech(n as double) as double
declare function    asec(n as double) as double
declare function     sec(n as double) as double
'cotangents       
declare function   acoth(n as double) as double
declare function    coth(n as double) as double
declare function    acot(n as double) as double
declare function     cot(n as double) as double
'tangents       
declare function   atanh(n as double) as double
declare function    tanh(n as double) as double
declare function    atan(n as double) as double
'declare function     tan(n as double) as double 'builtin
'cosines       
declare function   acosh(n as double) as double
declare function    cosh(n as double) as double
'declare function    acos(n as double) as double 'builtin
'declare function     cos(n as double) as double 'builtin
'sines       
declare function   asinh(n as double) as double
declare function    sinh(n as double) as double
'declare function    asin(n as double) as double  'builtin
'declare function     sin(n as double) as double  'builtin
'===============================================================================
'
'===============================================================================
declare function        Setup(byval str1  as string) as string   'calls SpaceOut() , Prep_Formula()
declare function     SpaceOut(byval eq    as string) as string   'called by SetUp takes out spaces
declare function   eval_funct(byval funct as string) as ubyte    'called by prep_formula returns CHR() for function name
declare function prep_formula(byval eq    as string) as string   'replaces function names with CHR() returned by eval_funct()
declare function   VarReplace(byval eq    as string) as string   'replaces variable names in string with values
declare function      ParseEq(byval eq    as string) as double   'recursive descent parser
'===============================================================================
'set up graphics screen
'===============================================================================
dim as integer xres,yres
screen 19
screeninfo xres,yres
screenres xres,yres
'===============================================================================
'set up radius and get screen centers
'===============================================================================
dim as double xctr=xres/2
dim as double yctr=yres/2
dim as integer radius = 125
'===============================================================================
'===============================================================================
dim as double deg1
dim as double deg1_start =  0
dim as double deg1_end   =360
dim as double deg1_inc   =  1
dim as double d1
dim as double r1         =atn(1)/45
dim as double c1
dim as double s1

dim as double deg2
dim as double deg2_start =  0
dim as double deg2_end   =360
dim as double deg2_inc   =  1
dim as double d2
dim as double r2         =atn(1)/45
dim as double c2
dim as double s2
'===============================================================================
'===============================================================================
'dimension string for ParseEq function
dim shared as string eq
'===============================================================================
'===============================================================================
'dimension user variables and values arrays;
'both must have the same number of dimensions , Values() is filled in during looping.
'dimensions allowed are (0 to 16) which equate to chr(239) to chr(255)
dim shared as string*1   chars(0 to 7) ' function replaces this with a char
dim shared as double    values(0 to 7)
dim shared as string variables(0 to 7)
'when assigning variable names,
'make sure to put ones with other ones substrings first.
variables(0)="r1"
variables(1)="d1"
variables(2)="c1"
variables(3)="s1"

variables(4)="r2"
variables(5)="d2"
variables(6)="c2"
variables(7)="s2"

Values(0)=r1
'Values(1)=d1
'Values(2)=c1
'Values(3)=s1
Values(4)=r2
'Values(5)=d2
'Values(6)=c2
'Values(7)=s2

'===============================================================================
'===============================================================================
'dimension and assign input strings
dim as string input_x1 = "(c1*cos(cos(d2*r2)*s2/c1)*cos(d2*r2*(c1*c2)/s1)*cos(s1*d2*r2)*c2*s1*2.7) + (.1*c1*cos(cos(d2*r2)*s2/c1)*cos(d2*r2*(c1*c2)/s1)*cos(s1*d2*r2)*c2*s1*2.7)/1.5"
dim as string input_x2 = "(c1*cos(cos(d2*r2)*s2/c1)*cos(d2*r2*(c1*c2)/s1)*cos(s1*d2*r2)*c2*s1*2.7) + (.1*c1*cos(cos(d2*r2)*s2/c1)*cos(d2*r2*(c1*c2)/s1)*cos(s1*d2*r2)*c2*s1*2.7)/1.5"
dim as string input_y1 = "(s1*sin(sin(d2*r2)*c2/s1)*sin(d2*r2*(s1*s2)/c1)*sin(c1*d2*r2)*c2*s1*2.7) + (.1*s1*sin(sin(d2*r2)*c2/s1)*sin(d2*r2*(s1*s2)/c1)*sin(c1*d2*r2)*c2*s1*2.7)/1.5"
dim as string input_y2 = "(s1*sin(sin(d2*r2)*c2/s1)*sin(d2*r2*(s1*s2)/c1)*sin(c1*d2*r2)*c2*s1*2.7) + (.1*s1*sin(sin(d2*r2)*c2/s1)*sin(d2*r2*(s1*s2)/c1)*sin(c1*d2*r2)*c2*s1*2.7)/1.5"
dim as string input_z1 = "c2+s2"

'dimension final outputs
dim as double out_x1
dim as double out_x2
dim as double out_y1
dim as double out_y2
dim as double out_z1

'Call SetUp( str ) to trim white space and turn input string into single chr() function calls ie..( "acotan" = chr(??) )
input_x1 = SetUp(input_x1)
input_x2 = SetUp(input_x2)
input_y1 = SetUp(input_y1)
input_y2 = SetUp(input_y2)
input_z1 = SetUp(input_z1)

'===============================================================================
'do double 360 loop
'===============================================================================
dim as double t1, t2
t1=timer
   
    for d1 = deg1_start to deg1_end step deg1_inc
       
        'd1=deg1
        c1=cos(d1*r1)
        s1=sin(d1*r1)
           
        'Values(0)=r1
        Values(1)=d1
        Values(2)=c1
        Values(3)=s1
       
        for d2= deg2_start to deg2_end step deg2_inc
       
            'd2=deg2
            c2=cos(d2*r2)
            s2=sin(d2*r2)
           
            'Values(4)=r2
            Values(5)=d2
            Values(6)=c2
            Values(7)=s2
           
            eq = input_x1 : eq = VarReplace(eq) : out_x1 = radius * ParseEq(eq)
            eq = input_y1 : eq = VarReplace(eq) : out_y1 = radius * ParseEq(eq)
           
            eq = input_x2 : eq = VarReplace(eq) : out_x2 = radius * ParseEq(eq)
            eq = input_y2 : eq = VarReplace(eq) : out_y2 = radius * ParseEq(eq)
           
            eq = input_z1 : eq = VarReplace(eq) : out_z1 = radius * ParseEq(eq)
           
            pset( xctr + out_x1 + out_x2 , yctr + out_y1 + out_y2 ),9
           
        next
       
    next

t2=timer
print "Elapsed time = " ; (t2-t1)

sleep
END
'===============================================================================
'===============================================================================
'===============================================================================
'FUNCTIONS and SUBS BELOW HERE...
'===============================================================================
'===============================================================================
'===============================================================================
function Setup(byval str1 as string) as string
    dim as string inputs
    inputs = Lcase(str1)
    inputs = SpaceOut(inputs)      'extract white space
    Inputs = Prep_Formula(inputs)  'change all function calls and operators to single ubyte character.
    return inputs
end function

'===============================================================================
'===============================================================================
function SpaceOut(byval eq as string ) as string
    dim as string parse, parse_l , parse_r
    dim as integer spaces
    spaces=instr(1,eq," ")
    do while spaces<>0
        parse_l = left( eq, spaces - 1 )
        parse_r =  mid( eq, spaces + 1 )
        parse = parse_l + parse_r
        eq = parse
        spaces=instr(1,eq," ")
    loop
    return eq
end function
'===============================================================================
'===============================================================================
function eval_funct(byval funct as string) as ubyte
    select case funct
        case "+"      :return 200+0
        case "-"      :return 200+1
        case "*"      :return 200+2
        case "\"      :return 200+3
        case "/"      :return 200+3
        case "^"      :return 200+4
       
        case "log"    :return 200+5
       
        case "acosech":return 200+6
        case "cosech" :return 200+7
        case "acosec" :return 200+8
        case "cosec"  :return 200+9
       
        case "asech"  :return 200+10
        case "sech"   :return 200+11
        case "asec"   :return 200+12
        case "sec"    :return 200+13
       
        case "acotanh":return 200+14
        case "cotanh" :return 200+15
        case "acotan" :return 200+16
        case "cotan"  :return 200+17
       
        case "atanh"  :return 200+18
        case "tanh"   :return 200+19
        case "atan"   :return 200+20
        case "tan"    :return 200+21
       
        case "acosh"  :return 200+22
        case "cosh"   :return 200+23
        case "acos"   :return 200+24
        case "cos"    :return 200+25
       
        case "asinh"  :return 200+26
        case "sinh"   :return 200+27
        case "asin"   :return 200+28
        case "sin"    :return 200+29
       
        case "xor"    :return 200+30
        case "or"     :return 200+31
        case "and"    :return 200+32
        case "not"    :return 200+33
       
        case "imp"    :return 200+34
        case "eqv"    :return 200+35
       
        case "mod"    :return 200+36
       
        case "("      :return 200+37
        case ")"      :return 200+38
       
        case else
            return asc(funct)
    end select
   
end function

'===============================================================================
'===============================================================================
function prep_formula(byval eq as string) as string
    '===============================================================================
    '===============================================================================
    '===============================================================================
    'get trancendental functions
    'search in order of to avoid substring occurance (acotan) before (tan) etc...
    '                                                (acosech) befor (cos) etc..
    '===============================================================================
    '===============================================================================
    '===============================================================================
    dim as string str1 = eq
    dim as integer funct_loc
    'log   
    funct_loc = instr(1,str1,"log")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("log")) + mid(str1,funct_loc+3)
        funct_loc = instr(1,str1,"log")
    loop
    '===============================================================================
    'cosecants
    '===============================================================================
    'acosech
     funct_loc = instr(1,str1,"acosech")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("acosech")) + mid(str1,funct_loc+7)
        funct_loc = instr(1,str1,"acosech")
    loop
    'cosech
     funct_loc = instr(1,str1,"cosech")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("cosech")) + mid(str1,funct_loc+6)
        funct_loc = instr(1,str1,"cosech")
    loop
    'acosec
     funct_loc = instr(1,str1,"acosec")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("acosec")) + mid(str1,funct_loc+6)
        funct_loc = instr(1,str1,"acosec")
    loop
    'cosec 
     funct_loc = instr(1,str1,"cosec")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("cosec")) + mid(str1,funct_loc+5)
        funct_loc = instr(1,str1,"cosec")
    loop
    '===============================================================================
    'secants
    '===============================================================================
    'asech 
     funct_loc = instr(1,str1,"asech")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("asech")) + mid(str1,funct_loc+5)
        funct_loc = instr(1,str1,"asech")
    loop
    'sech   
     funct_loc = instr(1,str1,"sech")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("sech")) + mid(str1,funct_loc+4)
        funct_loc = instr(1,str1,"sech")
    loop
    'asec   
     funct_loc = instr(1,str1,"asec")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("asec")) + mid(str1,funct_loc+4)
        funct_loc = instr(1,str1,"asec")
    loop
    'sec   
     funct_loc = instr(1,str1,"sec")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("sec")) + mid(str1,funct_loc+3)
        funct_loc = instr(1,str1,"sec")
    loop
    '===============================================================================
    'cotangents
    '===============================================================================
    'acoth
     funct_loc = instr(1,str1,"acoth")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("acoth")) + mid(str1,funct_loc+5)
        funct_loc = instr(1,str1,"acoth")
    loop
    'cotanh
     funct_loc = instr(1,str1,"coth")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("coth")) + mid(str1,funct_loc+4)
        funct_loc = instr(1,str1,"coth")
    loop
    'acotan
     funct_loc = instr(1,str1,"acot")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("acot")) + mid(str1,funct_loc+4)
        funct_loc = instr(1,str1,"acot")
    loop
    'cotan 
     funct_loc = instr(1,str1,"cot")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("cot")) + mid(str1,funct_loc+3)
        funct_loc = instr(1,str1,"cot")
    loop
    '===============================================================================
    'tangents
    '===============================================================================
    'atanh 
     funct_loc = instr(1,str1,"atanh")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("atanh")) + mid(str1,funct_loc+5)
        funct_loc = instr(1,str1,"atanh")
    loop
    'tanh   
     funct_loc = instr(1,str1,"tanh")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("tanh")) + mid(str1,funct_loc+4)
        funct_loc = instr(1,str1,"tanh")
    loop
    'atan   
     funct_loc = instr(1,str1,"atan")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("atan")) + mid(str1,funct_loc+4)
        funct_loc = instr(1,str1,"atan")
    loop
    'tan   
     funct_loc = instr(1,str1,"tan")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("tan")) + mid(str1,funct_loc+3)
        funct_loc = instr(1,str1,"tan")
    loop
    '===============================================================================
    'cosines
    '===============================================================================
    'acosh 
     funct_loc = instr(1,str1,"acosh")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("acosh")) + mid(str1,funct_loc+5)
        funct_loc = instr(1,str1,"acosh")
    loop
    'cosh   
     funct_loc = instr(1,str1,"cosh")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("cosh")) + mid(str1,funct_loc+4)
        funct_loc = instr(1,str1,"cosh")
    loop
    'acos   
     funct_loc = instr(1,str1,"acos")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("acos")) + mid(str1,funct_loc+4)
        funct_loc = instr(1,str1,"acos")
    loop
    'cos   
     funct_loc = instr(1,str1,"cos")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("cos")) + mid(str1,funct_loc+3)
        funct_loc = instr(1,str1,"cos")
    loop
    '===============================================================================
    'sines
    '===============================================================================
    'asinh
     funct_loc = instr(1,str1,"asinh")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("asinh")) + mid(str1,funct_loc+5)
        funct_loc = instr(1,str1,"asinh")
    loop
    'sinh   
     funct_loc = instr(1,str1,"sinh")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("sinh")) + mid(str1,funct_loc+4)
        funct_loc = instr(1,str1,"sinh")
    loop
    'asin   
     funct_loc = instr(1,str1,"asin")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("asin")) + mid(str1,funct_loc+4)
        funct_loc = instr(1,str1,"asin")
    loop
    'sin   
     funct_loc = instr(1,str1,"sin")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("sin")) + mid(str1,funct_loc+3)
        funct_loc = instr(1,str1,"sin")
    loop
    '===============================================================================
    '===============================================================================
    'end of trancendentals
    '===============================================================================
    '===============================================================================
    '===============================================================================
    'regular math symbols
    '===============================================================================
    '+ PLUS   
     funct_loc = instr(1,str1,"+")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("+")) + mid(str1,funct_loc+1)
        funct_loc = instr(1,str1,"+")
    loop
    '- MINUS   
     funct_loc = instr(1,str1,"-")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("-")) + mid(str1,funct_loc+1)
        funct_loc = instr(1,str1,"-")
    loop
    '* MULTIPLY   
     funct_loc = instr(1,str1,"*")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("*")) + mid(str1,funct_loc+1)
        funct_loc = instr(1,str1,"*")
    loop
    '\ FLOAT DIVIDE   
     funct_loc = instr(1,str1,"/")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("/")) + mid(str1,funct_loc+1)
        funct_loc = instr(1,str1,"/")
    loop
    '/ INTEGER DIVIDE  , integer divide is replaced with float divide in ParseEq()
     funct_loc = instr(1,str1,"\")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("\")) + mid(str1,funct_loc+1)
        funct_loc = instr(1,str1,"\")
    loop
    '^ EXPONENT   
     funct_loc = instr(1,str1,"^")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("^")) + mid(str1,funct_loc+1)
        funct_loc = instr(1,str1,"^")
    loop
    '===============================================================================
    'regular logic
    '===============================================================================
    'XOR   
     funct_loc = instr(1,str1,"xor")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("xor")) + mid(str1,funct_loc+3)
        funct_loc = instr(1,str1,"xor")
    loop
    'OR   
     funct_loc = instr(1,str1,"or")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("or")) + mid(str1,funct_loc+2)
        funct_loc = instr(1,str1,"or")
    loop
    'AND   
     funct_loc = instr(1,str1,"and")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("and")) + mid(str1,funct_loc+3)
        funct_loc = instr(1,str1,"and")
    loop
    'NOT   
     funct_loc = instr(1,str1,"not")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("not")) + mid(str1,funct_loc+3)
        funct_loc = instr(1,str1,"not")
    loop
    'IMP   
     funct_loc = instr(1,str1,"imp")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("imp")) + mid(str1,funct_loc+3)
        funct_loc = instr(1,str1,"imp")
    loop
    'EQV   
     funct_loc = instr(1,str1,"eqv")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("eqv")) + mid(str1,funct_loc+3)
        funct_loc = instr(1,str1,"eqv")
    loop
    'MOD   
     funct_loc = instr(1,str1,"mod")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("mod")) + mid(str1,funct_loc+3)
        funct_loc = instr(1,str1,"mod")
    loop
    '===============================================================================
    'parenthesis
    '===============================================================================
    '(   
     funct_loc = instr(1,str1,"(")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("(")) + mid(str1,funct_loc+1)
        funct_loc = instr(1,str1,"(")
    loop
    ')   
     funct_loc = instr(1,str1,")")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct(")")) + mid(str1,funct_loc+1)
        funct_loc = instr(1,str1,")")
    loop
    '===============================================================================
    'USER VARIABLES in Variables() array
    '===============================================================================
    dim as integer inc
    for inc = lbound(Variables) to ubound(Variables)
        chars(inc)=chr(239+inc)
        funct_loc = instr( 1 , str1 , Variables(inc) )
        do while funct_loc<>0
            if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(239+inc) + mid(str1,funct_loc+len(Variables(inc)))
            funct_loc = instr( 1 , str1 , Variables(inc) )
        loop
    next
    return str1
end function
'===============================================================================
'===============================================================================
'===============================================================================
'===============================================================================
function VarReplace(byval eq as string) as string
    dim as string str1 = eq
    dim as integer inc , funct_loc
    dim as double value
    for inc = lbound(Chars) to ubound(Chars)
        value = Values(inc)
        funct_loc = instr( 1 , str1 , Chars(inc) )
        do while funct_loc<>0
            str1 = left(str1,funct_loc-1) + str(value) + mid(str1,funct_loc+1)
            funct_loc = instr( 1 , str1 , Chars(inc) )
        loop
    next
    return str1
end function

'===============================================================================
'===============================================================================
'recursive descent parser
'===============================================================================
'===============================================================================
function ParseEq(byval eq as string) as double
    dim as integer indx, tempc, op , curLow=29, curInd, numOfOps=0, numOfPar=1
   
    'get rid of parantheses if they include the whole equation 'ex (234+434*(23+1)) ->  234+434*(23+1)
    if eq[0]=237 and eq[len(eq)-1]=238 then
        for indx = 1 to len(eq)-1           
            if eq[indx]=238 or eq[indx]=237 then numOfPar+=(237-eq[indx])*2+1           
            if numOfPar=0 and indx<>len(eq)-1 then exit for
            if numOfPar=0 and indx=len(eq)-1 then eq=mid$(eq,2,len(eq)-2)
        next
    end if
       
    'find the lowest operator
    for indx = 0 to len(eq)-1
       
        'skip stuff inside parantheses in the operation count
        if eq[indx]=237 then '(
            numOfPar=1
            for tempc = indx+1 to len(eq)-1
                if eq[tempc]=238 or eq[tempc]=237 then numOfPar+=(237-eq[tempc])*2+1           
                indx=tempc+1
                if numOfPar=0 then exit for               
            next
            if indx=len(eq) then exit for 'equation end has been reached           
        end if
       
        op=eq[indx]
        if op >=200 and op<=236 then numOfOps+=1
        if op >=239 and op<=255 then numOfOps+=1
       
        if op = 200 then curLow=-1 : curInd=indx ' +
        if op = 201 then curlow= 1 : curInd=indx ' -       
       
        if op = 202 then if abs(curlow)>1 then curlow= -2 : curInd=indx ' *
        if op = 203 then if abs(curlow)>1 then curlow=  2 : curInd=indx ' / \
       
        if op = 204 then if abs(curlow)>2 then curLow= 03 : curInd=indx ' ^
       
        if op = 205 then if abs(curlow)>3 then curLow= 04 : curInd=indx 'log
       
        if op = 206 then if abs(curlow)>3 then curLow= 05 : curInd=indx 'acosech
        if op = 207 then if abs(curlow)>3 then curLow= 06 : curInd=indx 'cosech
        if op = 208 then if abs(curlow)>3 then curLow= 07 : curInd=indx 'acosec
        if op = 209 then if abs(curlow)>3 then curLow= 08 : curInd=indx 'cosec
       
        if op = 210 then if abs(curlow)>3 then curLow= 09 : curInd=indx 'asech
        if op = 211 then if abs(curlow)>3 then curLow= 10 : curInd=indx 'sech
        if op = 212 then if abs(curlow)>3 then curLow= 11 : curInd=indx 'asec
        if op = 213 then if abs(curlow)>3 then curLow= 12 : curInd=indx 'sec
       
        if op = 214 then if abs(curlow)>3 then curLow= 13 : curInd=indx 'acoth
        if op = 215 then if abs(curlow)>3 then curLow= 14 : curInd=indx 'coth
        if op = 216 then if abs(curlow)>3 then curLow= 15 : curInd=indx 'acot
        if op = 217 then if abs(curlow)>3 then curLow= 16 : curInd=indx 'cot
       
        if op = 218 then if abs(curlow)>3 then curLow= 17 : curInd=indx 'atanh
        if op = 219 then if abs(curlow)>3 then curLow= 18 : curInd=indx 'tanh
        if op = 220 then if abs(curlow)>3 then curLow= 19 : curInd=indx 'atan
        if op = 221 then if abs(curlow)>3 then curLow= 20 : curInd=indx 'tan
       
        if op = 222 then if abs(curlow)>3 then curLow= 21 : curInd=indx 'acosh
        if op = 223 then if abs(curlow)>3 then curLow= 22 : curInd=indx 'cosh
        if op = 224 then if abs(curlow)>3 then curLow= 23 : curInd=indx 'acos
        if op = 225 then if abs(curlow)>3 then curLow= 24 : curInd=indx 'cos
       
        if op = 226 then if abs(curlow)>3 then curLow= 25 : curInd=indx 'asinh
        if op = 227 then if abs(curlow)>3 then curLow= 26 : curInd=indx 'sinh
        if op = 228 then if abs(curlow)>3 then curLow= 27 : curInd=indx 'asin
        if op = 229 then if abs(curlow)>3 then curLow= 28 : curInd=indx 'sin
   
    next
   
    if numOfOps=0 then return val(eq)'single number, no equation to evaluate!
   
    if curLow=-1 then return ParseEq(left$(eq,curInd)) + ParseEq(right$(eq,len(eq)-curInd-1))
    if curLow= 1 then return ParseEq(left$(eq,curInd)) - ParseEq(right$(eq,len(eq)-curInd-1))
    if curLow=-2 then return ParseEq(left$(eq,curInd)) * ParseEq(right$(eq,len(eq)-curInd-1))
    if curLow= 2 then return ParseEq(left$(eq,curInd)) / ParseEq(right$(eq,len(eq)-curInd-1))
    if curLow= 3 then return ParseEq(left$(eq,curInd)) ^ ParseEq(right$(eq,len(eq)-curInd-1))   
   
    if curLow= 04 then return log(     ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
   
    'cosecants
    if curLow= 05 then return acosech( ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
    if curLow= 06 then return  cosech( ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
    if curLow= 07 then return  acosec( ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
    if curLow= 08 then return   cosec( ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
   
    'secants
    if curLow= 09 then return   asech( ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
    if curLow= 10 then return    sech( ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
    if curLow= 11 then return    asec( ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
    if curLow= 12 then return     sec( ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
   
    'cotangents
    if curLow= 13 then return   acoth( ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
    if curLow= 14 then return    coth( ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
    if curLow= 15 then return    acot( ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
    if curLow= 16 then return     cot( ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
   
    'tangents
    if curLow= 17 then return   atanh( ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
    if curLow= 18 then return    tanh( ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
    if curLow= 19 then return    atan( ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
    if curLow= 20 then return     tan( ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
   
    'cosines
    if curLow= 21 then return   acosh( ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
    if curLow= 22 then return    cosh( ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
    if curLow= 23 then return    acos( ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
    if curLow= 24 then return     cos( ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
   
    'sines
    if curLow= 25 then return   asinh( ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
    if curLow= 26 then return    sinh( ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
    if curLow= 27 then return    asin( ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
    if curLow= 28 then return     sin( ParseEq(left$(eq,curInd)+right$(eq,len(eq)-curInd-1)) )
   
end function
'===============================================================================
'===============================================================================
'===============================================================================
'begin Dodicats TRIG functions
'(Dodicat from scottland) on http://www.freebasic.net/forum/
'===============================================================================
'cosecants
'===============================================================================
Function acosech(n as double) As Double
    dim x as double = n
    return Log((Sgn(x) * Sqr(x * x + 1) +1) / x)
End Function

Function cosech(n as double) As Double
    dim x as double = n
    return 2 / (Exp(x) - Exp(-x))
End Function

Function acosec(n as double) As Double
    dim x as double = n
    return Atn(x / Sqr(x * x - 1)) + (Sgn(x) - 1) * (2 * Atn(1))
End Function

Function cosec(n as double) As Double
    dim x as double = n
    return 1 / Sin(x)
End Function

'===============================================================================
'secants
'===============================================================================
Function asech(n as double) As Double
    dim x as double = n
    return Log((Sqr(-x * x + 1) + 1) / x)
End Function

Function sech(n as double) As Double
    dim x as double = n
    return 2 / (Exp(x) + Exp(-x))
End Function

Function asec(n as double) As Double
    dim x as double = n
    return Atn(x / Sqr(x * x - 1)) + Sgn((x) -1) * (2 * Atn(1))
End Function

Function sec(n as double) As Double
    dim x as double = n
    return 1 / Cos(x)
End Function

'===============================================================================
' cotangents
'===============================================================================
Function acoth(n as double) As Double
    dim x as double = n
    return Log((x + 1) / (x - 1)) / 2
End Function

Function coth(n as double) As Double
    dim x as double = n
    return (Exp(x) + Exp(-x)) / (Exp(x) - Exp(-x))
End Function

Function acot(n as double) As Double
    dim x as double = n
    return Atn(x) + 2 * Atn(1)
End Function

Function cot(n as double) As Double
    dim x as double = n
    return 1 / Tan(x)
End Function

'===============================================================================
' tangents
'===============================================================================
Function atanh(n as double) As Double
    dim x as double = n
    return Log((1 + x) / (1 - x)) / 2
End Function

Function tanh(n as double) As Double
    dim x as double = n
    return (Exp(x) - Exp(-x)) / (Exp(x) + Exp(-x))
End Function

Function atan(n as double) As Double
    dim x as double = n
    return Atn(x)
End Function   

'Function TAN(n as double) As Double
'    dim x as double = n
'    TAN = tan(x)
'End Function   

'===============================================================================
' cosines
'===============================================================================
Function acosh(n as double) As Double
    dim x as double = n
    return Log(x + Sqr(x * x - 1))
End Function

Function cosh(n as double) As Double
    dim x as double = n
    return (Exp(x) + Exp(-x)) / 2
End Function

'Function Acos(n as double) As Double
'    dim x as double = n
'    ACOS = Atn(-x / Sqr(-x * x + 1)) + 2 * Atn(1)
'End Function

'Function cos(n as double) As Double
'    dim x as double = n
'    COS = cos(x)
'End Function

'===============================================================================
' sines
'===============================================================================
Function asinh(n as double) As Double
    dim x as double = n
    return Log(x + Sqr(x * x + 1))
End Function

Function sinh(n as double) As Double
    dim x as double = n
    return (Exp(x) - Exp(-x)) / 2
End Function

'Function asin(n as double) As Double
'   dim x as double = n
'    asin = Atn(x / Sqr(-x * x + 1))
'End Function

'Function Sin(byval x as doubele ) as double
'    dim x as double = n
'    sin=sin(x)
'End Function

'===============================================================================
'others
'===============================================================================
'Function logN(n as double,Byval n As Double) As Double
'    logN = Log(x) / Log(n)
'End Function

'Function haversine(n as double) As Double
'    haversine = (Sin(x/2))^2
'End Function
'===============================================================================
'END TRANCENDENTALS
'===============================================================================

dodicat
Posts: 6234
Joined: Jan 10, 2006 20:30
Location: Scotland

Postby dodicat » Dec 07, 2011 22:20

Hi Albert

577 seconds here.

But that is a good parser, I tried it out with some stinking functions, and stinking functions inside functions and it returns the correct value.

Maybe, here in squares sometimes, we think that you come up with some way out ideas now and then, but you always cough up the goods.

Some day one of your way out ideas will be a real prize winner.


@ dafhi
Thanks dafhi, I grabbed your code this time before it vanished again, which it has.

What we need now is a sort of sort,to sort to sort out all these sorts.

Your coding is much more sophisticated than mine, and I enjoy reading through it, if I'm fast off the mark to get it.
It is very cool.

Thanks for the optimized combsort in the other thread.
podvornyak
Posts: 148
Joined: Nov 12, 2007 11:46
Location: Russia

Postby podvornyak » Dec 08, 2011 1:22

albert wrote:I've finished the parser

test2.asm:8254: Error: invalid use of operator "EQ"
told to me... ^_^
albert
Posts: 5533
Joined: Sep 28, 2006 2:41
Location: California, USA

Postby albert » Dec 08, 2011 3:08

@Podvornyak

lines 112 , 113 , 114 ,115 , 116 Are the formulas that you can alter.

If you use a variable name that contains a function call;
like var(1) = "cos1" the Prep_Formula() with replace the "cos" part with the function COS() character.
So you have to look through the Eval_Funct() and create variable names that don't have any other functions inside them.

chars(0 to ?) 16 is max as string*1
values(0 to ?) 16 is max as double
variables(0 to ?) 16 is max as string

All three have to be dimensioned to the same number.

Once you got that then you need to call formula = SetUp(formula)
Setup() will go thru the formula calling the other functions and return a string , where all the operators ,parenthesis, functions ,var names are replaced by a single chr(200+).

After that you need to update Variables( ?? ) = ? during the looping.
"eq" is the sting thats passed ByVal to VarReplace() , which changes the variable chr(?) to a double value.

formula = setup(formula)
do
Values(?) = double
eq = formula
eq = VarReplace(eq)
double = ParseEq(eq)
loop

Neither the parser or any of the functions do error checking for mismatched parenthesis.
podvornyak
Posts: 148
Joined: Nov 12, 2007 11:46
Location: Russia

Postby podvornyak » Dec 08, 2011 5:56

albert wrote:@Podvornyak
lines 112 , 113 , 114 ,115 , 116, ..., ...
I'm not good in english. I've change name of variables eq to eq1. Is it harmless? Or i've done something wrong?

Ubuntu 10.04 64
Result 119.*********

Code: Select all

'===============================================================================
'trig functions by Dodicat from Scotland (From Freebasic Forum)
'===============================================================================
'cosecants
declare function acosech(n as double) as double
declare function  cosech(n as double) as double
declare function  acosec(n as double) as double
declare function   cosec(n as double) as double
'secants
declare function   asech(n as double) as double
declare function    sech(n as double) as double
declare function    asec(n as double) as double
declare function     sec(n as double) as double
'cotangents       
declare function   acoth(n as double) as double
declare function    coth(n as double) as double
declare function    acot(n as double) as double
declare function     cot(n as double) as double
'tangents       
declare function   atanh(n as double) as double
declare function    tanh(n as double) as double
declare function    atan(n as double) as double
'declare function     tan(n as double) as double 'builtin
'cosines       
declare function   acosh(n as double) as double
declare function    cosh(n as double) as double
'declare function    acos(n as double) as double 'builtin
'declare function     cos(n as double) as double 'builtin
'sines       
declare function   asinh(n as double) as double
declare function    sinh(n as double) as double
'declare function    asin(n as double) as double  'builtin
'declare function     sin(n as double) as double  'builtin
'===============================================================================
'
'===============================================================================
declare function        Setup(byval str1  as string) as string   'calls SpaceOut() , Prep_Formula()
declare function     SpaceOut(byval eq1    as string) as string   'called by SetUp takes out spaces
declare function   eval_funct(byval funct as string) as ubyte    'called by prep_formula returns CHR() for function name
declare function prep_formula(byval eq1    as string) as string   'replaces function names with CHR() returned by eval_funct()
declare function   VarReplace(byval eq1    as string) as string   'replaces variable names in string with values
declare function      ParseEq(byval eq1    as string) as double   'recursive descent parser
'===============================================================================
'set up graphics screen
'===============================================================================
dim as integer xres,yres
screen 19
screeninfo xres,yres
screenres xres,yres
'===============================================================================
'set up radius and get screen centers
'===============================================================================
dim as double xctr=xres/2
dim as double yctr=yres/2
dim as integer radius = 125
'===============================================================================
'===============================================================================
dim as double deg1
dim as double deg1_start =  0
dim as double deg1_end   =360
dim as double deg1_inc   =  1
dim as double d1
dim as double r1         =atn(1)/45
dim as double c1
dim as double s1

dim as double deg2
dim as double deg2_start =  0
dim as double deg2_end   =360
dim as double deg2_inc   =  1
dim as double d2
dim as double r2         =atn(1)/45
dim as double c2
dim as double s2
'===============================================================================
'===============================================================================
'dimension string for ParseEq function
dim shared as string eq1
'===============================================================================
'===============================================================================
'dimension user variables and values arrays;
'both must have the same number of dimensions , Values() is filled in during looping.
'dimensions allowed are (0 to 16) which equate to chr(239) to chr(255)
dim shared as string*1   chars(0 to 7) ' function replaces this with a char
dim shared as double    values(0 to 7)
dim shared as string variables(0 to 7)
'when assigning variable names,
'make sure to put ones with other ones substrings first.
variables(0)="r1"
variables(1)="d1"
variables(2)="c1"
variables(3)="s1"

variables(4)="r2"
variables(5)="d2"
variables(6)="c2"
variables(7)="s2"

Values(0)=r1
'Values(1)=d1
'Values(2)=c1
'Values(3)=s1
Values(4)=r2
'Values(5)=d2
'Values(6)=c2
'Values(7)=s2

'===============================================================================
'===============================================================================
'dimension and assign input strings
dim as string input_x1 = "(c1*cos(cos(d2*r2)*s2/c1)*cos(d2*r2*(c1*c2)/s1)*cos(s1*d2*r2)*c2*s1*2.7) + (.1*c1*cos(cos(d2*r2)*s2/c1)*cos(d2*r2*(c1*c2)/s1)*cos(s1*d2*r2)*c2*s1*2.7)/1.5"
dim as string input_x2 = "(c1*cos(cos(d2*r2)*s2/c1)*cos(d2*r2*(c1*c2)/s1)*cos(s1*d2*r2)*c2*s1*2.7) + (.1*c1*cos(cos(d2*r2)*s2/c1)*cos(d2*r2*(c1*c2)/s1)*cos(s1*d2*r2)*c2*s1*2.7)/1.5"
dim as string input_y1 = "(s1*sin(sin(d2*r2)*c2/s1)*sin(d2*r2*(s1*s2)/c1)*sin(c1*d2*r2)*c2*s1*2.7) + (.1*s1*sin(sin(d2*r2)*c2/s1)*sin(d2*r2*(s1*s2)/c1)*sin(c1*d2*r2)*c2*s1*2.7)/1.5"
dim as string input_y2 = "(s1*sin(sin(d2*r2)*c2/s1)*sin(d2*r2*(s1*s2)/c1)*sin(c1*d2*r2)*c2*s1*2.7) + (.1*s1*sin(sin(d2*r2)*c2/s1)*sin(d2*r2*(s1*s2)/c1)*sin(c1*d2*r2)*c2*s1*2.7)/1.5"
dim as string input_z1 = "c2+s2"

'dimension final outputs
dim as double out_x1
dim as double out_x2
dim as double out_y1
dim as double out_y2
dim as double out_z1

'Call SetUp( str ) to trim white space and turn input string into single chr() function calls ie..( "acotan" = chr(??) )
input_x1 = SetUp(input_x1)
input_x2 = SetUp(input_x2)
input_y1 = SetUp(input_y1)
input_y2 = SetUp(input_y2)
input_z1 = SetUp(input_z1)

'===============================================================================
'do double 360 loop
'===============================================================================
dim as double t1, t2
t1=timer
   
    for d1 = deg1_start to deg1_end step deg1_inc
       
        'd1=deg1
        c1=cos(d1*r1)
        s1=sin(d1*r1)
           
        'Values(0)=r1
        Values(1)=d1
        Values(2)=c1
        Values(3)=s1
       
        for d2= deg2_start to deg2_end step deg2_inc
       
            'd2=deg2
            c2=cos(d2*r2)
            s2=sin(d2*r2)
           
            'Values(4)=r2
            Values(5)=d2
            Values(6)=c2
            Values(7)=s2
           
            eq1 = input_x1 : eq1 = VarReplace(eq1) : out_x1 = radius * ParseEq(eq1)
            eq1 = input_y1 : eq1 = VarReplace(eq1) : out_y1 = radius * ParseEq(eq1)
           
            eq1 = input_x2 : eq1 = VarReplace(eq1) : out_x2 = radius * ParseEq(eq1)
            eq1 = input_y2 : eq1 = VarReplace(eq1) : out_y2 = radius * ParseEq(eq1)
           
            eq1 = input_z1 : eq1 = VarReplace(eq1) : out_z1 = radius * ParseEq(eq1)
           
            pset( xctr + out_x1 + out_x2 , yctr + out_y1 + out_y2 ),9
           
        next
       
    next

t2=timer
print "Elapsed time = " ; (t2-t1)

sleep
END
'===============================================================================
'===============================================================================
'===============================================================================
'FUNCTIONS and SUBS BELOW HERE...
'===============================================================================
'===============================================================================
'===============================================================================
function Setup(byval str1 as string) as string
    dim as string inputs
    inputs = Lcase(str1)
    inputs = SpaceOut(inputs)      'extract white space
    Inputs = Prep_Formula(inputs)  'change all function calls and operators to single ubyte character.
    return inputs
end function

'===============================================================================
'===============================================================================
function SpaceOut(byval eq1 as string ) as string
    dim as string parse, parse_l , parse_r
    dim as integer spaces
    spaces=instr(1,eq1," ")
    do while spaces<>0
        parse_l = left( eq1, spaces - 1 )
        parse_r =  mid( eq1, spaces + 1 )
        parse = parse_l + parse_r
        eq1 = parse
        spaces=instr(1,eq1," ")
    loop
    return eq1
end function
'===============================================================================
'===============================================================================
function eval_funct(byval funct as string) as ubyte
    select case funct
        case "+"      :return 200+0
        case "-"      :return 200+1
        case "*"      :return 200+2
        case ""      :return 200+3
        case "/"      :return 200+3
        case "^"      :return 200+4
       
        case "log"    :return 200+5
       
        case "acosech":return 200+6
        case "cosech" :return 200+7
        case "acosec" :return 200+8
        case "cosec"  :return 200+9
       
        case "asech"  :return 200+10
        case "sech"   :return 200+11
        case "asec"   :return 200+12
        case "sec"    :return 200+13
       
        case "acotanh":return 200+14
        case "cotanh" :return 200+15
        case "acotan" :return 200+16
        case "cotan"  :return 200+17
       
        case "atanh"  :return 200+18
        case "tanh"   :return 200+19
        case "atan"   :return 200+20
        case "tan"    :return 200+21
       
        case "acosh"  :return 200+22
        case "cosh"   :return 200+23
        case "acos"   :return 200+24
        case "cos"    :return 200+25
       
        case "asinh"  :return 200+26
        case "sinh"   :return 200+27
        case "asin"   :return 200+28
        case "sin"    :return 200+29
       
        case "xor"    :return 200+30
        case "or"     :return 200+31
        case "and"    :return 200+32
        case "not"    :return 200+33
       
        case "imp"    :return 200+34
        case "eqv"    :return 200+35
       
        case "mod"    :return 200+36
       
        case "("      :return 200+37
        case ")"      :return 200+38
       
        case else
            return asc(funct)
    end select
   
end function

'===============================================================================
'===============================================================================
function prep_formula(byval eq1 as string) as string
    '===============================================================================
    '===============================================================================
    '===============================================================================
    'get trancendental functions
    'search in order of to avoid substring occurance (acotan) before (tan) etc...
    '                                                (acosech) befor (cos) etc..
    '===============================================================================
    '===============================================================================
    '===============================================================================
    dim as string str1 = eq1
    dim as integer funct_loc
    'log   
    funct_loc = instr(1,str1,"log")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("log")) + mid(str1,funct_loc+3)
        funct_loc = instr(1,str1,"log")
    loop
    '===============================================================================
    'cosecants
    '===============================================================================
    'acosech
     funct_loc = instr(1,str1,"acosech")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("acosech")) + mid(str1,funct_loc+7)
        funct_loc = instr(1,str1,"acosech")
    loop
    'cosech
     funct_loc = instr(1,str1,"cosech")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("cosech")) + mid(str1,funct_loc+6)
        funct_loc = instr(1,str1,"cosech")
    loop
    'acosec
     funct_loc = instr(1,str1,"acosec")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("acosec")) + mid(str1,funct_loc+6)
        funct_loc = instr(1,str1,"acosec")
    loop
    'cosec
     funct_loc = instr(1,str1,"cosec")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("cosec")) + mid(str1,funct_loc+5)
        funct_loc = instr(1,str1,"cosec")
    loop
    '===============================================================================
    'secants
    '===============================================================================
    'asech
     funct_loc = instr(1,str1,"asech")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("asech")) + mid(str1,funct_loc+5)
        funct_loc = instr(1,str1,"asech")
    loop
    'sech   
     funct_loc = instr(1,str1,"sech")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("sech")) + mid(str1,funct_loc+4)
        funct_loc = instr(1,str1,"sech")
    loop
    'asec   
     funct_loc = instr(1,str1,"asec")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("asec")) + mid(str1,funct_loc+4)
        funct_loc = instr(1,str1,"asec")
    loop
    'sec   
     funct_loc = instr(1,str1,"sec")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("sec")) + mid(str1,funct_loc+3)
        funct_loc = instr(1,str1,"sec")
    loop
    '===============================================================================
    'cotangents
    '===============================================================================
    'acoth
     funct_loc = instr(1,str1,"acoth")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("acoth")) + mid(str1,funct_loc+5)
        funct_loc = instr(1,str1,"acoth")
    loop
    'cotanh
     funct_loc = instr(1,str1,"coth")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("coth")) + mid(str1,funct_loc+4)
        funct_loc = instr(1,str1,"coth")
    loop
    'acotan
     funct_loc = instr(1,str1,"acot")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("acot")) + mid(str1,funct_loc+4)
        funct_loc = instr(1,str1,"acot")
    loop
    'cotan
     funct_loc = instr(1,str1,"cot")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("cot")) + mid(str1,funct_loc+3)
        funct_loc = instr(1,str1,"cot")
    loop
    '===============================================================================
    'tangents
    '===============================================================================
    'atanh
     funct_loc = instr(1,str1,"atanh")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("atanh")) + mid(str1,funct_loc+5)
        funct_loc = instr(1,str1,"atanh")
    loop
    'tanh   
     funct_loc = instr(1,str1,"tanh")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("tanh")) + mid(str1,funct_loc+4)
        funct_loc = instr(1,str1,"tanh")
    loop
    'atan   
     funct_loc = instr(1,str1,"atan")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("atan")) + mid(str1,funct_loc+4)
        funct_loc = instr(1,str1,"atan")
    loop
    'tan   
     funct_loc = instr(1,str1,"tan")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("tan")) + mid(str1,funct_loc+3)
        funct_loc = instr(1,str1,"tan")
    loop
    '===============================================================================
    'cosines
    '===============================================================================
    'acosh
     funct_loc = instr(1,str1,"acosh")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("acosh")) + mid(str1,funct_loc+5)
        funct_loc = instr(1,str1,"acosh")
    loop
    'cosh   
     funct_loc = instr(1,str1,"cosh")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("cosh")) + mid(str1,funct_loc+4)
        funct_loc = instr(1,str1,"cosh")
    loop
    'acos   
     funct_loc = instr(1,str1,"acos")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("acos")) + mid(str1,funct_loc+4)
        funct_loc = instr(1,str1,"acos")
    loop
    'cos   
     funct_loc = instr(1,str1,"cos")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("cos")) + mid(str1,funct_loc+3)
        funct_loc = instr(1,str1,"cos")
    loop
    '===============================================================================
    'sines
    '===============================================================================
    'asinh
     funct_loc = instr(1,str1,"asinh")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("asinh")) + mid(str1,funct_loc+5)
        funct_loc = instr(1,str1,"asinh")
    loop
    'sinh   
     funct_loc = instr(1,str1,"sinh")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("sinh")) + mid(str1,funct_loc+4)
        funct_loc = instr(1,str1,"sinh")
    loop
    'asin   
     funct_loc = instr(1,str1,"asin")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("asin")) + mid(str1,funct_loc+4)
        funct_loc = instr(1,str1,"asin")
    loop
    'sin   
     funct_loc = instr(1,str1,"sin")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("sin")) + mid(str1,funct_loc+3)
        funct_loc = instr(1,str1,"sin")
    loop
    '===============================================================================
    '===============================================================================
    'end of trancendentals
    '===============================================================================
    '===============================================================================
    '===============================================================================
    'regular math symbols
    '===============================================================================
    '+ PLUS   
     funct_loc = instr(1,str1,"+")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("+")) + mid(str1,funct_loc+1)
        funct_loc = instr(1,str1,"+")
    loop
    '- MINUS   
     funct_loc = instr(1,str1,"-")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("-")) + mid(str1,funct_loc+1)
        funct_loc = instr(1,str1,"-")
    loop
    '* MULTIPLY   
     funct_loc = instr(1,str1,"*")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("*")) + mid(str1,funct_loc+1)
        funct_loc = instr(1,str1,"*")
    loop
    '\ FLOAT DIVIDE   
     funct_loc = instr(1,str1,"/")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("/")) + mid(str1,funct_loc+1)
        funct_loc = instr(1,str1,"/")
    loop
    '/ INTEGER DIVIDE  , integer divide is replaced with float divide in ParseEq()
     funct_loc = instr(1,str1,"")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("")) + mid(str1,funct_loc+1)
        funct_loc = instr(1,str1,"")
    loop
    '^ EXPONENT   
     funct_loc = instr(1,str1,"^")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("^")) + mid(str1,funct_loc+1)
        funct_loc = instr(1,str1,"^")
    loop
    '===============================================================================
    'regular logic
    '===============================================================================
    'XOR   
     funct_loc = instr(1,str1,"xor")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("xor")) + mid(str1,funct_loc+3)
        funct_loc = instr(1,str1,"xor")
    loop
    'OR   
     funct_loc = instr(1,str1,"or")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("or")) + mid(str1,funct_loc+2)
        funct_loc = instr(1,str1,"or")
    loop
    'AND   
     funct_loc = instr(1,str1,"and")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("and")) + mid(str1,funct_loc+3)
        funct_loc = instr(1,str1,"and")
    loop
    'NOT   
     funct_loc = instr(1,str1,"not")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("not")) + mid(str1,funct_loc+3)
        funct_loc = instr(1,str1,"not")
    loop
    'IMP   
     funct_loc = instr(1,str1,"imp")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("imp")) + mid(str1,funct_loc+3)
        funct_loc = instr(1,str1,"imp")
    loop
    'EQV   
     funct_loc = instr(1,str1,"eqv")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("eqv")) + mid(str1,funct_loc+3)
        funct_loc = instr(1,str1,"eqv")
    loop
    'MOD   
     funct_loc = instr(1,str1,"mod")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("mod")) + mid(str1,funct_loc+3)
        funct_loc = instr(1,str1,"mod")
    loop
    '===============================================================================
    'parenthesis
    '===============================================================================
    '(   
     funct_loc = instr(1,str1,"(")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct("(")) + mid(str1,funct_loc+1)
        funct_loc = instr(1,str1,"(")
    loop
    ')   
     funct_loc = instr(1,str1,")")
    do while funct_loc<>0
        if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(eval_funct(")")) + mid(str1,funct_loc+1)
        funct_loc = instr(1,str1,")")
    loop
    '===============================================================================
    'USER VARIABLES in Variables() array
    '===============================================================================
    dim as integer inc
    for inc = lbound(Variables) to ubound(Variables)
        chars(inc)=chr(239+inc)
        funct_loc = instr( 1 , str1 , Variables(inc) )
        do while funct_loc<>0
            if funct_loc<>0 then str1 = left(str1,funct_loc-1) + chr(239+inc) + mid(str1,funct_loc+len(Variables(inc)))
            funct_loc = instr( 1 , str1 , Variables(inc) )
        loop
    next
    return str1
end function
'===============================================================================
'===============================================================================
'===============================================================================
'===============================================================================
function VarReplace(byval eq1 as string) as string
    dim as string str1 = eq1
    dim as integer inc , funct_loc
    dim as double value
    for inc = lbound(Chars) to ubound(Chars)
        value = Values(inc)
        funct_loc = instr( 1 , str1 , Chars(inc) )
        do while funct_loc<>0
            str1 = left(str1,funct_loc-1) + str(value) + mid(str1,funct_loc+1)
            funct_loc = instr( 1 , str1 , Chars(inc) )
        loop
    next
    return str1
end function

'===============================================================================
'===============================================================================
'recursive descent parser
'===============================================================================
'===============================================================================
function ParseEq(byval eq1 as string) as double
    dim as integer indx, tempc, op , curLow=29, curInd, numOfOps=0, numOfPar=1
   
    'get rid of parantheses if they include the whole equation 'ex (234+434*(23+1)) ->  234+434*(23+1)
    if eq1[0]=237 and eq1[len(eq1)-1]=238 then
        for indx = 1 to len(eq1)-1           
            if eq1[indx]=238 or eq1[indx]=237 then numOfPar+=(237-eq1[indx])*2+1           
            if numOfPar=0 and indx<>len(eq1)-1 then exit for
            if numOfPar=0 and indx=len(eq1)-1 then eq1=mid$(eq1,2,len(eq1)-2)
        next
    end if
       
    'find the lowest operator
    for indx = 0 to len(eq1)-1
       
        'skip stuff inside parantheses in the operation count
        if eq1[indx]=237 then '(
            numOfPar=1
            for tempc = indx+1 to len(eq1)-1
                if eq1[tempc]=238 or eq1[tempc]=237 then numOfPar+=(237-eq1[tempc])*2+1           
                indx=tempc+1
                if numOfPar=0 then exit for               
            next
            if indx=len(eq1) then exit for 'equation end has been reached           
        end if
       
        op=eq1[indx]
        if op >=200 and op<=236 then numOfOps+=1
        if op >=239 and op<=255 then numOfOps+=1
       
        if op = 200 then curLow=-1 : curInd=indx ' +
        if op = 201 then curlow= 1 : curInd=indx ' -       
       
        if op = 202 then if abs(curlow)>1 then curlow= -2 : curInd=indx ' *
        if op = 203 then if abs(curlow)>1 then curlow=  2 : curInd=indx ' / \
       
        if op = 204 then if abs(curlow)>2 then curLow= 03 : curInd=indx ' ^
       
        if op = 205 then if abs(curlow)>3 then curLow= 04 : curInd=indx 'log
       
        if op = 206 then if abs(curlow)>3 then curLow= 05 : curInd=indx 'acosech
        if op = 207 then if abs(curlow)>3 then curLow= 06 : curInd=indx 'cosech
        if op = 208 then if abs(curlow)>3 then curLow= 07 : curInd=indx 'acosec
        if op = 209 then if abs(curlow)>3 then curLow= 08 : curInd=indx 'cosec
       
        if op = 210 then if abs(curlow)>3 then curLow= 09 : curInd=indx 'asech
        if op = 211 then if abs(curlow)>3 then curLow= 10 : curInd=indx 'sech
        if op = 212 then if abs(curlow)>3 then curLow= 11 : curInd=indx 'asec
        if op = 213 then if abs(curlow)>3 then curLow= 12 : curInd=indx 'sec
       
        if op = 214 then if abs(curlow)>3 then curLow= 13 : curInd=indx 'acoth
        if op = 215 then if abs(curlow)>3 then curLow= 14 : curInd=indx 'coth
        if op = 216 then if abs(curlow)>3 then curLow= 15 : curInd=indx 'acot
        if op = 217 then if abs(curlow)>3 then curLow= 16 : curInd=indx 'cot
       
        if op = 218 then if abs(curlow)>3 then curLow= 17 : curInd=indx 'atanh
        if op = 219 then if abs(curlow)>3 then curLow= 18 : curInd=indx 'tanh
        if op = 220 then if abs(curlow)>3 then curLow= 19 : curInd=indx 'atan
        if op = 221 then if abs(curlow)>3 then curLow= 20 : curInd=indx 'tan
       
        if op = 222 then if abs(curlow)>3 then curLow= 21 : curInd=indx 'acosh
        if op = 223 then if abs(curlow)>3 then curLow= 22 : curInd=indx 'cosh
        if op = 224 then if abs(curlow)>3 then curLow= 23 : curInd=indx 'acos
        if op = 225 then if abs(curlow)>3 then curLow= 24 : curInd=indx 'cos
       
        if op = 226 then if abs(curlow)>3 then curLow= 25 : curInd=indx 'asinh
        if op = 227 then if abs(curlow)>3 then curLow= 26 : curInd=indx 'sinh
        if op = 228 then if abs(curlow)>3 then curLow= 27 : curInd=indx 'asin
        if op = 229 then if abs(curlow)>3 then curLow= 28 : curInd=indx 'sin
   
    next
   
    if numOfOps=0 then return val(eq1)'single number, no equation to evaluate!
   
    if curLow=-1 then return ParseEq(left$(eq1,curInd)) + ParseEq(right$(eq1,len(eq1)-curInd-1))
    if curLow= 1 then return ParseEq(left$(eq1,curInd)) - ParseEq(right$(eq1,len(eq1)-curInd-1))
    if curLow=-2 then return ParseEq(left$(eq1,curInd)) * ParseEq(right$(eq1,len(eq1)-curInd-1))
    if curLow= 2 then return ParseEq(left$(eq1,curInd)) / ParseEq(right$(eq1,len(eq1)-curInd-1))
    if curLow= 3 then return ParseEq(left$(eq1,curInd)) ^ ParseEq(right$(eq1,len(eq1)-curInd-1))   
   
    if curLow= 04 then return log(     ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
   
    'cosecants
    if curLow= 05 then return acosech( ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
    if curLow= 06 then return  cosech( ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
    if curLow= 07 then return  acosec( ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
    if curLow= 08 then return   cosec( ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
   
    'secants
    if curLow= 09 then return   asech( ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
    if curLow= 10 then return    sech( ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
    if curLow= 11 then return    asec( ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
    if curLow= 12 then return     sec( ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
   
    'cotangents
    if curLow= 13 then return   acoth( ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
    if curLow= 14 then return    coth( ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
    if curLow= 15 then return    acot( ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
    if curLow= 16 then return     cot( ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
   
    'tangents
    if curLow= 17 then return   atanh( ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
    if curLow= 18 then return    tanh( ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
    if curLow= 19 then return    atan( ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
    if curLow= 20 then return     tan( ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
   
    'cosines
    if curLow= 21 then return   acosh( ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
    if curLow= 22 then return    cosh( ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
    if curLow= 23 then return    acos( ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
    if curLow= 24 then return     cos( ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
   
    'sines
    if curLow= 25 then return   asinh( ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
    if curLow= 26 then return    sinh( ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
    if curLow= 27 then return    asin( ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
    if curLow= 28 then return     sin( ParseEq(left$(eq1,curInd)+right$(eq1,len(eq1)-curInd-1)) )
   
end function
'===============================================================================
'===============================================================================
'===============================================================================
'begin Dodicats TRIG functions
'(Dodicat from scottland) on http://www.freebasic.net/forum/
'===============================================================================
'cosecants
'===============================================================================
Function acosech(n as double) As Double
    dim x as double = n
    return Log((Sgn(x) * Sqr(x * x + 1) +1) / x)
End Function

Function cosech(n as double) As Double
    dim x as double = n
    return 2 / (Exp(x) - Exp(-x))
End Function

Function acosec(n as double) As Double
    dim x as double = n
    return Atn(x / Sqr(x * x - 1)) + (Sgn(x) - 1) * (2 * Atn(1))
End Function

Function cosec(n as double) As Double
    dim x as double = n
    return 1 / Sin(x)
End Function

'===============================================================================
'secants
'===============================================================================
Function asech(n as double) As Double
    dim x as double = n
    return Log((Sqr(-x * x + 1) + 1) / x)
End Function

Function sech(n as double) As Double
    dim x as double = n
    return 2 / (Exp(x) + Exp(-x))
End Function

Function asec(n as double) As Double
    dim x as double = n
    return Atn(x / Sqr(x * x - 1)) + Sgn((x) -1) * (2 * Atn(1))
End Function

Function sec(n as double) As Double
    dim x as double = n
    return 1 / Cos(x)
End Function

'===============================================================================
' cotangents
'===============================================================================
Function acoth(n as double) As Double
    dim x as double = n
    return Log((x + 1) / (x - 1)) / 2
End Function

Function coth(n as double) As Double
    dim x as double = n
    return (Exp(x) + Exp(-x)) / (Exp(x) - Exp(-x))
End Function

Function acot(n as double) As Double
    dim x as double = n
    return Atn(x) + 2 * Atn(1)
End Function

Function cot(n as double) As Double
    dim x as double = n
    return 1 / Tan(x)
End Function

'===============================================================================
' tangents
'===============================================================================
Function atanh(n as double) As Double
    dim x as double = n
    return Log((1 + x) / (1 - x)) / 2
End Function

Function tanh(n as double) As Double
    dim x as double = n
    return (Exp(x) - Exp(-x)) / (Exp(x) + Exp(-x))
End Function

Function atan(n as double) As Double
    dim x as double = n
    return Atn(x)
End Function   

'Function TAN(n as double) As Double
'    dim x as double = n
'    TAN = tan(x)
'End Function   

'===============================================================================
' cosines
'===============================================================================
Function acosh(n as double) As Double
    dim x as double = n
    return Log(x + Sqr(x * x - 1))
End Function

Function cosh(n as double) As Double
    dim x as double = n
    return (Exp(x) + Exp(-x)) / 2
End Function

'Function Acos(n as double) As Double
'    dim x as double = n
'    ACOS = Atn(-x / Sqr(-x * x + 1)) + 2 * Atn(1)
'End Function

'Function cos(n as double) As Double
'    dim x as double = n
'    COS = cos(x)
'End Function

'===============================================================================
' sines
'===============================================================================
Function asinh(n as double) As Double
    dim x as double = n
    return Log(x + Sqr(x * x + 1))
End Function

Function sinh(n as double) As Double
    dim x as double = n
    return (Exp(x) - Exp(-x)) / 2
End Function

'Function asin(n as double) As Double
'   dim x as double = n
'    asin = Atn(x / Sqr(-x * x + 1))
'End Function

'Function Sin(byval x as doubele ) as double
'    dim x as double = n
'    sin=sin(x)
'End Function

'===============================================================================
'others
'===============================================================================
'Function logN(n as double,Byval n As Double) As Double
'    logN = Log(x) / Log(n)
'End Function

'Function haversine(n as double) As Double
'    haversine = (Sin(x/2))^2
'End Function
'===============================================================================
'END TRANCENDENTALS
'===============================================================================
albert
Posts: 5533
Joined: Sep 28, 2006 2:41
Location: California, USA

Postby albert » Dec 08, 2011 14:16

@podvornyak

If you change EQ or eq to eq1 or EQ1 then you need to change it all accros the board thruought all functions where its passed or referenced.

If your using FBIDE then Just a replace eq , eq1 should work.
It should work fine then. If you use FBEdit , i'm not sure but i think a global search and replace would be the same or similar.

I'm still working on the whole thing , I want to put it into
"Trigonometry_Designer_GL_V2" my current program i'm working on.

I'm thinking of taking out the operators (+-/\*^) and parenthesis from being replaced by a chr(). right now it replaces all the trig and normal functions and parenthesis with a single character chr(200+).

So if you want to change a something you have to recode all the (sortof enums) in eval_funct() and match them with changes in ParseEq().

The parenthesis in ParseEQ() are also encoded in eval_funct() ,i think as 237,238.. User variables start at 239 and can go to 255. I might change that to start at a lower value to allow more than 16 user variables.

But the prog i'm going to use it in ( Trigonometry_Designer_GL_v2 ) will only allow for x1,y1, x2,y2 , z1. which is how i got the whole thing set up already. just yet to add ATAN2(?,?) and Dodicats HaverSine() functions.
albert
Posts: 5533
Joined: Sep 28, 2006 2:41
Location: California, USA

Postby albert » Dec 08, 2011 14:36

@podvornyak

After looking at your above post of the code, It looks like all occurrences of eq are replaced with eq1 and it should work fine.

I looked in all functions and it seems to be eq1 all the way through.

My own computer and Dodicat's didn't show any errors. and Dodicat has as least two computers , running both Windows and Linux???

The only thing i could imagine as a possible error would be to change a variable name to something that has another function inside it:
like Variable(?) = "cosine1" where both "cos" and "sin" are other functions. it would replace cosine with chr(?)ine and "ine"would throw an error
albert
Posts: 5533
Joined: Sep 28, 2006 2:41
Location: California, USA

Postby albert » Dec 08, 2011 14:47

@podvornyak

Sorry!!!
I copied and pasted your posted code of my code and it ran fine in Windows7 64 bit.

But like i posted, it takes 400+ seconds on a 2Ghz Dual-Core to complete the whole thing with the real long formulas in x1,y1,x2,y2.
Which is what i was doing is benchmarking the ParsaeEq() function against Dodicats previously posted Parser.

I can't imagine where your error is coming from.
You are more experienced than me in coding and i have used your OpenGL and MultiKey() code in my programs.
podvornyak
Posts: 148
Joined: Nov 12, 2007 11:46
Location: Russia

Postby podvornyak » Dec 08, 2011 21:17

albert wrote:I can't imagine where your error is coming
Asm Operator "EQ"
Description: the "EQ" operator compares the first and second operands and returns a value of 0 (false) if the two operands are not equal or a value of 1 (true) if the two operands are equal.
albert wrote:You are more experienced than me in coding

Nope... More theory experienced. Anyway... Try to avoid two char variable names in future. I'm already naming my functions and variables with full names because of this. More time for keyboarding but more insurance and self-speaking code... Like this:

Code: Select all

...
engine.video.width = 320
with engine
    .video.height = 240
    with .video
        .bit = 16
    end with
    .start
end with
....
with engine.video
    .begin
    ...
    .finish
end with
...

Also more typing experience. :D
albert
Posts: 5533
Joined: Sep 28, 2006 2:41
Location: California, USA

Postby albert » Dec 09, 2011 1:53

Is that what the problem was the 2 letter EQ was geting mixed up with an Assembly instruction??

When you name your variables it searches and replaces them, with INSTR() , which can screw up if you have a variable named "cosine" and one named "sine" and sine comes first in the variable name array().

Its supposed to fill a GL list or array with all the points and then go to GL mode and do your multikey rotating stuff.
podvornyak
Posts: 148
Joined: Nov 12, 2007 11:46
Location: Russia

Postby podvornyak » Dec 09, 2011 2:59

albert wrote:Is that what the problem was the 2 letter EQ was geting mixed up with an Assembly instruction??
It is.
up.. Finally i've figure out what do u mean when ask about spheres in dna sample. I think so... To display OpenGL point as circle, not as rectangle - glEnable GL_POINT_SMOOTH. I've reinstall system and i've jump on to 0.23 fbc. That problem appear on all my doodles. Actually it was something wrong with my system - all points drawing as circles.
dodicat
Posts: 6234
Joined: Jan 10, 2006 20:30
Location: Scotland

Postby dodicat » Dec 16, 2011 3:01

Higg's Bosun

Code: Select all


Screen 19,32
Dim As Integer xres,yres
Screeninfo xres,yres
Type v3
    As Single x,y
End Type
Operator +(a As v3,b As v3) As v3
Return Type(a.x+b.x,a.y+b.y)
End Operator
Operator * (a As v3,b As Single) As v3
Return Type(b*a.x,b*a.y)
End Operator
#define rr(f,l) (Rnd*(l-f)+f)
#define distance(p1,p2) sqr( (p1.x-p2.x)*(p1.x-p2.x)+(p1.y-p2.y)*(p1.y-p2.y))
#define length(p1) sqr( (p1.x)*(p1.x)+(p1.y)*(p1.y))
#define normalize(p1) type<v3>( p1.x/(length(p1)),p1.y/(length(p1)))
#macro rotate(pivot,p,a,scale1,scale2)
var rotx=scale1*(Cos(a*.0174533)*(p.x-pivot.x)-Sin(a*.0174533)*(p.y-pivot.y))+pivot.x
var roty=scale2*(Sin(a*.0174533)*(p.x-pivot.x)+Cos(a*.0174533)*(p.y-pivot.y))+pivot.y
#endmacro
#macro check_boundary(v)
If v.x>xres Then: vel(n).x=-vel(n).x:start(n)=Type(xres,v.y):t(n)=0:End If
If v.x<0 Then: vel(n).x=-vel(n).x:start(n)=Type(0,v.y):t(n)=0:End If
If v.y>yres Then: vel(n).y=-vel(n).y:start(n)=Type(v.x,yres):t(n)=0:End If
If v.y<0 Then: vel(n).y=-vel(n).y:start(n)=Type(v.x,0):t(n)=0:End If
#endmacro

Dim As Integer z, num=10500
Dim Shared As v3 a(num),ca(num),start(num),vel(num),temp,gravity=Type(0,.01)
Dim Shared As Single t(num),rad(num)
Dim Shared As Uinteger colour(num)
Dim As v3 pivot=Type(xres/2,.8*yres)
Dim As Single ang,dist,k=1,yk=1

For n As Integer=1 To Ubound(a)
    z=255*(n-1)/(Ubound(a)-1)
    a(n)=Type(rr(0,xres),rr((.8*yres),yres))
    rad(n)=rr(2,7)
    start(n)=a(n)
    ca(n)=a(n)
    vel(n)=Type(rr(-1,1),rr(-1,1))
    vel(n)=normalize(vel(n))
    colour(n)=Rgb(z,100,0)
Next n

Do
    ang=ang+.1
    pivot.x=pivot.x+1*k
    If pivot.x>xres Then k=-k
    If pivot.x<0 Then k=-k
   
    pivot.y=pivot.y+1*yk
    If pivot.y>yres Then yk=-yk
    If pivot.y<0 Then yk=-yk
   
    Screenlock
    Cls
   
    For n As Integer=1 To Ubound(a)
        t(n)=t(n)+1
        dist=distance(a(n),pivot)
        If dist < xres/2 Then
            rotate(pivot,ca(n),ang,1,1)
            temp=Type(rotx,roty)
            start(n)=temp
            t(n)=0
        End If
        check_boundary(ca(n))
        ca(n)=start(n)+vel(n)*t(n)+gravity*(.5*t(n)*t(n))
        Circle(ca(n).x,ca(n).y),rad(n),colour(n),,,,f
    Next n
    Locate 1,1
    Print length(vel(77))
    Screenunlock
    Sleep 1,1
Loop Until Inkey=Chr(27)
Sleep



albert
Posts: 5533
Joined: Sep 28, 2006 2:41
Location: California, USA

Postby albert » Dec 16, 2011 4:46

@Dodicat

How long di it take you to come up with that??
Thats way cool. some complex coding..

I've been studying Assmebly language and reading all the Intel/AMD TECHNICAL DOCS.

Some Intel opcodes AMD doesn't have and AMD has some opcodes that Intel doesn't.
So writing an assembler for both, i guess you just got to skip the non-both opcodes.
dafhi
Posts: 1329
Joined: Jun 04, 2005 9:51

Postby dafhi » Dec 16, 2011 6:28

looks great dodi
D.J.Peters
Posts: 8019
Joined: May 28, 2005 3:28
Contact:

Postby D.J.Peters » Dec 16, 2011 15:06

for dodicat and albert
your old example without the MS script engine
the part of gfx are the same

you have 26 vars from "a-z" or "A-Z"

e.g. SetVar("B",value) is the same as SetVar("b",value)

Joshy

Code: Select all

type float as single ' or double
declare sub Unary        (byref Result as float)
declare sub Parenthesized(byref Result as float)
declare sub Exponent     (byref Result as float)
declare sub MulDiv       (byref Result as float)
declare sub AddSub       (byref result as float)
declare sub GetToken

enum TokenTypes
  EOL
  DELIMETER
  NUMBER   ' integer or float
  IDENT    ' function or var
end enum

dim shared as string  Expression,Token,Char
dim shared as integer LenExpression,TokenType,CurrentPos,CharA
dim shared as float Vars(25)

sub sError(sErr as string)
  print "Error: " & sErr & " !"
  beep:sleep:end
end sub

' SetVar("A",123.456)
sub SetVar(nam as string,value as float)
  nam = trim(nam)
  if len(nam)<>1 then
    serror("name of var '" & nam & "' has more then one letter ('A'...'Z')")
  else 
    dim as integer index = asc(ucase(nam))-65
    if (index<0) or (index>25) then
      serror("var name '" & nam & "' is out of range (A...Z)")
    else
      Vars(index)=value
    end if
  end if 
end sub
' value = GetVar("R")
function GetVar(v as string) as float
  dim as integer index = asc(v)-65
  if (index<0) or (index>25) then
    serror("GetVar '" & v & "' is out of range (A...Z)")
  else
    return Vars(index)
  end if
end function

' 0-9
function IsDigit() as integer
  dim as integer aChar=asc(Char)
  return ((aChar>47) and (aChar<58))
end function
' a-z,A-Z
function IsAlpha() as integer
  dim as integer aChar=asc(Char)
  return ((aChar>64) and (aChar<91))
end function
' " ", TAB
function IsWhite() as integer
  dim as integer aChar=asc(Char)
  return ((aChar=32) or (aChar=9))
end function
' -+/*^()
function IsDelimeter() as integer
  dim as integer aChar=asc(Char)
  if aChar=9 then return 1
  return (instr("-+/*^()",Char)>0)
end function
' math
function IsFunction() as integer
  return (instr("ABS,ATN,COS,RND,SIN,TAN",Token)>0)
end function

' "A"..."Z" ?
function IsVar() as integer
  if len(Token)<>1 then return 0
  dim as integer aChar=asc(token)
  return ((aChar>64) and (aChar<91))
end function

sub GetChar
  CurrentPos+=1
  if CurrentPos>lenExpression then
    char="":return
  end if
  Char=mid(Expression,CurrentPos,1)
end sub

sub GetToken()
  GetChar
  if Char="" then
    Token     = ""
    TokenType = EOL
    return
  end if
 
  if IsDelimeter() then
    Token     = Char
    TokenType = DELIMETER
    return
  end if


  if IsDigit() then
    Token = ""
    while IsDelimeter()=0 and Char<>""
      Token = Token & Char : GetChar
    wend
    TokenType = NUMBER
    CurrentPos-=1
    return
  end if
 
  if IsAlpha() then
    Token = ""
    while IsAlpha() and Char<>""
      Token = Token & Char : GetChar
    wend
    TokenType = IDENT
    CurrentPos-=1
    return
  end if
end sub

' priority 1 (higest in math)
sub Parenthesized(byref Result as float)
  if (Token ="(") and (TokenType = DELIMETER) then
    GetToken()
    AddSub(Result)
    if( Token <> ")") then
      serror("unbalanced round brackets")
    end if
    GetToken()
  else
    select case TokenType
    case NUMBER : Result = val(Token) : GetToken
    case IDENT
      if IsVar() then
        Result = GetVar(Token) : GetToken
      elseif IsFunction() then
        dim as string Func = Token
        dim as float res  = result
        GetToken:Parenthesized(res)
        select case Func
        case "ABS":result=abs(res)
        case "ATN":result=atn(res)
        case "COS":result=cos(res)
        case "RND":result=rnd(res)
        case "SIN":result=sin(res)
        case "TAN":result=tan(res)
        case else : serror("ident '" & func & "' isn't a function")
        end select
      else
        serror("ident '" & token & "' isn't a var or function")
      end if
    end select
  end if
end sub

' priority 2
sub Unary(byref Result as float)
  dim as string Op
  if (TokenType=DELIMETER) then
    if ((Token="+") or (Token="-")) then
      Op = Token : GetToken()
    end if 
  end if
  Parenthesized(Result)
  if (Op="-") then Result = -Result
end sub

' priority 3
sub Exponent(byref Result as float)
  Unary(Result)
  if (Token="^") then
    GetToken()
    dim as float Temp
    Exponent(Temp)
    result ^= temp
  end if
end sub

' priority 4
sub MulDiv(byref Result as float)
  dim as string Op
  dim as float Temp
  Exponent(Result)
  Op=Token
  while Op = "*" or Op = "/"
    GetToken()
    Exponent(Temp)
    if op="*" then
      result*=temp
    elseif op="/" then
      result/=temp
    else
      sError("wrong operator '" & Op & "' /,* are ecxepted") 
    end if
    'DoMath(Op,Result,Temp)
    Op = Token
  wend
end sub
' priority 5 (lowest in math)
sub AddSub(byref Result as float)
  MulDiv(result)
  dim as string Op=Token
  dim as float Temp
  while Op = "+" or Op = "-"
    GetToken()
    MulDiv(Temp)
    if op="-" then
      result-=temp
    elseif op="+" then
      result+=temp
    else
      sError("wrong operator '" & Op & "' +,- are ecxepted") 
    end if
    'DoMath(Op,Result,Temp)
    Op = Token
  wend
end sub

function Solver(e as string) as float
  dim as float result
  e=trim(e)
  LenExpression=len(e)
  ' no expression at all
  if LenExpression<1 then return 0
  e=ucase(e)
  Expression=e ' make expression global
  CurrentPos=0 ' read read pointer
  GetToken()
  ' start with lowest priority
  AddSub(result)
  return result
end function

 'progress
Type bar
    As Integer x,y,l,d,percent
    As Uinteger col
End Type
Dim As Integer percentage
#define progress(value,lower,upper) 100*(value-lower)/(upper-lower)

Sub progressbar(b As bar)
    Line(b.x+1,b.y+1)-( (b.l*b.percent/100+b.x),b.y+b.d-1),b.col,bf
    Line(b.x,b.y)-(b.x+b.l,b.y+b.d),,b
End Sub
Dim  As bar b
b=Type<bar>(100,300,600,20,0,Rgb(0,0,200))
 
 

Dim Shared As Integer xres,yres
Screen 20,32
Screeninfo xres,yres

Type vector3d
    As Single x,y,z
End Type

#define vct type<vector3d>

#define distance(p1,p2) sqr((p1.x-p2.x)*(p1.x-p2.x)+(p1.y-p2.y)*(p1.y-p2.y))

#macro incircle(cx,cy,radius,x,y)
(cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
#endmacro

Dim Shared As vector3d eyepoint
Dim Shared Rx(1 To 3,1 To 3) As Single
Dim Shared Ry(1 To 3,1 To 3) As Single
Dim Shared Rz(1 To 3,1 To 3) As Single
Dim Shared pivot_vector(1 To 3) As Single
Dim Shared new_pos(1 To 3) As Single
Dim Shared temp1(1 To 3) As Single
Dim Shared temp2(1 To 3) As Single

Operator + (v1 As vector3d,v2 As vector3d) As vector3d
  Return Type<vector3d>(v1.x+v2.x,v1.y+v2.y,v1.z+v2.z)
End Operator

Operator -(v1 As vector3d,v2 As vector3d) As vector3d
  Return Type<vector3d>(v1.x-v2.x,v1.y-v2.y,v1.z-v2.z)
End Operator

Operator * (f As Single,v1 As vector3d) As vector3d
  Return Type<vector3d>(f*v1.x,f*v1.y,f*v1.z)
End Operator

Function r(first As Double, last As Double) As Double
  Function = Rnd * (last - first) + first
End Function

Function apply_perspective(p As vector3d) As vector3d
  Dim As Single w=(p.z*(-1)/300+1)*.75
  Return vct((p.x-eyepoint.x)/w+eyepoint.x,(p.y-eyepoint.y)/w+eyepoint.y,(p.z-eyepoint.z)/w+eyepoint.z)
End Function

Sub framecounter
  Static As Double t1=0
  static as integer frames
  frames+=1
  If frames mod 16=0 Then
    dim as double t2 = Timer
    dim as integer fps = 16/(t2-t1)
    Windowtitle "Frames per second = " & fps
    t1=t2
  End If
End Sub

    #macro mv(m1,v,ans)
    For i As Integer=1 To 3
        s=0
        For k As Integer = 1 To 3
            s=s+m1(i,k)*v(k)
        Next k
        ans(i)=s
    Next i
    #endmacro
    #define cr 0.0174532925199433

Function rotatepoint3d( _
  Byval pivot As vector3d,_
  Byval pt As vector3d,_
  Byval angle As vector3d,_
  Byval dilator As Single=1) As vector3d

  Dim angle_radians As vector3d=Type<vector3d>(cr*angle.x,cr*angle.y,cr*angle.z)
   
    Dim s As Single
    pivot_vector(1)=(pt.x-pivot.x)*dilator
    pivot_vector(2)=(pt.y-pivot.y)*dilator
    pivot_vector(3)=(pt.z-pivot.z)*dilator
   
    'rotat1on matrices about the three axix
    Rx(1,1)=1:Rx(1,2)=0:Rx(1,3)=0
    Rx(2,1)=0:Rx(2,2)=Cos(angle_radians.x):Rx(2,3)=-Sin(angle_radians.x)
    Rx(3,1)=0:Rx(3,2)=Sin(angle_radians.x):Rx(3,3)=Cos(angle_radians.x)
   
    Ry(1,1)=Cos(angle_radians.y):Ry(1,2)=0:Ry(1,3)=Sin(angle_radians.y)
    Ry(2,1)=0:Ry(2,2)=1:Ry(2,3)=0
    Ry(3,1)=-Sin(angle_radians.y):Ry(3,2)=0:Ry(3,3)=Cos(angle_radians.y)
   
    Rz(1,1)=Cos(angle_radians.z):Rz(1,2)=-Sin(angle_radians.z):Rz(1,3)=0
    Rz(2,1)=Sin(angle_radians.z):Rz(2,2)=Cos(angle_radians.z):Rz(2,3)=0
    Rz(3,1)=0:Rz(3,2)=0:Rz(3,3)=1
   
    mv (Rx,pivot_vector,temp1)           
    mv (Ry,temp1,temp2)
    mv (Rz,temp2,new_pos)
   
    new_pos(1)=new_pos(1)+pivot.x
    new_pos(2)=new_pos(2)+pivot.y
    new_pos(3)=new_pos(3)+pivot.z
   
    Return Type<vector3d>(new_pos(1),new_pos(2),new_pos(3))
End Function

Sub blow(a() As vector3d,mag As Single)
    For z As Integer=1 To Ubound(a)
        a(z)=mag*a(z)
    Next z
End Sub

Sub translate(a() As vector3d,pt As vector3d)
    For z As Integer=1 To Ubound(a)
        a(z)=a(z)+vct(pt.x,pt.y,pt.z)
    Next z
End Sub


Function vertex(piv As vector3d,p1 As vector3d,ang As vector3d,dil As Single,col As Uinteger) As Single
    var _temp1=rotatepoint3d(piv,p1,ang,dil)
    _temp1=apply_perspective(_temp1)

    'Circle(_temp1.x,_temp1.y),(20*Abs(dil)+Abs(_temp1.z/2)*1*dil),col,,,,f
    pset (_temp1.x,_temp1.y),col
    Return _temp1.z
End Function

Sub set_perspective(x As Single,y As Single,z As Single,minz As Single,maxz As Single)
    eyepoint=vct(x,y,z)
End Sub
#macro combsort(array,comp)
Scope
    var size=Ubound(array),switch=0,j=0
    Dim As Single void=size
    Do
        void=void/1.3: If void<1 Then void=1
        switch=0
        For i As Integer =1 To size-void
            j=i+void
            If comp(i)>comp(j) Then
                Swap array(i),array(j): switch=1
                Swap comp(i),comp(j)
                Swap col(i),col(j)
            End If
        Next
    Loop Until  switch =0 And void=1
End Scope
#endmacro

Redim Shared As vector3d e(0)
Dim count As Integer
Redim Shared As Uinteger col(0)
dim as single funct
dim as single dist
dim as vector3d pt,cent=type<vector3d>(0,0)

dim as string formula,worker
worker="(sin(x)+cos(6-x)*sin(-y)+cos(6-y)-2*cos(x^2))/d"
locate 3,3
print "Example function sin(x)*cos(y)"
print "You can also use d as a variable, which is distance from origin"
print "E.G. (sin(2*d)/(2*d))*5"
input "Enter a function or press [enter]",formula
if formula="" then formula=worker

For x As Single=-5 To 5 Step .101
  setvar("x",x)
  For y As Single=-5 To 5 Step .101
    setvar("y",y)
    pt=type<vector3d>(x,y)
    dist=distance(pt,cent)
    setvar("d",dist)
    count=count+1
    Redim Preserve e(count)
    Redim Preserve col(count)
    col(count)=Rgb(255*(x+5)/10,155*(y+5)/10,50)
    funct=Solver(formula)
    e(count)=Type<vector3d>(x,y,funct)
  Next y
  percentage=progress(x,-5,5)
  b.percent=percentage
  progressbar(b)
Next x

blow(e(),80)

translate(e(),vct(xres/2,yres/2,0))

set_perspective(xres/2,yres/2,0,-100,100)


Dim As Single dilation=.2
Dim As vector3d piv,ang
piv=eyepoint

Dim As String i
Dim As Single zeds(1 to Ubound(e)),_mw
Dim As Uinteger colour
Dim As Integer mx,my,mw
Dim As Single startdilation=.2

dilation=startdilation

dim as any pointer im=imagecreate(xres,yres)
paint im,(0,0),rgb(255,255,255)


Do
    framecounter
    i=Inkey
    if i= chr(255) + "K"  then ang.x=ang.x+5
    if i= chr(255) + "M"  then ang.x=ang.x-5
    if i= chr(255) + "P"  then ang.y=ang.y-5
    if i= chr(255) + "H"  then ang.y=ang.y+5
    'ang.y=ang.y+.7
    'ang.x=ang.x+.5
    'ang.z=ang.z+.25
    Screenlock
    'Cls
    put(0,0),im,pset
    draw string (20,20), "Use up/down keys and mouse wheel",rgb(0,0,0)
    draw string(20,50), "z= " & formula,rgb(0,0,0)
    Getmouse mx,my,mw
    _mw=mw/100
    combsort(e,zeds)
    dilation=startdilation+_mw
    For z As Integer=1 To Ubound(e)
        zeds(z)=vertex(piv,e(z),ang,dilation,col(z))
    Next z
    Screenunlock
    Sleep 10
Loop Until i=Chr(27)
imagedestroy im
Sleep

Return to “General”

Who is online

Users browsing this forum: No registered users and 3 guests