Vector Graphics Engine

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
oog
Posts: 124
Joined: Jul 08, 2011 20:34

Vector Graphics Engine

Postby oog » Dec 18, 2011 13:29

The Vector Graphics Engine (VGE) can be used to draw vector models at different zoom levels and with different levels of detail.
It is part of the Train Simulator an is now available as a separate library.

Image

You can download the lib including documentation and example programs at proog.de.


Code: Select all

'
'    file vge.bas
'
'    vge (vector graphics engine)
'
'    Copyright by oog, www.proog.de 2011
'
'    This program is free software: you can redistribute it and/or modify
'    it under the terms of the GNU General Public License as published by
'    the Free Software Foundation, either version 3 of the License, Or
'    (at your option) any later version.
'
'    This program is distributed in the hope that it will be useful,
'    but WITHOUT ANY WARRANTY; without even the implied warranty of
'    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
'    GNU General Public License for more details.
'
'    You should have received a copy of the GNU General Public License
'    along with this program.  If not, see <http://www.gnu.org/licenses/>.




'################################################
'## Definitions and constants
'################################################


'DrawItem constants for CoorScale
Const ScaleVehicle=10
Const ScaleBuilding=4

'convert world to pixel
'(need v as tview variable)
#define xcoor(x) (v.Offx+((x)/v.Scale))
#define ycoor(y) (v.Offy+((y)/v.Scale))

'convert pixel to world
'(need v as tview variable)
#define p2wx(x) (((x)-v.Offx)*v.Scale)
#define p2wy(y) (((y)-v.Offy)*v.Scale)


'################################################
'## Types
'################################################

Type p3
  x As Integer
  y As Integer
  z As Integer
End Type


Type TView                          'View
 As Integer WinX,WinY               'Window size
 As Integer Offx,Offy,Scale         'World view position and scale
 As Integer Debug                   'debug view
End Type


'################################################
'## Functions / Subs (Graphics)
'################################################


Function VisRectItem(x1 As Integer, y1 As Integer, _
  x2 As Integer, y2 As Integer, _
  v As TView) As Integer
  'check distance (x^2+y^2 < Distance^2)
  Dim As Integer d
  If (((xcoor(x1)-v.WinX/2)^2 _
      +(ycoor(y1)-v.WinY/2)^2)) _
      <(v.WinX*v.WinX+v.WinY*v.WinY) Then
    Return 1
  Else
    If (((xcoor(x2)-v.WinX/2)^2 _
        +(ycoor(y2)-v.WinY/2)^2)) _
        <(v.WinX*v.WinX+v.WinY*v.WinY) Then
      Return 1
    Else
      Return 0
    EndIf
  EndIf
End Function


Sub ScreenCenter(x As Integer, y As Integer, v As TView)
  v.Offx=v.winx/2-x/v.Scale
  v.Offy=v.winy/2-y/v.Scale
End Sub


Sub TriDraw(a1 As p3, b1 As p3, c1 As p3, col As Integer, dwin As Any ptr)
  Dim As p3 a, b, c, t
  Dim As Integer y, dy, xa, xb, L1, D1, L2, D2
 
  a=a1: b=b1: c=c1
  If a.y>b.y Then: t=b: b=a: a=t: EndIf
  If a.y>c.y Then: t=c: c=a: a=t: EndIf
  If b.y>c.y Then: t=c: c=b: b=t: EndIf
 
  dy=c.y-a.y
  For y=0 To dy
    If y=(b.y-a.y) Then
      xa=b.x
    Else
      If y<(b.y-a.y) Then
        L1=y
        D1=b.y-a.y
        xa=(b.x*L1+a.x*(D1-L1))/D1
      Else
        L1=y-b.y+a.y
        D1=c.y-b.y
        xa=(c.x*L1+b.x*(D1-L1))/D1
      EndIf
    EndIf
    L2=y
    D2=c.y-a.y
    If d2=0 Then
      xb=c.x
    Else
      xb=(c.x*L2+a.x*(D2-L2))/D2
    EndIf
    Line dwin,(xa,y+a.y)-(xb,y+a.y),col
  Next
End Sub


'################################################
'## Graphics - Build
'################################################

Function VDE_CheckParamRange(zoom As Integer, zmin As Integer, zmax As Integer) As Integer
  Dim As Integer r
  r=(zmin<=zoom) AndAlso (zoom<=zmax)
  If r=0 Then
    Print "VDE_CheckParamRange out of range ("+str(zmin)+".."+str(zmax)+"): "+str(zoom)+" = 0x"+hex(zoom)
    Sleep
  EndIf
  Return r
End Function


Function VDE_Check8s(value As Integer) As Integer
  Dim As Integer r
  r=(-128<=value) AndAlso (value<=127)
  If r=0 Then
    Print "VDE_CheckParamRange out of range (-128...127): "+str(value)
    Sleep
  EndIf
  Return r
End Function


Function VDE_Check8u(value As Integer) As Integer
  Dim As Integer r
  r=(0<=value) AndAlso (value<=255)
  If r=0 Then
    Print "VDE_CheckParamRange out of range (0...255): "+str(value)
    Sleep
  EndIf
  Return r
End Function


Function VectRem(Remark As String) As String
  Return ""
End Function


Function VectVehicle As String
  Return "v"
End Function


Function VectZoomIn(zoom As Integer) As String
  If VDE_Check8u(zoom) Then
    Return "Z"+Chr(zoom)
  Else
    End
  EndIf
End Function


Function VectZoomOut(zoom As Integer) As String
  If VDE_Check8u(zoom) Then
    Return "z"+Chr(zoom)
  Else
    End
  EndIf
End Function


Function VectZoomRange(zoomout As Integer, zoomin As Integer) As String
  If VDE_Check8u(zoomout) _
  AndAlso VDE_Check8u(zoomin) Then
    Return "R"+Chr(zoomout)+Chr(zoomin)
  Else
    End
  EndIf
End Function


Function VectEndZoom As String
  Return "E"
End Function


Function VectExit As String
  Return "X"
End Function


Function VectColor(col As Integer) As String
  Dim s As String
  If VDE_CheckParamRange(col, 0, &Hffffff) Then
    s="O"+Chr(col Shr 16 And &Hff) _
      +Chr(col Shr 8 And &Hff) _
      +Chr(col And &Hff)
    Return s
  Else
    End
  EndIf
End Function


Function VectLine(x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer) As String
  Dim s As String
  'Line
  If VDE_Check8s(x1) _
  AndAlso VDE_Check8s(y1) _
  AndAlso VDE_Check8s(x2) _
  AndAlso VDE_Check8s(y2) Then
    s="L"+Chr(x1+128)+Chr(y1+128)+Chr(x2+128)+Chr(y2+128)
    Return s
  Else
    End
  EndIf
End Function


Function VectTri(x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, x3 As Integer, y3 As Integer) As String
  Dim s As String
  'Unfilled Triangle
  If VDE_Check8s(x1) _
  AndAlso VDE_Check8s(y1) _
  AndAlso VDE_Check8s(x2) _
  AndAlso VDE_Check8s(y2) _
  AndAlso VDE_Check8s(x3) _
  AndAlso VDE_Check8s(y3) Then
    s="U"+Chr(x1+128)+Chr(y1+128) _
     +Chr(x2+128)+Chr(y2+128) _
     +Chr(x3+128)+Chr(y3+128)
    Return s
  Else
    End
  EndIf
End Function


Function VectFTri(x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, x3 As Integer, y3 As Integer) As String
  Dim s As String
  'Filled Triangle
  If VDE_Check8s(x1) _
  AndAlso VDE_Check8s(y1) _
  AndAlso VDE_Check8s(x2) _
  AndAlso VDE_Check8s(y2) _
  AndAlso VDE_Check8s(x3) _
  AndAlso VDE_Check8s(y3) Then
    s="T"+Chr(x1+128)+Chr(y1+128) _
     +Chr(x2+128)+Chr(y2+128) _
     +Chr(x3+128)+Chr(y3+128)
    Return s
  Else
    End
  EndIf
End Function


Function VectBox(x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer) As String
  Dim s As String
  'Box
  If VDE_Check8s(x1) _
  AndAlso VDE_Check8s(y1) _
  AndAlso VDE_Check8s(x2) _
  AndAlso VDE_Check8s(y2) Then
    s="L"+Chr(x1+128)+Chr(y1+128)+Chr(x1+128)+Chr(y2+128) _
     +"L"+Chr(x1+128)+Chr(y2+128)+Chr(x2+128)+Chr(y2+128) _
     +"L"+Chr(x2+128)+Chr(y2+128)+Chr(x2+128)+Chr(y1+128) _
     +"L"+Chr(x2+128)+Chr(y1+128)+Chr(x1+128)+Chr(y1+128)
    Return s
  Else
    End
  EndIf
End Function


Function VectFBox(x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer) As String
  Dim s As String
  'Filled Box
  If VDE_Check8s(x1) _
  AndAlso VDE_Check8s(y1) _
  AndAlso VDE_Check8s(x2) _
  AndAlso VDE_Check8s(y2) Then
    s="T"+Chr(x1+128)+Chr(y1+128) _
     +Chr(x2+128)+Chr(y1+128) _
     +Chr(x1+128)+Chr(y2+128) _
     +"T"+Chr(x1+128)+Chr(y2+128) _
     +Chr(x2+128)+Chr(y1+128) _
     +Chr(x2+128)+Chr(y2+128)
    Return s
  Else
    End
  EndIf
End Function


Function VectCircle(x As Integer, y As Integer, r As Integer) As String
  If VDE_Check8s(x) _
  AndAlso VDE_Check8s(y) _
  AndAlso VDE_Check8u(r) Then
    Return "C"+Chr(x+128)+Chr(y+128)+Chr(r) 's
  Else
    End
  EndIf
End Function


Function VectFCircle(x As Integer, y As Integer, r As Integer) As String
  If VDE_Check8s(x) _
  AndAlso VDE_Check8s(y) _
  AndAlso VDE_Check8u(r) Then
    Return "D"+Chr(x+128)+Chr(y+128)+Chr(r) 's
  Else
    End
  EndIf
End Function


'################################################
'## Graphics - draw
'################################################

'Token
' "v"                     Vehicle coordinate scale
' "Z" n                   Zoom in
' "z" n                   Zoom out
' "R" m,n                 Zoom range out,in
' "E"                     End Zoom
' "X"                     Exit
' "O" r,g,b               Color
' "C" x,y,r               Circle
' "D" x,y,r               Disc = filled Circle
' "L" x1,y1,x2,y2         Line
' "T" x1,y1,x2,y2,x3,y3   Triangle
' "U" x1,y1,x2,y2,x3,y3   Unfilled Triangle


Function SkipDrawZoom(mBuild As String, i As Integer) As Integer
  While (mBuild[i]<>Asc("E")) _
  AndAlso(i<Len(mBuild))
    Select Case mBuild[i]
    Case Asc("X")
      i+=1
    Case Asc("C")
      i+=4
    Case Asc("D")
      i+=4
    Case Asc("O")
      i+=4
    Case Asc("L")
      i+=5
    Case Asc("T")
      i+=7
    Case Asc("U")
      i+=7
    Case Else
      'error - skip command string
      Print "Error - SkipDrawZoom - Build String Syntax i="+str(i)
      Sleep
      i=Len(mBuild)
    End Select
  Wend
  Return i
End Function


Sub DrawModel(ax As Integer, ay As Integer, bx As Integer, by As Integer, _
  mBuild As String, v As TView, col As Integer=1, _
  NoDebug As Integer=0, dwin As Any Ptr=0)
  'NoDebug: Don't draw reference points for models in debug view
 
  Dim As longInt tx0,ty0,tx1,ty1,tx2,ty2
  Dim As Integer rx0,ry0,rx1,ry1,rx2,ry2,distance
  Dim As Integer i, co, ucol, CoorScale=ScaleBuilding
  Dim As longint d
  Dim As p3 a, b, c
  Dim m As Integer = 1000 '1000mm = 1m
  Const ZoomScale=0.8
 
  If VisRectItem(ax, ay, bx, by, v) Then
    tx0=ax
    ty0=ay
    tx1=(bx-ax)
    ty1=(by-ay)
    tx2=(by-ay)
    ty2=-(bx-ax)
    distance=Sqr(tx1*tx1+ty1*ty1)
    i=0
    If 1<v.Scale*m*2/distance Then
      Do While i<Len(mBuild)
        'Commands with shortest parameter list first!
       
        Select Case mBuild[i]
        Case Asc("v")
          'Vehicle coordinate scale
          CoorScale=ScaleVehicle
       
        Case Asc("Z")
          'ZoomIn
          i+=1: rx0=mBuild[i]
          If rx0<ZoomScale*v.Scale*m/distance Then
            i=SkipDrawZoom(mBuild, i+1)
          EndIf
       
        Case Asc("z")
          'ZoomOut
          i+=1: rx0=mBuild[i]
          If rx0>=ZoomScale*v.Scale*m/distance Then
            i=SkipDrawZoom(mBuild, i+1)
          EndIf
       
        Case Asc("R")
          'ZoomRange out,in
          i+=1: rx0=mBuild[i]
          i+=1: rx1=mBuild[i]
          If rx0>=ZoomScale*v.Scale*m/distance _
          OrElse rx1<ZoomScale*v.Scale*m/distance Then
            i=SkipDrawZoom(mBuild, i+1)
          EndIf
       
        Case Asc("X")
          'Exit
          i=Len(mBuild)
       
        Case Asc("O")
          'Color
          i+=1: ucol=mBuild[i]*&H10000
          i+=1: ucol+=mBuild[i]*&H100
          i+=1: ucol+=mBuild[i]
          If ucol=1 Then
            co=col
          Else
            co=ucol
          EndIf
       
        Case Asc("C")
          'Circle
          i+=1: rx0=(mBuild[i]-128)*coorscale
          i+=1: ry0=(mBuild[i]-128)*coorscale+500
          i+=1: rx1=mBuild[i]*coorscale*m/v.Scale
          Circle dwin,(xcoor(tx0 +(rx0*tx2+ry0*tx1)/m), _
                 ycoor(ty0 +(rx0*ty2+ry0*ty1)/m)), _
                 rx1/m*distance/m,co
       
        Case Asc("D")
        'Disc = filled circle
          i+=1: rx0=(mBuild[i]-128)*coorscale
          i+=1: ry0=(mBuild[i]-128)*coorscale+500
          i+=1: rx1=mBuild[i]*coorscale*m/v.Scale
          Circle dwin,(xcoor(tx0 +(rx0*tx2+ry0*tx1)/m), _
                 ycoor(ty0 +(rx0*ty2+ry0*ty1)/m)), _
                 rx1/m*distance/m,co,,,,F
       
        Case Asc("L")
          'Line
          i+=1: rx0=(mBuild[i]-128)*coorscale
          i+=1: ry0=(mBuild[i]-128)*coorscale+500
          i+=1: rx1=(mBuild[i]-128)*coorscale
          i+=1: ry1=(mBuild[i]-128)*coorscale+500
          Line dwin,(xcoor(tx0 +(rx0*tx2+ry0*tx1)/m), _
               ycoor(ty0 +(rx0*ty2+ry0*ty1)/m)) _
             -(xcoor(tx0 +(rx1*tx2+ry1*tx1)/m), _
               ycoor(ty0 +(rx1*ty2+ry1*ty1)/m)),co
       
        Case Asc("T")
          'Filled Triangle
          i+=1: rx0=(mBuild[i]-128)*coorscale
          i+=1: ry0=(mBuild[i]-128)*coorscale+500
          i+=1: rx1=(mBuild[i]-128)*coorscale
          i+=1: ry1=(mBuild[i]-128)*coorscale+500
          i+=1: rx2=(mBuild[i]-128)*coorscale
          i+=1: ry2=(mBuild[i]-128)*coorscale+500
          a.x=xcoor(tx0 +(rx0*tx2+ry0*tx1)/m)
          a.y=ycoor(ty0 +(rx0*ty2+ry0*ty1)/m)
          b.x=xcoor(tx0 +(rx1*tx2+ry1*tx1)/m)
          b.y=ycoor(ty0 +(rx1*ty2+ry1*ty1)/m)
          c.x=xcoor(tx0 +(rx2*tx2+ry2*tx1)/m)
          c.y=ycoor(ty0 +(rx2*ty2+ry2*ty1)/m)
          TriDraw(a,b,c,co,dwin)
       
        Case Asc("U")
          'Unfilled Triangle
          i+=1: rx0=(mBuild[i]-128)*coorscale
          i+=1: ry0=(mBuild[i]-128)*coorscale+500
          i+=1: rx1=(mBuild[i]-128)*coorscale
          i+=1: ry1=(mBuild[i]-128)*coorscale+500
          i+=1: rx2=(mBuild[i]-128)*coorscale
          i+=1: ry2=(mBuild[i]-128)*coorscale+500
          a.x=xcoor(tx0 +(rx0*tx2+ry0*tx1)/m)
          a.y=ycoor(ty0 +(rx0*ty2+ry0*ty1)/m)
          b.x=xcoor(tx0 +(rx1*tx2+ry1*tx1)/m)
          b.y=ycoor(ty0 +(rx1*ty2+ry1*ty1)/m)
          c.x=xcoor(tx0 +(rx2*tx2+ry2*tx1)/m)
          c.y=ycoor(ty0 +(rx2*ty2+ry2*ty1)/m)
          Line dwin, (a.x,a.y)-(b.x,b.y),co
          Line dwin, (b.x,b.y)-(c.x,c.y),co
          Line dwin, (a.x,a.y)-(c.x,c.y),co
       
        Case Asc("E")
          'is a valid command - do nothing
 
        Case Else
          'error - skip command string
          Print "Error - DrawModel - Build String Syntax i="+str(i)
          Sleep
          i=Len(mBuild)
         
        End Select
       
        i+=1
      Loop
    EndIf
    'debug: show reference point and normal vectors
    If v.Debug AndAlso (NoDebug=0) Then
      Circle dwin,(xcoor(ax),ycoor(ay)),3,&Hffff00,,,,f     'PointA
      Circle dwin,(xcoor(bx),ycoor(by)),3,&H8080ff          'PointB
      Circle dwin,(xcoor(ax+tx2),ycoor(ay+ty2)),3,&H00ffff  '90° Point
    EndIf
  EndIf
End Sub
veggie
Posts: 75
Joined: May 17, 2009 12:52

Re: Vector Graphics Engine

Postby veggie » Dec 31, 2011 2:33

Lovely stuff, thank you!
veggie
Posts: 75
Joined: May 17, 2009 12:52

Re: Vector Graphics Engine

Postby veggie » Jan 02, 2012 1:05

Had more of a chance to appreciate this little lib, small but perfectly formed(nice docs too!), well done!

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 9 guests