'Form created with the help of Freeform 3
'Generated on Jan 09, 2003 at 17:46:25
'diff_eq-parser.bas
'PROGRAM WRITTEN BY INGEMAR BJERLE Dec 2002, ingemar.bjerle@telia.com
'The program is using an eval-subroutine written by Neil Tremblay
'neiltrem@hotmail.com, lcsoft.5u.com
    print  " SOLVING of max 5 first order diff. eq."
    print " and max 2 functions"
    print "         Test cases"
    print "         *** case1 ***"
    print " d2y/dx2+.25*y-8=0"
    print " dY/dX)=U and dU/dX=8-.25*Y: these eq. are introduced in the program"
    print " Boundary conditions: XIN=0, XEND=5; DU/DX=11.95"
    PRINT " FILE EXPERIMENTAL DATA=SIMP1.DAT"
    print""
    print ""
    print "         *** case3 ***"
    print " A-->B-->C "
    print "  k1  k2"
    print " dc1/dx=-k1*c1, dc2/dx=k1*c1-k2*c2, dc3/dx=k2*c2"
    print " DY/DX=-k1*Y,   DU/DX=k1*Y- K2*U,  DZ/DX =k2*U"
    print " Boundary conditions: XIN=0, XEND=100, YIN=.296, UIN=0, ZIN=0"
    print " k1=.02; k2=.05"

nomainwin
    cc=1200
    ee=cc*6 'cc set at top of program
    dim  x(ee):    dim xs(ee):    dim  y(ee):    dim ys(ee)
    dim x1(cc):dim y(cc):dim u(cc):dim z(cc): dim v(cc):dim r(cc)
    StaticText #1.status1, "",       130, 400,200,20'text xy-plot
    StaticText #1.status3, "",        10, 380, 30,20'text xy-plot
    WindowWidth  = 600
    WindowHeight = 450
    UpperLeftX = Int((DisplayWidth-WindowWidth)/2)
    UpperLeftY = Int((DisplayHeight-WindowHeight)/2)
    open " XY-plot:" for graphics_nsb_nf as #1

[setupMainWindow]
    WindowWidth = 580
    WindowHeight = 580
      UpperLeftX = Int((DisplayWidth-WindowWidth)/.5)
    UpperLeftY = Int((DisplayHeight-WindowHeight)/10)
    BackgroundColor$ = "yellow"
    ForegroundColor$ = "black"
     textboxColor$ = "white"
    statictext #w.status3,"",        40, 290, 80,  30'file loaded
    statictext #w.status5,"",       160, 273, 220, 15'recNum
       textbox #w.t0,               470, 140,  50, 25'runge step
    statictext #w.ta0, "step runge",465, 120,  70, 20'dydx
       textbox #w.t1,                45,  42, 280, 28'dydx
       textbox #w.t2,                45,  67, 280, 28'dudx
    statictext #w.stat4, "dY/dX",     5,  47,  38, 25
    statictext #w.stat5, "dU/dX",     5,  72,  38, 25
    statictext #w.stat7, "differential equations", 110, 17, 130, 25
       textbox #w.t3,                45,  92, 280, 28'dzdx
    statictext #w.stat9, "dZ/dX",     5,  97,  38, 25
       textbox #w.t4,                45, 117, 280, 28'dvdx
    statictext #w.stat9, "dV/dX",     5, 117,  38, 25
       textbox #w.t5,                45, 142, 280, 26'drdx
    statictext #w.stat11, "dR/dX",    5, 142,  38, 25
    statictext #w.stat14,"functions",140,168,  52, 18
       textbox #w.t6,                45, 187, 280, 28'V
       textbox #w.t7,                45, 212, 280, 25'R
    statictext #w.stat17, "V",       20, 187,   9, 20
    statictext #w.stat18, "R",       20, 212,  10, 20
       textbox #w.b1,               375,  42,  50, 25'Yin
       textbox #w.b2,               375,  67,  50, 25'Uin
       textbox #w.b3,               375,  92,  50, 25'Zin
       textbox #w.b4,               375, 117,  50, 25'Vin
       textbox #w.b5,               375, 142,  50, 25'Rin
       textbox #w.b6,               375, 187,  50, 25'Xin
       textbox #w.b7,               375, 212,  50, 25'Xout

    statictext #w.stat123, "1",     326,  42,  15, 20
    statictext #w.stat126, "2",     326,  67,  15, 20
    statictext #w.stat127, "3",     326,  92,  15, 20
    statictext #w.stat128, "4",     326, 117,  15, 20
    statictext #w.stat129, "5",     326, 142,  15, 20
    statictext #w.stat132, "4",     326, 187,  15, 20
    statictext #w.stat133, "5",     326, 212,  15, 20


    statictext #w.stat23, "Yin",    350, 42,  19, 20
    statictext #w.stat26, "Uin",    350, 67,  19, 20
    statictext #w.stat27, "Zin",    350, 92,  19, 20
    statictext #w.stat28, "Vin",    350, 117, 19, 20
    statictext #w.stat29, "Rin",    350, 142, 19, 20
    statictext #w.stat32, "Xin",    350, 187, 19, 20
    statictext #w.stat33, "Xout",   342, 212, 26, 20
    statictext #w.stat36,"boundary",370,  17, 80, 20
       textbox #w.t37,               70, 245,490, 25'ID text
       textbox #w.t36,               45, 245, 25, 25'ID-nr
    statictext #w.stat39, "ID:",     25, 245, 16, 20
    texteditor #w.res                 5, 325,570,210
    'graphicbox #w.1,                320, 320 ,250, 200

    button #w.b41, "add",         [add.rec],  UL, 125, 290, 65, 25
    button #w.b42, "update",   [update.rec],  UL, 200, 290, 65, 25
    button #w.b43, "previous",   [prev.rec],  UL, 275, 290, 67, 25
    button #w.b44, "next",       [next.rec],  UL, 350, 290, 65, 25
    button #w.b56, "close",          [quit],  UL, 510, 290, 45, 25
    button #w.b61, "start calc",  [startfit], UL, 450, 200,100, 30

    open "Differential equation solver" for window as #w
    print #w, "font ms_sans_serif 0 16"
    print #w.t1, "!font courier 14";
    print #w.t2, "!font ariel 14";
    print #w, "trapclose [quit]"

    axx=2
    open "diff_eq";axx;".dat" for random as #vcl len=1024
    print #w.status3, "diff_eq";axx;".dat"

    print #w.res,"!font Courier 8 ";
    print #w.t37,"!font ariel  10 ";
    print #w.t1, "!font ariel  11 bold ";
    print #w.t2, "!font ariel  11 bold";
    print #w.t3, "!font ariel  11 bold";
    print #w.t4, "!font ariel  11 bold";
    print #w.t5, "!font ariel  11 bold";
    print #w.t6, "!font ariel  11 bold";
    print #w.t7, "!font ariel  11 bold";
    print #w.res,"      *** IMPORTANT ***"
    print #w.res, " The parser is some time sensitive regarding the order of the terms"
    print #w.res, " The parser has fixed calc. order and always starts with parenthesis"
    print #w.res, ""
    print #w.res, " The order of precedence for the math functions is as follows"
    print #w.res, " ( bracket   (3+4)   = 7"
    print #w.res, " ^ power     3^2     = 9"
    print #w.res, " r root      3r27    = 3     a=brc=c^(1/b)"
    print #w.res, " * multiply  4*5     = 20"
    print #w.res, " / divide    12/4    = 3"
    print #w.res, " + add       3+4     = 7"
    print #w.res, " - subtract  12-4    = 8"
    print #w.res, ""
    print #w.res, " A minus sign can be an operator or just a sign. "
    print #w.res, " Collect  terms two and two with negativ signs"
    print #w.res, " and enclose them with parenthesis. Put one of "
    print #w.res, " these  expressions first in the textbox preceeded "
    print #w.res, " by a minus sign. A minus sign as sign must be closely"
    print #w.res, " succeded by the term no space is allowed. For minus "
    print #w.res, " as operator space before and after is allowed."
    print #w.res, " To insert '1-Y-U' write '-Y + -U + 1'"
    print #w.res, " A bracket followed by a '-' must have a space in between"
    print #w.res, " Variables recognized by the parser are: X, Y, U, Z, V, R"
    print #w.res, " XY-plot: plots Y, U, Z, V and R"
    PRINT #w.res,""
    print #w.res, " SOLVING of max 5 first order diff. eq."
    print #w.res, " or max 2 functions + 3 diff. eq"

    Field #vcl, _
    50 as    ID$, _
    50 as   dydx$, _
    50 as   dudx$, _
    50 as   dzdx$, _
    50 as   dvdx$, _
    50 as   drdx$, _
    50 as      V$, _
    50 as      R$, _
    10 as   runge, _
    10 as     Yin, _
    10 as     Uin, _
    10 as     Zin, _
    10 as     Vin, _
    10 as     Rin, _
    10 as     Xin, _
    10 as    Xend, _
    10 as   exfile, _
    10 as     K1, _
    10 as     K2, _
    10 as     K3, _
    10 as     K4, _
    10 as      n, _
    100 as    ID1$, _
    10 as      cs1, _'sum650
    374 as spare,
    goto [next.rec]
    goto [loop]

[display.rec]'sub
    print #w.t0,runge
    print #w.t1,dydx$
    print #w.t2,dudx$
    print #w.t3,dzdx$
    print #w.t4,dvdx$
    print #w.t5,drdx$
    print #w.t6,V$
    print #w.t7,R$
    print #w.t37,ID1$
    print #w.b1,Yin
    print #w.b2,Uin
    print #w.b3,Zin
    print #w.b4,Vin
    print #w.b5,Rin
    print #w.b6,Xin
    print #w.b7,Xend
    return

[validate]'sub
    valid = 1
    print #w.t0, "!contents? runge"
    print #w.t1, "!contents? dydx$"
    print #w.t2, "!contents? dudx$"
    print #w.t3, "!contents? dzdx$"
    print #w.t4, "!contents? dvdx$"
    print #w.t5, "!contents? drdx$"
    print #w.t6, "!contents? V$"
    print #w.t7, "!contents? R$"
    print #w.t37,"!contents? ID1$"
    print #w.b1, "!contents? Yin"
    print #w.b2, "!contents? Uin"
    print #w.b3, "!contents? Zin"
    print #w.b4, "!contents? Vin"
    print #w.b5, "!contents? Rin"
    print #w.b6, "!contents? Xin"
    print #w.b7, "!contents? Xend"
    return

[update.rec]
    gosub [validate]
    if valid = 0 then [loop]
    put #vcl, recNum
    print #w.status5, " recNum: ";recNum;"  has been updated at ";recNum
    goto [loop]

[prev.rec]
    if recNum > 1 then
    recNum = recNum - 1
    get #vcl, recNum
    yy1=lof(#vcl) / 1024
    print #w.t36,recNum
    print #w.t37,ID$
    print #w.status5, "record-Nr=";recNum;":   End of file at ";yy1
    else
    print #w.status5, " Start of file:    End of file at ";yy1
    end if
    gosub [display.rec]
    goto [loop]

[next.rec]
    if recNum < lof(#vcl) / 1024 then
    recNum = recNum + 1
    get #vcl, recNum
    yy1=lof(#vcl) / 1024
    print #w.t36,recNum
    print #w.t37,ID$
    print #w.status5, "record-Nr=";recNum;":   End of file at ";yy1
    end if
    gosub [display.rec]
    goto [loop]

[add.rec]
    gosub [validate]
    if valid = 0 then [loop]
    recNum = lof(#vcl) / 1024 + 1 ' calc location of next record
    put #vcl, recNum
    print #w.status5, " recNum:"; recNum;"  has been added at ";recNum
    rec= lof(#vcl) / 1024
    goto [loop]

[loop]'wait for input
    input r$
    goto [loop]

[startfit]
     gosub [runge2]
     gosub [plot]
     goto [loop]

[ini]'SUB INITIAL CONDITIONS
       print #w.b1,"!contents? YIN"
       print #w.b2,"!contents? UIN"
       print #w.b3,"!contents? ZIN"
       print #w.b4,"!contents? VIN"
       print #w.b5,"!contents? RIN"
       print #w.b6,"!contents? XIN"
       print #w.b7,"!contents? XEND"
       RETURN

[RUNGE]'SUB RUNGE
      rem SOLVING 1-4  FIRST ORDER DIFF. EQ
      rem VARIABLES IN SUBROUTINE:INDEPENTENT: X  DEPENDENT:  Y, U Z V AND R
'           A           B           D           E        L
            A=0:        B=0:        D=0:        E=0:     L=0
 X=X:       Y=Y:        U=U:        Z=Z:       V=V:      R=R:     GOSUB [EQ]
           K1=A*DX:    L1=B*DX:    F1=D*DX:   G1=E*DX:  M1=L*DX
X=X+DX/2:  Y=Y+K1/2:   U=U+L1/2:   Z=Z+F1/2:  V=V+G1/2: R=R+M1/2: GOSUB [EQ]
           K2=A*DX:    L2=B*DX:    F2=D*DX:   G2=E*DX:  M2=L*DX
X=X-DX/2:  Y=Y-K1/2:   U=U-L1/2 :  Z=Z-F1/2:  V=V-G1/2: R=R-M1/2
X=X+DX/2:  Y=Y+K2/2:   U=U+L2/2 :  Z=Z+F2/2:  V=V+G2/2: R=R+M2/2: GOSUB [EQ]
           K3=A*DX:    L3=B*DX:    F3=D*DX:   G3=E*DX:  M3=L*DX
X=X-DX/2:  Y=Y-K2/2:   U=U-L2/2 :  Z=Z-F2/2:  V=V-G2/2: R=R-M2/2
X=X+DX:    Y=Y+K3:     U=U+L3    : Z=Z+F3:    V=V+G3:   R=R+M3:   GOSUB [EQ]
           K4=A*DX:    L4=B*DX:    F4=D*DX:   G4=E*DX:  M4=L*DX
           Y=Y-K3:     U=U-L3    : Z=Z-F3:    V=V-G3:   R=R-M3
        Y=Y+K1/6+K2/3+K3/3+K4/6:      U=U+L1/6+L2/3+L3/3+L4/6
        Z=Z+F1/6+F2/3+F3/3+F4/6:      V=V+G1/6+G2/3+G3/3+G4/6
        R=R+M1/6+M2/3+M3/3+M4/6
        RETURN

[runge2]'calc start points
        PRINT #w.res,""
        print #w.t0, "!contents? runge"
        NN=runge
        N=1
        Y=0:Z=0:U=0:V=0:R=0:X=0
        GOSUB [ini]
        DX=(XEND-XIN)/NN
        N1=len(str$(X)):N2=LEN(STR$(Y)):N6=LEN(STR$(R))
        N3=len(str$(U)):N4=LEN(STR$(Z)):N5=LEN(STR$(V))
        Na1=N1:Na2=N2:Na3=N3:Na4=N4:Na5=N5:Na6=N6
        print #w.res, " ";"X";SPACE$(9-N1);"Y:1";SPACE$(13-N2);
        print #w.res,   "U:2";SPACE$(13-N3);"Z:3";SPACE$(13-N4);
        print #w.res,   "V:4";SPACE$(13-N5);"R:5";SPACE$(13-N6)
        DX=DX/N
         print #w.res,"------------------------------------------------------------------------------------------------"
       FOR K=1 TO NN
         X=XIN:  Y=YIN:  U=UIN: Z=ZIN: V=VIN: R=RIN
          FOR I=1 TO N
           GOSUB [RUNGE]
           'gosub [func]
          NEXT I
          gosub [func]
        N1=len(str$(X)):N2=LEN(STR$(Y)):N6=LEN(STR$(R))
        N3=len(str$(U)):N4=LEN(STR$(Z)):N5=LEN(STR$(V))
        print #w.res," "; X;SPACE$(9-N1);Y;SPACE$(15-N2);
        PRINT #w.res,     U;SPACE$(15-N3);Z;SPACE$(15-N4);
        print #w.res,     V;SPACE$(15-N5);R;SPACE$(15-N6)
        XIN=X:  YIN=Y:  UIN=U: ZIN=Z: VIN=V: RIN=R
        x1(K)=X:y(K)=Y:u(K)=U:z(K)=Z:v(K)=V:r(K)=R
       next K
        print #w.res,"------------------------------------------------------------------------------------------------"
        print #w.res, " ";"X";SPACE$(9-Na1);"Y:1";SPACE$(13-Na2);
        print #w.res,   "U:2";SPACE$(13-Na3);"Z:3";SPACE$(13-Na4);
        print #w.res,   "V:4";SPACE$(13-Na5);"R:5";SPACE$(13-Na6)
        print #w.res,""
    return

[EQ]'SUB EQUATIONS
        REM  DIFF EQ:  D2Y/DX2 + z2*Y -z1=0'case 1
        REM  WRITTEN AS TWO FIRST ORDER:  U=DY/DX:   DU/DX=z1-z2*Y
        REM  BOUNDARY CONDITIONS:
        'A=DY B=DU D=DZ E=DV L=DR
       '******************************
 for i=1 to 5
     if i=1 then print #w.t1, "!contents? Formula$";
     if i=2 then print #w.t2, "!contents? Formula$";
     if i=3 then print #w.t3, "!contents? Formula$";
     if i=4 then print #w.t4, "!contents? Formula$";
     if i=5 then print #w.t5, "!contents? Formula$";
      if len(trim$(Formula$))>0 then
  for ii=1 to 6
    if ii=1 then
      xv$="X":xVar$=str$(X)'valid numerical X converted to string
    end if
    if ii=2 then
      xv$="Y":xVar$=str$(Y)
    end if
    if ii=3 then
      xv$="U":xVar$=str$(U)
    end if
    if ii=4 then
      xv$="Z":xVar$=str$(Z)
    end if
    if ii=5 then
      xv$="V":xVar$=str$(V)
    end if
    if ii=6 then
      xv$="R":xVar$=str$(R)
    end if
    while instr(Formula$,xv$) > 0
        varpos = instr(Formula$,xv$)
        varlen=len(xv$)
        formulalen = len(Formula$)
        formulaleft$ = left$(Formula$,varpos - 1)
        formularight$ = right$(Formula$,formulalen-varpos-varlen+1)
        Formula$ = formulaleft$ + xVar$ + formularight$ 
    wend
  next ii
     Calcresult$ = Formulacalc$(Formula$)
     if i=1 then A=val(Calcresult$)
     if i=2 then B=val(Calcresult$)
     if i=3 then D=val(Calcresult$)
     if i=4 then E=val(Calcresult$)
     if i=5 then L=val(Calcresult$)
     end if
 next i
    return

[func]'SUB FUNCTIONS
 for ii=1 to 2
      if ii=1 then print #w.t6, "!contents? Formula$";
      if ii=2 then print #w.t7, "!contents? Formula$";
        if len(trim$(Formula$))>0 then
   for i=1 to 6
    if i=1 then
      xv$="X":xVar$=str$(X)'valid numerical X converted to string
    end if
    if i=2 then
      xv$="Y":xVar$=str$(Y)
    end if
    if i=3 then
      xv$="U":xVar$=str$(U)
    end if
    if i=4 then
      xv$="Z":xVar$=str$(Z)
    end if
    if i=5 then
      xv$="V":xVar$=str$(V)
    end if
    if i=6 then
      xv$="R":xVar$=str$(R)
    end if
    while instr(Formula$,xv$) > 0
        varpos = instr(Formula$,xv$)
        varlen=len(xv$)
        formulalen = len(Formula$)
        formulaleft$ = left$(Formula$,varpos - 1)
        formularight$ = right$(Formula$,formulalen-varpos-varlen+1)
        Formula$ = formulaleft$ + xVar$ + formularight$ 
    wend
  next i
          Calcresult$ = Formulacalc$(Formula$)
          if ii=1 then V=val(Calcresult$)
          if ii=2 then R=val(Calcresult$)
        end if
 next ii
      return

'***** Functions **************
function Formulacalc$(op$)
    'This function coordindates to resolve the formula and return a result string
    'It calls all of the necessary functions.
    true = 1
    false = 0
    test$ = "(^r*/+-)"
    lentest = len(test$)
    advfunc = false

    while Calcrequired(op$) = true
        for pass = 1 to lentest
            operation$ = mid$(test$,pass,1) 'get math operation
            oppos = instr(op$,operation$,1)  'get first occurance of math op
            if oppos > 0 then
                if operation$ = "-" and oppos = 1 then
                    oppos = instr(op$,operation$,3)
                    exit for
                else
                    exit for
                end if
            end if
        next pass

        select case operation$
            case "("
                clspos = getclsbracket(op$,oppos)
                oplen = len(op$)
                opleft$ = left$(op$,oppos - 1)
                opmid$ = mid$(op$,oppos + 1,clspos - oppos - 1)
                opright$ = right$(op$,oplen-clspos)

                    opmid$ = Formulacalc$(opmid$)   'reduction send again

                if oppos > 3 then
                    func$ = mid$(op$,oppos - 3,4)

                    select case func$
                        case "sin("
                            opmid$ = Sinnum$(opmid$)
                            advfunc = true
                        case "cos("
                            opmid$ = Cosnum$(opmid$)
                            advfunc = true
                        case "tan("
                            opmid$ = Tannum$(opmid$)
                            advfunc = true
                        case "asn("
                            opmid$ = Asnnum$(opmid$)
                            advfunc = true
                        case "acs("
                            opmid$ = Acsnum$(opmid$)
                            advfunc = true
                        case "atn("
                            opmid$ = Atnnum$(opmid$)
                            advfunc = true
                        case "abs("
                            opmid$ = Absnum$(opmid$)
                            advfunc = true
                        case "exp("
                            opmid$ = Expnum$(opmid$)
                            advfunc = true
                        case "log("
                            opmid$ = Lognum$(opmid$)
                            advfunc = true
                        case "int("
                            opmid$ = Intnum$(opmid$)
                            advfunc = true
                        case "sqr("
                            opmid$ = Sqrnum$(opmid$)
                            advfunc = true
                        case "rnd("
                            opmid$ = Rndnum$(opmid$)
                            advfunc = true
                        case "mod("
                            opmid$ = Modnum$(opmid$)
                            advfunc = true
                    end select
                    if advfunc = true then  'remove end characters from left$
                        opleft$ = left$(op$,oppos - 4)
                        advfunc = false
                    end if

                end if

                op$ = opleft$ + opmid$ + opright$

            case "^"
                lvar$ = Getlval$(op$,oppos)
                rvar$ = Getrval$(op$,oppos)
                lvarlen = len(lvar$)
                rvarlen = len(rvar$)
                oplen = len(op$)
                opret$ = Pwrnum$(lvar$,rvar$)
                opleft$ = left$(op$,oppos - lvarlen - 1)
                opright$ = right$(op$,oplen-(oppos + rvarlen))
                op$ = opleft$ + opret$ + opright$

            case "r"
                lvar$ = Getlval$(op$,oppos)
                rvar$ = Getrval$(op$,oppos)
                lvarlen = len(lvar$)
                rvarlen = len(rvar$)
                oplen = len(op$)
                opret$ = Rootnum$(rvar$,lvar$)
                opleft$ = left$(op$,oppos - lvarlen - 1)
                opright$ = right$(op$,oplen-(oppos + rvarlen))
                op$ = opleft$ + opret$ + opright$

            case "*"
                lvar$ = Getlval$(op$,oppos)
                rvar$ = Getrval$(op$,oppos)
                lvarlen = len(lvar$)
                rvarlen = len(rvar$)
                oplen = len(op$)
                opret$ = Multnum$(lvar$,rvar$)
                opleft$ = left$(op$,oppos - lvarlen - 1)
                opright$ = right$(op$,oplen-(oppos + rvarlen))
                op$ = opleft$ + opret$ + opright$

            case "/"
                lvar$ = Getlval$(op$,oppos)
                rvar$ = Getrval$(op$,oppos)
                lvarlen = len(lvar$)
                rvarlen = len(rvar$)
                oplen = len(op$)
                opret$ = Divnum$(lvar$,rvar$)
                opleft$ = left$(op$,oppos - lvarlen - 1)
                opright$ = right$(op$,oplen-(oppos + rvarlen))
                op$ = opleft$ + opret$ + opright$

            case "+"
                lvar$ = Getlval$(op$,oppos)
                rvar$ = Getrval$(op$,oppos)
                lvarlen = len(lvar$)
                rvarlen = len(rvar$)
                oplen = len(op$)
                opret$ = Addnum$(lvar$,rvar$)
                opleft$ = left$(op$,oppos - lvarlen - 1)
                opright$ = right$(op$,oplen-(oppos + rvarlen))
                op$ = opleft$ + opret$ + opright$

            case "-"
                lvar$ = Getlval$(op$,oppos)
                rvar$ = Getrval$(op$,oppos)
                lvarlen = len(lvar$)
                rvarlen = len(rvar$)
                oplen = len(op$)
                opret$ = Subnum$(lvar$,rvar$)
                opleft$ = left$(op$,oppos - lvarlen - 1)
                opright$ = right$(op$,oplen-(oppos + rvarlen))
                op$ = opleft$ + opret$ + opright$

        end select

    wend
    Formulacalc$ = op$

end function

function Calcrequired(calc$)
'copyright 2002 Neil Tremblay
'neiltrem@hotmail.com
'lcsoft.5u.com
    'This function checks to see if more calculations are required
    true = 1
    false = 0
    result = 0
    count = 0
    calc$ = trim$(calc$)
    calclen = len(calc$) + 1
    test$ = "(^r*/+-"

    while result = 0 and count < calclen
        count = count + 1
        x$ = mid$(calc$, count, 1)
        result = instr(test$,x$)
        if result > 0 then
                if result = 7 then
                    if count = 1 then
                        result = 0
                    else
                        if mid$(calc$,count - 1,1) = "e" or mid$(calc$,count-1,1) = "," then
                            result = 0
                        else
                            result = 1
                        end if
                    end if
                else
                    result = 1
                end if
        end if
    wend

    Calcrequired = result

end function

function getclsbracket(op$,openpos) 'get position of corresponding close bracket
    brackets = 1

    while brackets > 0
        openpos = openpos + 1
        ret$ = mid$(op$, openpos, 1)
        if ret$ = ")" then
            brackets = brackets - 1
        else
            if ret$ = "(" then
                brackets = brackets + 1
            end if
        end if

    wend

    getclsbracket = openpos     'openpos becomes the close position

end function

function Addnum$(var1$,var2$)
    var1 = StringtoVal(var1$)
    var2 = StringtoVal(var2$)
    varresult = var1 + var2
    Addnum$ = ValtoString$(varresult)
end function

function Subnum$(var1$,var2$)
    var1 = StringtoVal(var1$)
    var2 = StringtoVal(var2$)
    varresult = var1 - var2
    Subnum$ = ValtoString$(varresult)
end function

function Multnum$(var1$,var2$)
    var1 = StringtoVal(var1$)
    var2 = StringtoVal(var2$)
    varresult = var1 * var2
    Multnum$ = ValtoString$(varresult)
end function

function Divnum$(var1$,var2$)
    var1 = StringtoVal(var1$)
    var2 = StringtoVal(var2$)
    varresult = var1 / var2
    Divnum$ = ValtoString$(varresult)
end function

function Pwrnum$(var1$,var2$)'var1$ is operand var2$ is power to raise
    var1 = StringtoVal(var1$)
    var2 = StringtoVal(var2$)
    varresult = var1^var2
    Pwrnum$ = ValtoString$(varresult)
end function

function Rootnum$(var1$,var2$) 'var1$ operand var2$ is root value
    var1 = StringtoVal(var1$)
    var2 = StringtoVal(var2$)
    varresult = var1^(1/var2)
    Rootnum$ = ValtoString$(varresult)
end function

function Sinnum$(var$)
    var1 = StringtoVal(var$)
    varresult = sin(var1)
    Sinnum$ = ValtoString$(varresult)
end function

function Cosnum$(var$)
    var1 = StringtoVal(var$)
    varresult = cos(var1)
    Cosnum$ = ValtoString$(varresult)
end function

function Tannum$(var$)
    var1 = StringtoVal(var$)
    varresult = tan(var1)
    Tannum$ = ValtoString$(varresult)
end function

function Acsnum$(var$)
    var1 = StringtoVal(var$)
    varresult = acs(var1)
    Acsnum$ = ValtoString$(varresult)
end function

function Asnnum$(var$)
    var1 = StringtoVal(var$)
    varresult = asn(var1)
    Asnnum$ = ValtoString$(varresult)
end function

function Atnnum$(var$)
    var1 = StringtoVal(var$)
    varresult = atn(var1)
    Atnnum$ = ValtoString$(varresult)
end function

function Expnum$(var$)
    var1 = StringtoVal(var$)
    varresult = exp(var1)
    Expnum$ = ValtoString$(varresult)
end function

function Lognum$(var$)
    var1 = StringtoVal(var$)
    varresult = log(var1)
    Lognum$ = ValtoString$(varresult)
end function

function Absnum$(var$)
    var1 = StringtoVal(var$)
    varresult = abs(var1)
    Absnum$ = ValtoString$(varresult)
end function

function Intnum$(var$)
    var1 = StringtoVal(var$)
    varresult = int(var1)
    Intnum$ = ValtoString$(varresult)
end function

function Sqrnum$(var$)
    var1 = StringtoVal(var$)
    varresult = sqr(var1)
    Sqrnum$ = ValtoString$(varresult)
end function

function Rndnum$(var$)
    var1 = StringtoVal(var$)
    varresult = rnd(var1)
    Rndnum$ = ValtoString$(varresult)
end function

function Modnum$(var$)
    seperator = instr(var$,",",1)
    varlen = len(var$)
    var1$ = left$(var$,seperator - 1)
    var2$ = right$(var$,varlen - seperator)
    var1 = StringtoVal(var1$)
    var2 = StringtoVal(var2$)

    varresult = abs(var1) - abs((int(var1/var2)*var2))
    Modnum$ = ValtoString$(varresult)
end function


function StringtoVal(var$)
    StringtoVal = val(trim$(var$))
end function

function ValtoString$(var)
    ValtoString$ = str$(var)
end function

function Getlval$(work$,pos)    'This function retrieves the value to the left of the operator
    test$ = "0123456789."
    operand$ = "^r*/+"
    minus$ = "-"
    space$ = " "
    exponent$ = "e"
    true = 1
    false = 0
    resval = false          'resval is set true when we have all of the number
    pcount = 0
    startret = false        'startret is set to true when we actually start getting val$


    while resval = false
        pcount = pcount + 1

        if pcount < pos then
            ret$ = mid$(work$,pos - pcount,1)

            if instr(test$,ret$) > 0 then
                res$ = ret$ + res$          'build value$ for function return
                if startret = false then
                    startret = true
                end if
            else
                select case ret$
                    case "e"        'do if exponetial
                        res$ = ret$ + res$

                    case " "        'do if space
                        if startret = true then
                            resval = true
                        else
                            res$ = ret$ + res$
                        end if

                    case "-"        'do if minus, determine if sign or operator
                        if mid$(work$,pos - (pcount +1),1) = exponent$ then
                            res$ = "e-" + res$
                            pcount = pcount + 1
                        else
                            while (resval = false) or ((pcount + 1) < pos)
                                pcount = pcount + 1
                                ret$ = mid$(work$,pos - pcount,1)
                                if ret$ <> space$ then
                                    if instr(test$,ret$) then
                                        resval = true
                                    else
                                        res$ = "-" + res$
                                        resval = true
                                    end if
                                end if
                            wend
                        end if
                    case else       'do if any other character
                        resval = true

                end select
            end if
        else
            resval = true
        end if
    wend

    Getlval$ = res$     'Return function result
    'print "res$ left ";res$
end function

function Getrval$(work$,pos)    'This function retrieves the value to the right of the operator
    test$ = "0123456789.e"
    minus$ = "-"
    space$ = " "
    true = 1
    false = 0
    resval = false
    pcount = 0
    startret = false
    lenwork = len(work$)

    while resval = false            'are we finished
        pcount = pcount + 1
        if (pcount + pos) <= lenwork then   'have we reached the end of the string
            ret$ = mid$(work$,pos + pcount,1)   'get character

            if instr(test$,ret$) > 0 then
                res$ = res$ + ret$          'build value$ for function return
                if startret = false then
                    startret = true
                end if
            else
                select case ret$
                    case " "        'do if space
                        if startret = true then
                            resval = true
                        else
                            res$ = res$ + ret$
                        end if

                    case "-"        'do if minus, start sign, end operator
                        select case startret
                            case false
                                startret = true
                                res$ = res$ + ret$

                            case true
                                if mid$(work$,pos +(pcount - 1),1) = "e" then
                                    res$ = res$ + ret$
                                else
                                    resval = true
                                end if
                        end select

                    case else       'do if any other character
                        resval = true

                end select
            end if
        else
            resval = true
        end if
    wend

    Getrval$ = res$
       ' print "res$ right ";res$
end function

[quit] 'End the program
    close #w: close #vcl:close #1
    end

[color]
 if i<=n/qq3 then
     print #1, "backcolor blue"
     print #1, "circlefilled 3"   'Y
    end if
    if i>n/qq3 then
     print #1, "backcolor red"
     print #1, "circlefilled 3"    'U
     end if
     if i>n*2/qq3 then
     print #1, "backcolor yellow"
     print #1, "circlefilled 3"    'Z
     end if
      if i>n*3/qq3 then
     print #1, "backcolor brown"
     print #1, "circlefilled 3"    'V
     end if
      if i>n*4/qq3 then
     print #1, "backcolor lightgray"
     print #1, "circlefilled 3"    'R
     end if
    print #1.status1,"X*10"
    print #1.status3,"Y U Z V R  *10"
    print #1.status4,"blue=Y"
    print #1.status5,"red =U"
    print #1.status6,"yell=Z"
    print #1.status7,"brwn=V"
    print #1.status8,"gray=R"
return

[plot]'sub
    'XY Plot
    'by L.Toms (basicprograms@bigfoot.com)
    close #1
    c5=300
    StaticText #1.status1, "",       250,  c5, 40,17'text xy-plot
    StaticText #1.status3, "",         2,   3,120,17'text xy-plot
    StaticText #1.status4, "",         2,  50, 50,17'text xy-plot
    StaticText #1.status5, "",         2,  68, 50,17'text xy-plot
    StaticText #1.status6, "",         2,  86, 50,17'text xy-plot
    StaticText #1.status7, "",         2, 104, 50,17'text xy-plot
    StaticText #1.status8, "",         2, 122, 50,17'text xy-plot

    WindowWidth  = 200+c5
    WindowHeight =  50+c5
    UpperLeftX = Int((DisplayWidth-WindowWidth)/2)
    UpperLeftY = Int((DisplayHeight-WindowHeight)/2)
    open " XY-plot:" for graphics_nsb_nf as #1
    print #1, "cls"
    print #1.status1, "!font courier 8";
    print #1.status3, "!font courier 8";
    print #1.status4, "!font courier 8";
    print #1.status5, "!font courier 8";
    print #1.status6, "!font courier 8";
    print #1.status7, "!font courier 8";
    print #1.status8, "!font courier 8";
    thisorthat=1
    select case thisorthat
    case 1
' ****** input data ***
 qq3=5'number of curves
 n=NN*qq3
 for i=1 to NN
    x(i)           =x1(i)*10
    x(i+NN)        =x1(i)*10
    x(i+NN*2)      =x1(i)*10
    x(i+NN*3)      =x1(i)*10
    x(i+NN*4)      =x1(i)*10

    y(i)           =y(i)*10
    y(i+NN)        =u(i)*10
    y(i+NN*2)      =z(i)*10
    y(i+NN*3)      =v(i)*10
    y(i+NN*4)      =r(i)*10
 next i
 for i=1 to n
    xs(i)=x(i)
    ys(i)=y(i)
 next i
' ***** end of input *****
case 2
 print "Starting x value for function? ";
 input " ";x1
 print "Ending x value for function? ";
 input " ";x2
 print "Increment? ";
 input " ";inc$
 if inc$=chr$(13) then inc$="1"
 inc=abs(val(inc$))
 'limit points to 300
 points=int(abs(x2-x1)/inc)+1
 if points>300 then
  stepsize=points/300
  points=300
 else
  stepsize=inc
 end if
 i=1
 xx=x1
 while i<=points
   x(i)=xx
   xs(i)=xx
   y(i)=Fx(xx)
   ys(i)=y(i)
   print x(i);
   print " ";y(i)
   i=i+1
   if i=points then
     xx=x2
   else
     xx=xx+stepsize
   end if
 wend
n=i-1
end select

'start plot **********************************************************************************************

print #1, "fill cyan;home"

'find min/max x,y
sort xs(),1,n
xmin=xs(1)
xmax=xs(n)
sort ys(),1,n
ymin=ys(1)
ymax=ys(n)

'now figure out how much real estate the axis tick mark labels need *********************************
plusalittlex=20
plusalittley=10
abitmore=6
bottomlabelheight=80
print #1, "font courier_new 10"
shiftdown2print=14
shiftover2print=4
'xmin
name$=str$(xmin)
print #1, "stringwidth? name$ xminwidth"
'xmax
name$=str$(xmax)
print #1, "stringwidth? name$ xmaxwidth"
'ymin
name$=str$(ymin)
print #1, "stringwidth? name$ yminwidth"
'ymax
name$=str$(ymax)
print #1, "stringwidth? name$ ymaxwidth"
xshift = max(yminwidth,ymaxwidth)+abitmore
'now we have the real estate in the x direction
xaxislength=WindowWidth-xshift-plusalittlex
'for now just set y area as follows
'lets keep 30 at the bottom for text and title
yaxislength=WindowHeight-bottomlabelheight-plusalittley
yend=WindowHeight-bottomlabelheight

'set XY axis for 3 cases *****************************************************************************
axistype=0
'positive numbers
if axistype=0 and xmin>=0 and ymin>=0 then axistype=1
'1st and 2nd quadrants
if axistype=0 and ymin>=0 then axistype=2
'all four quadrants
if axistype=0 then axistype=3

'print the main axes **********************************************************************************
select case axistype
case 1
'positive numbers
xp0=xshift
yp0=yend
print #1, "place ";xp0;" ";yp0
print #1, "turn 90"
print #1, "down;go ";xaxislength
print #1, "place ";xp0;" ";yp0
print #1, "turn -90"
print #1, "go ";yaxislength
print #1, "place ";xp0;" ";yp0
case 2
'1st and 2nd quadrant
'positive numbers
xp0=xshift
xpMID=xpO+xaxislength/2
yp0=yend
print #1, "place ";xp0;" ";yp0
print #1, "turn 90"
print #1, "down;go ";xaxislength
print #1, "place ";xpMID;" ";yp0
print #1, "turn -90"
print #1, "go ";yaxislength
case 3
'1st and 2nd quadrant
'positive numbers
xp0=xshift
xpMID=xpO+xaxislength/2+25
yp0=yend
ypMID=yp0-yaxislength/2
print #1, "place ";xpMID;" ";ypMID
print #1, "turn 90"
print #1, "down;go ";xaxislength/2+10
print #1, "place ";xpMID;" ";ypMID
print #1, "turn 180"
print #1, "go ";xaxislength/2-10
print #1, "place ";xpMID;" ";ypMID
print #1, "turn 90"
print #1, "go ";yaxislength/2
print #1, "place ";xpMID;" ";ypMID
print #1, "turn 180"
print #1, "go ";yaxislength/2
end select

'scale it ***************************************************************************************************
select case axistype
case 1
xend=xmax*1.1
yend=ymax*1.1
onex=xaxislength/xend
oney=yaxislength/yend
case 2
xmaxabs=max(abs(xmin),abs(xmax))
xend=2*xmaxabs*1.1
yend=ymax*1.1
onex=xaxislength/xend
oney=yaxislength/yend
case 3
xmaxabs=max(abs(xmin),abs(xmax))
xend=2*xmaxabs*1.1
ymaxabs=max(abs(ymin),abs(ymax))
yend=2*ymaxabs*1.1
onex=xaxislength/xend
oney=yaxislength/yend
end select

'set the x grid divisions **********************************************************
select case axistype
case 1
'if abs(xmax-xmin)>100 then
 maxdivx=10
'else
' maxdivx=10
'end if
call getdivisions 1, xmax, maxdivx
thegrid=gridpass(1)
case 2,3
'if xmaxabs>100 then
 maxdivx=10
'else
' maxdivx=10
'end if
call getdivisions 1, 2*xmaxabs, maxdivx
thegrid=gridpass(1)
end select

'print the x grid *************************************************************************
'goto [jump1]
select case axistype
case 1
i=thegrid
xg=xp0
xpm=xshift+xaxislength
xg=xg+onex*thegrid
while xg <= xpm
 print #1, "color black; backcolor cyan"
 print #1, "place ";xg;" ";yp0+shiftdown2print
 num$=str$(i)
 print #1, "\";num$
 print #1, "place ";xg;" ";yp0
 print #1, "north"
 print #1, "color lightgray"
 print #1, "go ";yaxislength
 i=i+thegrid
 xg=xg+onex*thegrid
wend
case 2,3
'start in the middle and go right (positive x)
i=thegrid
xpm=xshift+xaxislength
xg=xpMID+onex*thegrid
while xg <= xpm
 print #1, "color black; backcolor cyan"
 print #1, "place ";xg;" ";yp0+shiftdown2print
 num$=str$(i)
 print #1, "\";num$
 print #1, "place ";xg;" ";yp0
 print #1, "north"
 print #1, "color lightgray"
 print #1, "go ";yaxislength
 i=i+thegrid
 xg=xg+onex*thegrid
wend
'start in the middle and go left (negative x)
i=thegrid*-1
xpm=xshift+xaxislength
xg=xpMID-onex*thegrid
while xg >= xshift
 print #1, "color black; backcolor cyan"
 print #1, "place ";xg;" ";yp0+shiftdown2print
 num$=str$(i)
 print #1, "\";num$
 print #1, "place ";xg;" ";yp0+2
 print #1, "north"
 print #1, "color lightgray"
 print #1, "go ";yaxislength
 i=i-thegrid
 xg=xg-onex*thegrid
wend
print #1, "color black; backcolor cyan"
print #1, "place ";xpMID;" ";yp0+shiftdown2print
print #1, "\0"
end select

'find the divisions to use for the y grid *************************************
select case axistype
case 1,2
maxdivy=10
call getdivisions 0, ymax, maxdivy
thegrid=gridpass(1)
case 3
maxdivy=10
call getdivisions 0, 2*ymaxabs, maxdivy
thegrid=gridpass(1)
end select

'print the y grid - no more than 10 *************************************************
select case axistype
case 1,2
i=thegrid
yg=yp0
ypm=yp0-yaxislength
yg=yg-oney*thegrid
while yg >= ypm
 print #1, "color black; backcolor cyan"
 print #1, "place ";xp0-shiftover2print-ymaxwidth;" ";yg
 num$=str$(i)
 print #1, "\";"       ";num$
 print #1, "place ";xp0-2;" ";yg
 print #1, "north;turn 90"
 print #1, "color lightgray"
 print #1, "go ";xaxislength
 i=i+thegrid
 yg=yg-oney*thegrid
wend
case 3
'first go positive
i=thegrid
yg=ypMID
ypm=ypMID-yaxislength/2
yg=yg-oney*thegrid
while yg >= ypm
 print #1, "color black; backcolor cyan"
 print #1, "place ";xp0-shiftover2print-ymaxwidth;" ";yg
 num$=str$(i)
 print #1, "\";"       ";num$
 print #1, "place ";xp0-2;" ";yg
 print #1, "north;turn 90"
 print #1, "color lightgray"
 print #1, "go ";xaxislength
 i=i+thegrid
 yg=yg-oney*thegrid
wend
'now go negative
i=thegrid
yg=ypMID
ypm=ypMID+yaxislength/2
yg=yg+oney*thegrid
while yg <= ypm
 print #1, "color black; backcolor cyan"
 print #1, "place ";xp0-shiftover2print-ymaxwidth;" ";yg
 num$=str$(i)
 print #1, "\";"      -";num$
 print #1, "place ";xp0-2;" ";yg
 print #1, "north;turn 90"
 print #1, "color lightgray"
 print #1, "go ";xaxislength
 i=i+thegrid
 yg=yg+oney*thegrid
wend
print #1, "color black; backcolor cyan"
print #1, "place ";xp0-shiftover2print-ymaxwidth;" ";ypMID
print #1, "\       0"
end select

'plot points ***************************************************************
select case thisorthat
case 1
select case axistype
case 1
for i=1 to n
  xpt=x(i)*onex+xp0
  ypt=yp0-y(i)*oney
  print #1, "place ";xpt;" ";ypt
  gosub [color]
next i

case 2
for i=1 to n
  xpt=x(i)*onex+xpMID
  ypt=yp0-y(i)*oney
  print #1, "place ";xpt;" ";ypt
  gosub [color]
next i

case 3
for i=1 to n
  xpt=x(i)*onex+xpMID
  ypt=ypMID-y(i)*oney
  print #1, "place ";xpt;" ";ypt
  gosub [color]
next i
end select

print #1, "flush"
return'end main plot sub

'*************************************************************
sub getdivisions min1, max1, maxdiv
range=abs(max1-min1)
roughdiv=range/maxdiv
roughint=int(roughdiv)
'roundup
roughint=roughint+1
select case
case roughint=1
grid=1
case roughint=2
grid=2
case roughint<6
grid=5
case roughint<11
grid=10
case roughint<26
grid=25
case roughint<51
grid=50
case roughint<101
grid=100
case roughint<201
grid=200
case roughint<301
grid=300
case roughint<401
grid=400
case roughint<501
grid=500
case roughint<1001
grid=100*int(roughint/100)
case roughint<10001
grid=1000*int(roughint/1000)
case else
 flag=0
 s=1
 i=1000
 while flag=0 and s<100
 s=s+1
 i=i*10
 chk=int(roughint/i)
 if chk<=10 then
  flag=1
  grid=i*chk
 end if
 wend
end select
if s>=100 then
 print#1, "place 100 200"
 print#1, "\These numbers are just to big -- I give up."
end if
gridpass(1)=grid
end sub
return


