Squares

General FreeBASIC programming questions.
srvaldez
Posts: 2253
Joined: Sep 25, 2005 21:54

Postby srvaldez » Nov 24, 2011 1:39

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.
albert
Posts: 5533
Joined: Sep 28, 2006 2:41
Location: California, USA

Postby albert » Nov 24, 2011 2:07

@SRValdez @Dodicat

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 ???
 
dodicat
Posts: 6234
Joined: Jan 10, 2006 20:30
Location: Scotland

Postby dodicat » Nov 24, 2011 2:19

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!
srvaldez
Posts: 2253
Joined: Sep 25, 2005 21:54

Postby srvaldez » Nov 24, 2011 2:51

albert
to my understanding

Code: Select all

INSTR(1 , str, ANY "+-*\/" )

will be true if any of the characters in "+-*\/" are present in str, so it should do what you want.
albert
Posts: 5533
Joined: Sep 28, 2006 2:41
Location: California, USA

Postby albert » Nov 24, 2011 5:30

@srvaldez

The thing that is; is that its not a string , but a variable.

I just thought it would be nice to have in FB.
Where you could use ANY with a variable to check its value or character.
Instead of a SELECT CASE or a bunch of OR's or AND's..
dodicat
Posts: 6234
Joined: Jan 10, 2006 20:30
Location: Scotland

Postby dodicat » Nov 24, 2011 22:19

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.

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

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

Postby albert » Nov 24, 2011 23:27

@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!!! ??? !!!
jdebord
Posts: 525
Joined: May 27, 2005 6:20
Location: Limoges, France
Contact:

Postby jdebord » Nov 25, 2011 8:51

Did you try SEE (Simple Expression Evaluator) by krcko ?

I store a copy on my website:

http://www.unilim.fr/pages_perso/jean.debord/tpmath/see.zip

It has a very nice mechanism to add functions from the calling program.
dodicat
Posts: 6234
Joined: Jan 10, 2006 20:30
Location: Scotland

Postby dodicat » Nov 25, 2011 18:09

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
albert
Posts: 5533
Joined: Sep 28, 2006 2:41
Location: California, USA

Postby albert » Nov 25, 2011 20:07

@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.
albert
Posts: 5533
Joined: Sep 28, 2006 2:41
Location: California, USA

Postby albert » Nov 25, 2011 21:07

I'm making progress on the preparser..

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



Its still going down a line with the "("
srvaldez
Posts: 2253
Joined: Sep 25, 2005 21:54

Postby srvaldez » Nov 25, 2011 23:49

hi dodicat
I think your Setvariable needs work, if you hapen to have a variable n=1 then sin( becomes si1(
dodicat
Posts: 6234
Joined: Jan 10, 2006 20:30
Location: Scotland

Postby dodicat » Nov 26, 2011 0:13

srvaldez wrote:hi dodicat
I think your Setvariable needs work, if you hapen to have a variable n=1 then sin( becomes si1(


Hi srvaldez.
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.
albert
Posts: 5533
Joined: Sep 28, 2006 2:41
Location: California, USA

Abstract-147

Postby albert » Nov 26, 2011 2:36

I ported my "Abstract-147" to openGL with a z_axis.

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



It uses the " fill_array " method and then pases the array to GL.

Those "Golden Dawn" and hermetics orders people might like it..
dafhi
Posts: 1329
Joined: Jun 04, 2005 9:51

Postby dafhi » Nov 26, 2011 4:24

albert that looks amazing

Return to “General”

Who is online

Users browsing this forum: No registered users and 3 guests