hi dodicat
that's a clever example :)
you misunderstood, i am translating from PowerBasic to FB and PowerBasic has the Remove function, the first remove function I wrote does indeed remove any substring whereas the second removes any characters that are in the list.
I have an idea about a math parser, that would parse and byte code compile the expression and then you would call the evaluator with the compiled expression, also to make it useful it would need to be able to access variables declared in FB passed to the parser as pointers.
one hurdle that comes to mind is how to store literal numbers in the compiled expression, I guess you could use MKD.
Squares
@SRValdez @Dodicat
what i was implying in my post was a method kind of like:
what i was implying in my post was a method kind of like:
Code: Select all
INSTR(1 , str, ANY "+-*\/" ) but to evaluate a single CHR(?)
char = mid( str , loc , 1 ) : if char = ANY "-+*\/" then ??
char = str[ loc ] : if char = ANY "65 , 66 , 67" then ??
Rather than: IF char=65 OR char=66 OR char=67 then ???
I have seen some parsers use mkd.
I have a bit of a quandry at the moment, not code, but hardware.
A vista machine 2.5Gb, twin dual core does in .08 second what my machine does in 4 seconds.
My machine is 3.0 Gb, twin dual core, xp pro.
Strange and annoying.
Albert registers about 30 seconds for 360 x 360 evals (the VB one), I gave up waiting after 20 minutes, and the fans were going like fury.
So that's my excuse for lack of progress.
Back to Ebay maybe!
I have a bit of a quandry at the moment, not code, but hardware.
A vista machine 2.5Gb, twin dual core does in .08 second what my machine does in 4 seconds.
My machine is 3.0 Gb, twin dual core, xp pro.
Strange and annoying.
Albert registers about 30 seconds for 360 x 360 evals (the VB one), I gave up waiting after 20 minutes, and the fans were going like fury.
So that's my excuse for lack of progress.
Back to Ebay maybe!
albert
to my understanding
will be true if any of the characters in "+-*\/" are present in str, so it should do what you want.
to my understanding
Code: Select all
INSTR(1 , str, ANY "+-*\/" )
Hi Albert.
You can try Randy keeling's rpn parser, it is quite fast on this machine.
Functions are quite easy to add, there are three places in the code to add to, you'll see quite easily where they are.
You can try Randy keeling's rpn parser, it is quite fast on this machine.
Functions are quite easy to add, there are three places in the code to add to, you'll see quite easily where they are.
Code: Select all
'R. KEELING'S RPN PARSER,(From jdebord's mathlib website)
'sin,cos,tan,atn,sqr,log,exp
'others can be added
CONST FALSE as Byte = 0
CONST TRUE as byte = not FALSE
const MaxOperators as integer = 100
const MaxExpressions as integer = 100
'Operator Constants
const rpnNAO as Integer = 0 'NOT AN OPERATOR
CONST rpnLeftParenthesis as Integer = 1
CONST rpnRightParenthesis as Integer = 2
Const rpnPlus As integer = 3 '+
Const rpnMinus As integer = 4 '-
Const rpnMultiply As integer = 5 '*
Const rpnDivide As integer = 6 '/
Const rpnPercent As integer = 7 '% percentage
Const rpnIntegerDivision As integer = 8 '\ integer division
Const rpnPow As integer = 9 '^
Const rpnAbs As integer = 10 '"abs", "|.|"
Const rpnAtn As integer = 11 '"atn"
Const rpnCos As integer = 12 '"cos"
Const rpnSin As integer = 13 '"sin"
Const rpnExp As integer = 14 '"exp"
Const rpnFix As integer = 15 '"fix"
Const rpnInt As integer = 16 '"int"
Const rpnLn As integer = 17 '"ln"
Const rpnLog As integer = 18 '"log"
Const rpnRnd As integer = 19 '"rnd"
Const rpnSgn As integer = 20 '"sgn"
Const rpnSqr As integer = 21 '"sqr"
Const rpnTan As integer = 22 '"tan"
Const rpnAcos As integer = 23 '"acos"
Const rpnAsin As integer = 24 '"asin"
Const rpnCosh As integer = 25 '"cosh"
Const rpnSinh As integer = 26 '"sinh"
Const rpnTanh As integer = 27 '"tanh"
Const rpnAcosh As integer = 28 '"acosh"
Const rpnAsinh As integer = 29 '"asinh"
Const rpnAtanh As integer = 30 '"atanh"
Const rpnmod As integer = 31 '"mod"
Const rpnFact As integer = 32 '"fact", "!"
declare function ConvertInfixToPostFix(TExpression as String) as string
declare sub Update(byval _operator as BYTE, ByRef Expression as String, _
byref OSP as integer,ByRef ESP as integer, _
OStack() as BYTE, EStack() as String)
declare Function PushOperator (byval Object as BYTE, _
byref StackPointer AS integer, _
Stack() as BYTE) as byte
declare Function PopOperator (byref StackPointer AS integer,_
Stack() as BYTE) as byte
declare Function PushExpression (BYREF Object as string, _
ByRef StackPointer as integer, _
Stack() as string) as BYTe
declare Function PopExpression (byref StackPointer AS integer, _
Stack() as String) as String
declare FUNCTION GetPriority (_operator AS BYTE) as BYTE
declare function IsOperator(Item as String) as Byte
declare function GetOperatorString(_operator as BYTE) as string
declare function EvalPostFix (PostFixString as String) as double
function EvalPostFix (PostFixString as String) as double
'Valid PostFix String is <something><space><something><space>.......<something><space>
Dim ExpressionStack (MaxExpressions) as string
Dim ESP as integer
dim Position as integer
dim TokenString as string
Dim WorkingString as string
dim Var1 as string
Dim Var2 as String
dim A as double
dim B as Double
WorkingString = PostFixString
ESP = 0
Position = instr(WorkingString, " ")
If Position = 0 then
Print "ERROR"
end
end if
do while (Position <> 0)
TokenString = Left$(WorkingString,Position-1)
WorkingString = mid$(WorkingString, Position+1)
Position = instr(WorkingString, " ")
select case TokenString
case "+"
'Pop two values, add them, and then push the answer back
Var1 = PopExpression (ESP, ExpressionStack())
Var2 = PopExpression (ESP, ExpressionStack())
A = val(Var1)
B = Val(Var2)
PushExpression (str$(B+A), ESP, ExpressionStack())
case "-"
'Pop two values, add them, and then push the answer back
Var1 = PopExpression (ESP, ExpressionStack())
Var2 = PopExpression (ESP, ExpressionStack())
A = val(Var1)
B = Val(Var2)
PushExpression (str$(B-A), ESP, ExpressionStack())
case "*"
Var1 = PopExpression (ESP, ExpressionStack())
Var2 = PopExpression (ESP, ExpressionStack())
A = val(Var1)
B = Val(Var2)
PushExpression (str$(B*A), ESP, ExpressionStack())
case "/"
Var1 = PopExpression (ESP, ExpressionStack())
Var2 = PopExpression (ESP, ExpressionStack())
A = val(Var1)
B = Val(Var2)
PushExpression (str$(B/A), ESP, ExpressionStack())
case "^"
Var1 = PopExpression (ESP, ExpressionStack())
Var2 = PopExpression (ESP, ExpressionStack())
A = val(Var1)
B = Val(Var2)
PushExpression (str$(B^A), ESP, ExpressionStack())
case "SIN"
Var1 = PopExpression (ESP, ExpressionStack())
A = val(Var1)
PushExpression (str$(sin(a)), ESP, ExpressionStack())
case "COS"
Var1 = PopExpression (ESP, ExpressionStack())
A = val(Var1)
PushExpression (str$(cos(a)), ESP, ExpressionStack())
case "TAN"
Var1 = PopExpression (ESP, ExpressionStack())
A = val(Var1)
PushExpression (str$(TAN(a)), ESP, ExpressionStack())
case "ATN"
Var1 = PopExpression (ESP, ExpressionStack())
A = val(Var1)
PushExpression (str$(atn(a)), ESP, ExpressionStack())
case "SQR"
Var1 = PopExpression (ESP, ExpressionStack())
A = val(Var1)
PushExpression (str$(sqr(a)), ESP, ExpressionStack())
case "LOG"
Var1 = PopExpression (ESP, ExpressionStack())
A = val(Var1)
PushExpression (str$(log(a)), ESP, ExpressionStack())
case "EXP"
Var1 = PopExpression (ESP, ExpressionStack())
A = val(Var1)
PushExpression (str$(exp(a)), ESP, ExpressionStack())
case else
'must be an opperand
'when variable and constant support is added,
'it could be added here
'pass the function and array of variables as strings
'i.e Variables(1) might be "x=4.5"
' Variables(2) might be "SigmaZ = 23.55234"
'the code would then go through each each index looking for the
'variable or constant then replace it on the stack
'for now, we'll just push
PushExpression (TokenString, ESP, ExpressionStack())
end select
loop
EvalPostFix = Val(ExpressionStack(1))
end function
function ConvertInfixToPostFix(TExpression as String) as string
Dim OperatorStack (MaxOperators) as BYTE
Dim ExpressionStack (MaxExpressions) as String
dim OSP as integer
dim ESP as integer
Dim TokenString as String
Dim Token as BYTE
dim Position as integer
dim Offset as BYTE
dim Length as integer
Dim Expression as string
Dim VariableBuffer as string
dim _operator as Byte
Dim ErrorCode as Byte
dim CheckLeft as string
dim Counter as integer
dim ReturnAnswer as string
Dim TempExpression as string
ErrorCode=FALSE
OSP = 0
ESP = 0
VariableBuffer = ""
Expression = Lcase$(TExpression)
Length = Len(Expression)
Offset = 1
Position = 1
TokenString = LEFT$(Expression, Offset)
'Main loop
Do WHILE (NOT ErrorCode) AND (Position <= Length)
_operator = FALSE
Offset = 1
select case TokenString
case "+"
_operator = True
Token = rpnPlus
case "-"
_operator = True
Token = rpnMinus
case "*"
_operator = True
Token = rpnMultiply
case "/"
_operator = True
Token = rpnDivide
case "^"
_operator = True
Token = rpnPow
case "("
_operator = True
Token = rpnLeftParenthesis
case ")"
_operator = True
Token = rpnRightParenthesis
case "a"
if mid$(TExpression,position,3) = "atn" then
_operator = True
Offset = 3
Token = rpnatn
end if
case "b"
case "c"
if mid$(TExpression,position,3) = "cos" then
_operator = True
Offset = 3
Token = rpnCos
end if
case "e"
if mid$(TExpression,position,3) = "exp" then
_operator = True
Offset = 3
Token = rpnexp
end if
case "f"
case "h"
case "i"
case "j"
case "k"
case "l"
if mid$(TExpression,position,3) = "log" then
_operator = True
Offset = 3
Token = rpnlog
end if
case "m"
case "n"
case "o"
case "p"
case "q"
case "r"
case "s"
if mid$(TExpression,position,3) = "sin" then
_operator = True
Offset = 3
Token = rpnSin
end if
if mid$(TExpression,position,3) = "sqr" then
_operator = True
Offset = 3
Token = rpnSqr
end if
case "t"
if mid$(TExpression,position,3) = "tan" then
_operator = True
Offset = 3
Token = rpnTan
end if
case "u"
case "v"
case "w"
case "x"
case "y"
case "z"
case else
end select
IF _operator THEN
'check + and - to see if they are unary or binary
select case Token
case rpnPlus, rpnMinus
select case Position
case 1
'if its the first character, then it has to be unary
'in that cass just make it part of the variable
VariableBuffer = VariableBuffer + TokenString
case 2
if left$(Expression,1) = "(" then
'its unary
VariableBuffer = VariableBuffer + TokenString
else
Update Token, VariableBuffer, OSP,ESP, OperatorStack(),ExpressionStack()
end if
case is > 2
'This could be either one
CheckLeft = MID$(Expression,Position-2,2)
if IsOperator(CheckLeft) then
VariableBuffer = VariableBuffer + TokenString
else
Update Token, VariableBuffer, OSP,ESP, OperatorStack(),ExpressionStack()
end if
end select
case else
Update Token, VariableBuffer, OSP,ESP, OperatorStack(),ExpressionStack()
end select
ELSE
if TokenString <> " " then VariableBuffer = VariableBuffer + TokenString
END IF
Position = Position + Offset
TokenString = MID$(Expression, Position, 1)
loop
PushExpression (VariableBuffer, ESP, ExpressionStack())
dim ReturnOperator as BYTE
dim ReturnString as String
do while OSP <> 0
ReturnOperator = PopOperator(OSP,OperatorStack())
ReturnString = GetOperatorString(ReturnOperator)
PushExpression (ReturnString, ESP, ExpressionStack())
loop
ReturnAnswer = ""
for Counter = 1 to ESP
TempExpression = trim$(ExpressionStack(Counter))
if TempExpression <> "" then ReturnAnswer = ReturnAnswer + TempExpression + " "
next Counter
ConvertInfixToPostFix = ReturnAnswer
end function
Function PushOperator (byval Object as BYTE, byref StackPointer AS integer, _
Stack() as BYTE) as byte
StackPointer = StackPointer + 1
IF StackPointer > MaxOperators THEN
PushOperator = False
ELSE
Stack(StackPointer) = Object
PushOperator = True
END IF
END function
Function PopOperator (byref StackPointer AS integer, _
Stack() as BYTE) as Byte
IF StackPointer = 0 THEN
PopOperator = FALSE
ELSE
PopOperator = Stack(StackPointer)
StackPointer = StackPointer - 1
END IF
END Function
Function PushExpression (BYREF Object as string, _
ByRef StackPointer as integer, _
Stack() as string) as byte
StackPointer = StackPointer + 1
IF StackPointer > MaxExpressions THEN
PushExpression = False
ELSE
Stack(StackPointer) = Object
PushExpression = True
END IF
end function
Function PopExpression (byref StackPointer AS integer, _
Stack() as String) as String
IF StackPointer = 0 THEN
PopExpression = "FALSE"
ELSE
PopExpression = Stack(StackPointer)
StackPointer = StackPointer - 1
END IF
END Function
sub Update(byval _operator as BYTE, ByRef Expression as String, _
byref OSP as integer,ByRef ESP as integer, _
OStack() as BYTE, EStack() as String)
Dim ReturnPriority as BYTE
dim ReturnAnswer as byte
dim ReturnOperator as byte
dim ReturnString as string
ReturnAnswer = PushExpression (Expression, ESP, EStack())
Expression = ""
select case _operator
case rpnLeftParenthesis
ReturnAnswer = PushOperator (_operator, OSP, OStack())
case rpnRightParenthesis
ReturnOperator = PopOperator(OSP,OStack())
do while ReturnOperator<>rpnLeftParenthesis
ReturnString = GetOperatorString(ReturnOperator)
PushExpression (ReturnString, ESP, EStack())
ReturnOperator = PopOperator(OSP,OStack())
loop
case ELSE
if OSP = 0 then
PushOperator (_operator, OSP, OStack())
else
ReturnPriority = GetPriority(_operator)
if (ReturnPriority > GetPriority(OStack(OSP))) then
PushOperator (_operator, OSP, OStack())
else
Do While (ReturnPriority <= GetPriority(OStack(OSP)) And (OSP <> 0))
ReturnOperator = PopOperator(OSP,OStack())
ReturnString = GetOperatorString(ReturnOperator)
PushExpression (ReturnString, ESP, EStack())
loop
PushOperator (_operator, OSP, OStack())
end if
end if
end select
end sub
sub UpdateExpressionStack (Variable as String,StackPointer as integer,Stack() as BYTE)
end sub
FUNCTION GetPriority (_operator AS BYTE) as BYTE
SELECT CASE _operator
CASE rpnLeftParenthesis
GetPriority = 10
CASE rpnPlus, rpnMinus
GetPriority = 30
CASE rpnMultiply, rpnDivide, rpnIntegerDivision
GetPriority = 40
CASE rpnPow
GetPriority = 50
case else
'functions
GetPriority = 60
END SELECT
END FUNCTION
function IsOperator(Item as String) as Byte
IsOperator=FALSE
select case Right$(Item,1)
case "+","-","*","/","\","("
IsOperator=True
case "e"
select case LEFT$(Item,1)
case "1","2","3","4","5","6","7","8","9","0","."
IsOperator=True
end select
end select
end function
function GetOperatorString(_operator as BYTE) as string
select case _operator
case rpnPlus
GetOperatorString = "+"
case rpnMinus
GetOperatorString = "-"
case rpnMultiply
GetOperatorString = "*"
case rpnDivide
GetOperatorString = "/"
case rpnPow
GetOperatorString = "^"
case rpnSin
GetOperatorString = "SIN"
case rpnCos
GetOperatorString = "COS"
case rpnTan
GetOperatorString = "TAN"
case rpnatn
GetOperatorString = "ATN"
case rpnsqr
GetOperatorString = "SQR"
case rpnlog
GetOperatorString = "LOG"
case rpnexp
GetOperatorString = "EXP"
case else
GetOperatorString = "ERROR"
end select
end function
#define StrLen(s) *Cast(Integer Ptr,Cast(Integer,@s)+4)
Sub Setvariable(s As String,REPLACE_THIS As String,WITHTHIS As Double)' As String
var WITH_THIS=Str(WITHTHIS)
var position=Instr(s,REPLACE_THIS)
While position>0
s=Mid(s,1,position-1) & WITH_THIS & Mid(s,position+StrLen(REPLACE_THIS))
position=Instr(position+StrLen(WITH_THIS),s,REPLACE_THIS)
Wend
End Sub
function eval(s as string) as double
dim as string postfix=ConvertInfixToPostFix (s)
return EvalPostFix(postfix)
end function
'_____________ END EVAL _________________________________
'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))
'end progress
Screen 19,32
Dim As String main1,work1
main1="sin(deg1)*cos(deg2)+tan(deg3)+atn(deg1/3)+deg3"
Print main1
Print
Dim deg1 As Double
Dim deg2 As Double
Dim deg3 As Double
#macro _update()
work1=main1
setvariable(work1,"deg1",deg1)
setvariable(work1,"deg2",deg2)
setvariable(work1,"deg3",deg3)
#endmacro
deg1=.5:deg2=.007:deg3=.009
_update()
Print "formatted1"
Print work1
Print eval(work1), Sin(.5)*Cos(.007)+Tan(.009)+Atn(deg1/3)+deg3
Print
deg1=13:deg2=13:deg3=13
_update()
Print "formatted2"
Print work1
Print eval(work1), Sin(13)*Cos(13)+Tan(13)+Atn(13/3)+deg3
Dim As Double value,t1,t2,loopsize=50
t1=Timer
progressbar(b)
For deg1 =1 To loopsize
For deg2=1 To loopsize
For deg3=1 To loopsize
_update()
value=eval(work1)
Next deg3
Next deg2
percentage=progress(deg1,1,loopsize)
b.percent=percentage
progressbar(b)
Next deg1
t2=Timer
Print
Print
Print "time for ";loopsize^3;" evals = ";t2-t1
''print eval("exp(1)")
Sleep
@Dodicat
The jdebord library is the "fbeval.bi" it seem that Keeling added the arc functions and hyperbolics ..
It ran in 22 seconds for 125000 counts..
but thats just for one formula, and i got x1,x2,y1,y2 and z1.. so it would work out to 100 seconds and longer formula would be longer time.
What i'm working on is a way to preparse each fromula and set it up into an array of execution orders. and then just plug the vars in with the function calls..
===============================================
I figure; if the formula is static and only the var values change then there is no need to parse the whole formula each iteration.
cos(d1*r1*sin(c2*r2*s2)*c2)*log(d2*r2*c2)
array(1) = c2*r2*s2 -> array(2)
array(2) = sin( <- array(1) *c2) -> array(3) )
array(3) = cos( d1*r1* <-array(2) ) -> array(4)
array(4) = array(3) * log(d2*r2*c2)
something like the above!!! ??? !!!
The jdebord library is the "fbeval.bi" it seem that Keeling added the arc functions and hyperbolics ..
It ran in 22 seconds for 125000 counts..
but thats just for one formula, and i got x1,x2,y1,y2 and z1.. so it would work out to 100 seconds and longer formula would be longer time.
What i'm working on is a way to preparse each fromula and set it up into an array of execution orders. and then just plug the vars in with the function calls..
===============================================
I figure; if the formula is static and only the var values change then there is no need to parse the whole formula each iteration.
cos(d1*r1*sin(c2*r2*s2)*c2)*log(d2*r2*c2)
array(1) = c2*r2*s2 -> array(2)
array(2) = sin( <- array(1) *c2) -> array(3) )
array(3) = cos( d1*r1* <-array(2) ) -> array(4)
array(4) = array(3) * log(d2*r2*c2)
something like the above!!! ??? !!!
Did you try SEE (Simple Expression Evaluator) by krcko ?
I store a copy on my website:
http://www.unilim.fr/pages_perso/jean.d ... th/see.zip
It has a very nice mechanism to add functions from the calling program.
I store a copy on my website:
http://www.unilim.fr/pages_perso/jean.d ... th/see.zip
It has a very nice mechanism to add functions from the calling program.
Mouse wheel surface with floating points, put in perspective.
Code: Select all
'THE THING
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>
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 frame,fps
frame=frame+1
Static As Double t1,t2
If frame>=fps Then
t1 = Timer
fps = frame/(t1-t2)
Windowtitle "Frames per second = " & fps
t2=Timer
frame=0
End If
End Sub
Function rotatepoint3d(Byval pivot As vector3d,_
Byval pt As vector3d,_
Byval angle As vector3d,_
Byval dilator As Single=1) As vector3d
#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
Dim angle_radians As vector3d=Type<vector3d>(cr*angle.x,cr*angle.y,cr*angle.z)
Dim s As Single=Any
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
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)
For x As Single=-1 To 1 Step .02
For y As Single=-1 To 1 Step .02
count=count+1
Redim Preserve e(count)
Redim Preserve col(count)
col(count)=Rgb(155*(x+1)/2,155*(y+1)/2,Rnd*155)
e(count)=Type<vector3d>(x,y,(Sin(5*x)+Cos(5*y))/5)
Next y
Next x
blow(e(),800)
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(Ubound(e)),_mw
Dim As Uinteger colour
Dim As Integer mx,my,mw
Dim As Single startdilation=.2
dilation=startdilation
Do
framecounter
i=Inkey
ang.y=ang.y+.5
ang.x=ang.x+.5
ang.z=ang.z+.25
Screenlock
Cls
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 1,1
Loop Until i=Chr(27)
Sleep
@jdeBord
I put the SEE into Trigonometry_Designer_Windows_V1 on the projects page. it does okay in 2D mode but in GL mode it just stops.
We had to fill an array with the outputs and then hand the array off to GL
But it takes 1 minute to 10 minutes to fill the array depending on the 5 formulas lengths.
So i figured the formulas need to be preparsed, into simple execution orders and then plug the variable values in. JIT parsing is just too slow.
===============================================
@Dodicat I get 10 to 12 frames a second. its kinda of like open GL.
I put the SEE into Trigonometry_Designer_Windows_V1 on the projects page. it does okay in 2D mode but in GL mode it just stops.
We had to fill an array with the outputs and then hand the array off to GL
But it takes 1 minute to 10 minutes to fill the array depending on the 5 formulas lengths.
So i figured the formulas need to be preparsed, into simple execution orders and then plug the variable values in. JIT parsing is just too slow.
===============================================
@Dodicat I get 10 to 12 frames a second. its kinda of like open GL.
I'm making progress on the preparser..
Its still going down a line with the "("
Code: Select all
Declare SUB parse(byval inputs as string )
redim shared as string function_array()
dim as string equation = "Sin(cos(d1*d2*log(r1*r2*c2)*d2*r2)*c2*s2)*tan(d2*r2*s2)"
parse(equation)
print
for a as integer = 0 to ubound(function_array)
print function_array(a)
next
SLEEP
END
'===============================================================================
'===============================================================================
SUB parse(byval inputs as string )
dim as string formula = inputs
redim as string function_array( 0 to len(formula) )
'fill array elements
for a as integer = lbound(function_array) to ubound(function_array) step 1
function_array(a)=string(len(formula),"_")
next
function_array(0)=string(len(formula)," ")
dim as ubyte char
dim as integer indx
dim as integer l_p = lbound(function_array(0))
dim as integer r_p = lbound(function_array(0))
dim as integer elements=0
for indx = 0 to (len(formula)-1) step 1
char = formula[indx]
if char = 40 then l_p+=1
if char = 41 then l_p-=1:r_p=l_p+1
if char=40 then
if l_p>elements then elements=l_p
function_array(l_p)[indx]=char
elseif char=41 then
if r_p>elements then elements=r_p
function_array(r_p)[indx]=char
else
function_array(lbound(function_array))[indx]=char
end if
next
'shrink array to smallest possible
redim preserve function_array(elements)
'setup parse levels
l_p=0
r_p=0
dim as string innards
for a as integer = ubound(function_array(0)) to 1 step -1
l_p = instr( r_p+1, function_array(a), chr(40) )
r_p = instr( l_p+1, function_array(a), chr(41) )
do while (r_p<>0) and (l_p<>0)
innards = mid(function_array(0), (l_p+1), ((r_p-l_p)-1) )
mid(function_array(a), (l_p+1), ((r_p-l_p)-1) ) = innards
mid(function_array(0), (l_p+1), ((r_p-l_p)-1) ) = string(len(innards)," ")
l_p = instr( r_p+1, function_array(a), chr(40) )
r_p = instr( l_p+1, function_array(a), chr(41) )
loop
l_p=0
r_p=0
next
end sub
Hi srvaldez.srvaldez wrote:hi dodicat
I think your Setvariable needs work, if you hapen to have a variable n=1 then sin( becomes si1(
Well, you should make the variables a couple or more characters long to avoid clashes with function names.
It just does a find and replace job to try and keep up the speed.
I would have to do a comparison with all names otherwise, and give an error with a clash, easily enough done I suppose with instr.
I think that my VB eval is slow on this machine because I have VB6 installed (Emule)
Can't think of any other reason.
Abstract-147
I ported my "Abstract-147" to openGL with a z_axis.
It uses the " fill_array " method and then pases the array to GL.
Those "Golden Dawn" and hermetics orders people might like it..
Code: Select all
'=================================
'Begin code
'=================================
#include once "GL/gl.bi"
#include once "GL/glu.bi"
'console printed instructioins.
screen 0
cls
print "Press Esc to EXIT"
print "-----------------------------------------"
print
print "Press Space-bar to stop all motion "
print
print "-----------------------------------------"
print "Left , Right Arrows to rotate on X - Axis"
print
print " Up , Down Arrows to rotate on Y - Axis"
print
print " R_Shft to reset U/D , L/R rotate values "
print "-----------------------------------------"
print
print " (+) , (-) , (Enter) to control spin "
print
print " (Q) , (W) , (E) to control zoom level "
print
print " (A) , (S) , (D) to control U/D shift "
print
print " (Z) , (X) , (C) to control L/R shift "
print
print " (R) , (T) to control RED LEVEL "
print " (F) , (G) to control GREEN LEVEL "
print " (V) , (B) to control BLUE LEVEL "
print "-----------------------------------------";
'for general trig looping and values
'======================================
dim as double r1 = atn(1)/45
dim as double d1
dim as double deg1_start = 0
dim as double deg1_end = 360
dim as double deg1_inc = 1
'======================================
dim as double r2 = atn(1)/45
dim as double d2
dim as double deg2_start = 0
dim as double deg2_end = 360
dim as double deg2_inc = 1
'======================================
dim as double c1
dim as double c2
dim as double s1
dim as double s2
dim as double out_x
dim as double out_y
dim as double out_z
'set up data type for x,y,z
'===============================================================================
Type Vector3D
As double x1
as double y1
as double z1
End Type
Redim As Vector3D points(0)
Dim As Ulongint ub , count 'for putting x,y,z points into type array
count=0
For d1 = deg1_start To deg1_end Step deg1_inc
c1=cos(d1*r1)
s1=sin(d1*r1)
For d2 = deg2_start To deg2_end Step deg2_inc
c2=cos(d2*r2)
s2=sin(d2*r2)
count=count+1
Redim Preserve points(count)
points(count).x1 = c1
points(count).x1+=( c1*cos(cos(d2*r2)*s2/c1)*cos(d2*r2*(c1*c2)/s1)*cos(s1*d2*r2)*c2*s1*2.7)
points(count).x1+=(.1*c1*cos(cos(d2*r2)*s2/c1)*cos(d2*r2*(c1*c2)/s1)*cos(s1*d2*r2)*c2*s1*2.7)/1.5
points(count).y1 = s1
points(count).y1+=( s1*sin(sin(d2*r2)*c2/s1)*sin(d2*r2*(s1*s2)/c1)*sin(c1*d2*r2)*c2*s1*2.7)
points(count).y1+=(.1*s1*sin(sin(d2*r2)*c2/s1)*sin(d2*r2*(s1*s2)/c1)*sin(c1*d2*r2)*c2*s1*2.7)/1.5
points(count).z1 = c2+s2
Next d2
Next d1
'setup OpenGL screen
'===============================================================================
dim as integer xres,yres
windowtitle "Abstract-147"
screen 19
screeninfo xres,yres
Screenres xres,yres,24,1,2
glMatrixMode GL_PROJECTION
glLoadIdentity
gluPerspective 18 , xres/yres , .1, 500
glMatrixMode GL_MODELVIEW
glLoadIdentity
glblendfunc GL_SRC_ALPHA, GL_ONE
glpointsize 1
glenable gl_blend
'for OpenGl transition,rotation
Dim As double GL_X,GL_Y,GL_Z
dim as double xt, yt, zt=-15 'transition variables
dim as double xr, yr, zr 'rotation variables
dim as double xrs=.5,yrs=.5,zrs=.5' transitions of camera
dim as ubyte red= 150, green=75, blue=25
'do loop through points( array )
'===============================================================================
dim as ubyte status=1
DO WHILE status=1
ub=Ubound(points)
glclear GL_DEPTH_BUFFER_BIT or GL_COLOR_BUFFER_BIT
glloadidentity
gltranslatef xt, yt, zt
glrotatef xr, 1, 0, 0
glrotatef yr, 0, 1, 0
glrotatef zr, 0, 0, 1
glbegin gl_points
For loopy As ulongint = 1 To ub
'map point to screen
GL_X = -points(loopy).x1
GL_Y = -points(loopy).y1
GL_Z = points(loopy).z1
glcolor3ub red , green , blue
glvertex3f GL_X, GL_Y , GL_Z
Next loopy
glend
screensync
flip
glflush
'check for keys being pressed
if multikey(&h01) then status = 0 ' esc key to quit
xrs = xrs + (multikey(&h50)/10) - (multikey(&h48)/10) 'left & right arrows
yrs = yrs + (multikey(&h4D)/10) - (multikey(&h4B)/10) 'up & down arrows
zrs = zrs + (multikey(&h0C)/10) - (multikey(&h4E)/10) 'plus & minus on the keypad
xr = xr - xrs
yr = yr - yrs
zr = zr - zrs
zt = zt + ((multikey(&h10)/2) - (multikey(&h11)/2)) ' q , w zoom in out
yt = yt + ((multikey(&h1E)/2) - (multikey(&h1F)/2)) ' a , s shift left,right
xt = xt + ((multikey(&h2C)/2) - (multikey(&h2D)/2)) ' z , x shift up,down
red = red +((multikey(&h13)) - (multikey(&h14))) ' r , t adjust red level
green = green +((multikey(&h21)) - (multikey(&h22))) ' f , g adjust green level
blue = blue +((multikey(&h2f)) - (multikey(&h30))) ' v , b adjust blue level
if multikey(&h39) then xrs=0 : yrs=0 : zrs=0 ' SPACE-BAR = stop all transitions
if multikey(&h1C) then xr=0 : yr=0 : zr=0 ' "Enter Key" reset spin to zero
if multikey(&h36) then 'right_shift key, to reset GL_X,GL_Y rotation values
xrs=0:yrs=0
xr =0:yr =0
end if
if multikey(&h12) then zt=-15 ' "E key" reset zoom level
if multikey(&h20) then yt= 0 ' "D key" reset UP/DOWN position to center
if multikey(&h2E) then xt =0 ' "C key" reset Left/Right position to center
Loop
END
Those "Golden Dawn" and hermetics orders people might like it..