Code-Beispiel

3D ohne Library (nur FB Befehle)

Lizenz:	Erster Autor:	Letzte Bearbeitung:
GPL	TJF	28.04.2011
Ausgabe
Dieses Beispiel zeigt einen Würfel als 3D-Darstellung, der im Raum gedreht wird. Die Darstellung erfolgt in drei Ansichten aus verschiedenen Blickrichtungen.

Die Berechnung der Raumpunkte und der perspektivischen Darstellung erfolgt unter Anwendung von homogenen Koordinaten (wie sie z. B. auch in OpenGl verwendet werden). Es wird hier jedoch auf die Verwendung von externen Bibliotheken verzichtet. Alle Berechnungen sind ausschließlich mit FreeBasic-Befehlen realisiert.

Der Code wurde in Kooperation mit owen im englischen Forum entwickelt, siehe FreeBasic.Forum.
#DEFINE MAT1 {{1.0,0.0,0.0,0.0},{0.0,1.0,0.0,0.0},{0.0,0.0,1.0,0.0},{0.0,0.0,0.0,1.0}}

#DEFINE E_Z TYPE<v3>(0.0, 0.0, 1.0)

#DEFINE ME_Z TYPE<v3>(0.0, 0.0, -1.0)

Const As Integer MAXPNTS = 50

Const As Single EPS = 1e-7

Const As Single PI = 4 * Atn(1)

Const As Single GRAD_RAD = PI / 180

Const As Single PIXEL_HOCH_ZU_BREIT = 1.0

Dim As Uinteger SCW = 800, SCH = 600

SCREENRES SCW, SCH, 8



SUB er(Byval T As String)

  If Len(T) Then ?T : Sleep

  End 0

End Sub



Sub NormM4(M() As Single)

  M(0, 0) = 1.0 : M(0, 1) = 0.0 : M(0, 2) = 0.0 : M(0, 3) = 0.0

  M(1, 0) = 0.0 : M(1, 1) = 1.0 : M(1, 2) = 0.0 : M(1, 3) = 0.0

  M(2, 0) = 0.0 : M(2, 1) = 0.0 : M(2, 2) = 1.0 : M(2, 3) = 0.0

  M(3, 0) = 0.0 : M(3, 1) = 0.0 : M(3, 2) = 0.0 : M(3, 3) = 1.0

End Sub



Sub MulMat(A() As Single, B() As Single, C() As Single)

  For i As Integer = 0 To 3

    C(0, i) = A(0,0)*B(0,i) + A(0,1)*B(1,i) + A(0,2)*B(2,i) + A(0,3)*B(3,i)

    C(1, i) = A(1,0)*B(0,i) + A(1,1)*B(1,i) + A(1,2)*B(2,i) + A(1,3)*B(3,i)

    C(2, i) = A(2,0)*B(0,i) + A(2,1)*B(1,i) + A(2,2)*B(2,i) + A(2,3)*B(3,i)

    C(3, i) = A(3,0)*B(0,i) + A(3,1)*B(1,i) + A(3,2)*B(2,i) + A(3,3)*B(3,i)

  Next

End Sub



Sub InvMat(M() As Single, R() As Single)

  Dim As Single d

  Dim As Integer i, j, i1, i2, i3, j1, j2, j3, fl = 1

  For i = 0 To 3

    i1 = (i + 1) And 3 : i2 = (i + 2) And 3 : i3 = (i + 3) And 3

    For j = 0 To 3

      j1 = (j + 1) And 3 : j2 = (j + 2) And 3 : j3 = (j + 3) And 3

      R(j, i) = M(i1,j1) * (M(i2,j2)*M(i3,j3) - M(i2,j3)*M(i3,j2)) + _

                M(i1,j2) * (M(i2,j3)*M(i3,j1) - M(i2,j1)*M(i3,j3)) + _

                M(i1,j3) * (M(i2,j1)*M(i3,j2) - M(i2,j2)*M(i3,j1))

      R(j, i) *= fl

      fl = -fl

    Next

    fl = -fl

  Next

  For i = 0 To 3 : d += M(0, i) * R(i, 0) : Next

  If Abs(d) < EPS Then er("InvMat: Matrix nicht regulaer")

  For i = 0 To 3

    For j = 0 To 3

      R(i, j) /= d

    Next

  Next

End Sub







Type v3

  Declare Function Norm() As Integer

  As Single x, y, z

End Type



Function v3.Norm() As Integer

  Dim As Single n = Sqr(x*x + y*y + z*z)

  If Abs(n) < EPS Then Return -1

  x /= n : y /= n : z /= n : Return 0

End Function





Type v2

  As Single x, y

End Type



Type vert

  As v3 crd, nrm

  As INTEGER c

End Type



Type ansicht

PUBLIC:

  Declare Sub Clr()

  Declare Sub Scr(Byval As Single, Byval As Single, Byval As Single, Byval As Single)

  Declare Sub MCtoDC(Byref V As v3, Byref X As Single, Byref Y As Single)

  Declare Sub Vie(Byval As Single, Byval As Single, Byval As Single, _

                  Byval As Single, Byval As Single, Byval As Single, _

                  Byval As Single, Byval As Single, Byval As Single, _

                  Byval As Single, Byval As Single, Byval As Single, _

                  Byval As Single, Byval As Single, Byval As Single)

  Declare Sub LocalInit()

  Declare Sub updateMats()



  As Single MC_WC(3, 3), MC_DC(3, 3)



PRIVATE:

  Declare Sub Init()

  Declare Sub SetV()

  Declare Sub SetS(Byval Lu As v2, Byval Ro As v2)

  Declare Sub CalcVRC_NPC()

  Declare Sub CalcWC_VRC()



  As Uinteger maxint

  As Integer frame, MaChe



  As Single lux, luy, rox, roy

  As Single YsubO, YsubU, SpanMemSize

  As Single VPD, FPD, BPD

  As Single xMin, yMin, xMax, yMax, xSize, ySize

  As Single xwinsize, ywinsize, xwinoffs, ywinoffs



  As v3 VRP, NRP, VUP

  As v3 eyePoint



  As Single WC_NPC(3, 3), MC_NPC(3, 3)

  As Single WC_MC(3, 3), WC_DC(3, 3), NPC_MC(3, 3), NPC_DC(3, 3)

  As Single WC_VRC(3, 3), VRC_NPC(3, 3), NPC_WC(3, 3)

End Type



Sub ansicht.Clr()

  Line(rox, roy) - (lux, luy), 1, BF

End Sub



Sub ansicht.Scr(Byval Lx As Single, Byval Uy As Single, _

                Byval Rx As Single, Byval Oy As Single)

  lux = Lx

  luy = Uy

  rox = Rx

  roy = Oy

  YsubO = CINT(roy)

  YsubU = CINT(roy - 1)

  SpanMemSize = CINT((rox + 1) * 2)

  ySize = xSize * PIXEL_HOCH_ZU_BREIT * (luy - roy) / (rox - lux)

End Sub



Sub ansicht.Vie(Byval Vrpx As Single, Byval Vrpy As Single, Byval Vrpz As Single, _

                Byval Nrpx As Single, Byval Nrpy As Single, Byval Nrpz As Single, _

                Byval Vupx As Single, Byval Vupy As Single, Byval Vupz As Single, _

                Byval Minx As Single, Byval Miny As Single, Byval SizeX As Single, _

                Byval Vpd_ As Single, Byval Fpd_ As Single, Byval Bpd_ As Single)

  VRP.x = Vrpx

  VRP.y = Vrpy

  VRP.z = Vrpz

  NRP.x = Nrpx

  NRP.y = Nrpy

  NRP.z = Nrpz

  VUP.x = Vupx

  VUP.y = Vupy

  VUP.z = Vupz

  xMin  = Minx

  yMin  = Miny

  xSize = SizeX

  VPD = Vpd_

  FPD = Fpd_

  BPD = Bpd_

End Sub



Sub ansicht.Init()

  YSubU = CINT(luy)

  xMax = xMin + xSize

  yMax = yMin + ySize * (luy - YsubO) / (luy - roy)

  SetV()

  SetS(TYPE<v2>(lux, YsubU), TYPE<v2>(rox, YsubO))

End Sub



Sub ansicht.CalcWC_VRC()

  Dim As v3 vpn, vup_

  Dim As Single scal

  WC_VRC(0, 0) = 1.0

  WC_VRC(0, 1) = VRP.x

  WC_VRC(0, 2) = VRP.y

  WC_VRC(0, 3) = VRP.z

  vpn.x = NRP.x - VRP.x

  vpn.y = NRP.y - VRP.y

  vpn.z = NRP.z - VRP.z

  If vpn.Norm() Then er("CalcWC_VRC: VRP und NRP sind identisch!")

  WC_VRC(3, 0) = 0.0

  WC_VRC(3, 1) = vpn.x

  WC_VRC(3, 2) = vpn.y

  WC_VRC(3, 3) = vpn.z

  scal = VUP.x * vpn.x + VUP.y * vpn.y + VUP.z * vpn.z

  vup_.x = VUP.x - scal * vpn.x

  vup_.y = VUP.y - scal * vpn.y

  vup_.z = VUP.z - scal * vpn.z

  If vup_.Norm() Then er("CalcWC_VRC: VUP liegt kollinear zu (VRP, NRP)!")

  WC_VRC(2, 0) = 0.0

  WC_VRC(2, 1) = vup_.x

  WC_VRC(2, 2) = vup_.y

  WC_VRC(2, 3) = vup_.z

  WC_VRC(1, 0) = 0.0

  WC_VRC(1, 1) = vup_.y * vpn.z - vup_.z * vpn.y

  WC_VRC(1, 2) = vup_.z * vpn.x - vup_.x * vpn.z

  WC_VRC(1, 3) = vup_.x * vpn.y - vup_.y * vpn.x

  eyePoint.x = vpn.x * VPD + VRP.x

  eyePoint.y = vpn.y * VPD + VRP.y

  eyePoint.z = vpn.z * VPD + VRP.z

End Sub



Sub ansicht.CalcVRC_NPC()

  Dim As Single k, l

  k = (VPD - BPD) / VPD

  l = (FPD - BPD) / (VPD - FPD)

  VRC_NPC(0, 0) = 0.0

  VRC_NPC(0, 1) = k * xMin

  VRC_NPC(0, 2) = k * yMin

  VRC_NPC(0, 3) = BPD

  VRC_NPC(1, 0) = 0.0

  VRC_NPC(1, 1) = k * (xMax - xMin)

  VRC_NPC(1, 2) = 0.0

  VRC_NPC(1, 3) = 0.0

  VRC_NPC(2, 0) = 0.0

  VRC_NPC(2, 1) = 0.0

  VRC_NPC(2, 2) = k * (yMax - yMin)

  VRC_NPC(2, 3) = 0.0

  VRC_NPC(3, 0) = 1.0

  VRC_NPC(3, 1) = 0.0

  VRC_NPC(3, 2) = 0.0

  VRC_NPC(3, 3) = l * VPD

End Sub



Sub ansicht.SetV()

  CalcWC_VRC()

  CalcVRC_NPC()

  MulMat(VRC_NPC(), WC_VRC(), NPC_WC())

  InvMat(NPC_WC(), WC_NPC())

  MaChe = 1

End Sub



Sub ansicht.SetS(Byval Lu As v2, Byval Ro As v2)

  Clr()

  xwinsize = Ro.x - Lu.x

  xwinoffs = CINT(Lu.x)

  ywinsize = Ro.y - Lu.y

  ywinoffs = CINT(Lu.y)

  NormM4(NPC_DC())

  NPC_DC(1, 1) = xwinsize

  NPC_DC(2, 2) = ywinsize

  NPC_DC(3, 3) = maxint

  NPC_DC(0, 1) = xwinoffs

  NPC_DC(0, 2) = ywinoffs

  MaChe = 1

End Sub



Sub ansicht.LocalInit()

  YSubU = CINT(luy)

  xMax = xMin + xSize

  yMax = yMin + ySize * (luy - YsubO) / (luy - roy)

  SetV()

  SetS(TYPE<v2>(lux, YsubU), TYPE<v2>(rox, YsubO))

End Sub



Sub ansicht.updateMats()

  If MaChe = 0 Then Exit Sub

  Dim As Single mc_npc(3, 3)

  MulMat(MC_WC(), WC_NPC(), mc_npc())

  MulMat(mc_npc(), NPC_DC(), MC_DC())

  InvMat(MC_WC(), WC_MC())

  InvMat(mc_npc(), NPC_MC())

  MaChe = 0

End Sub



Sub ansicht.MCtoDC(Byref V As v3, Byref X As Single, Byref Y As Single)

  Dim As Single w

  w = MC_DC(0, 0) + V.x * MC_DC(1, 0) + V.y * MC_DC(2, 0) + V.z * MC_DC(3, 0)

  If Abs(w) < EPS Then er("MC_DC: Punkt nicht definiert!")

  X = (MC_DC(0, 1) + V.x * MC_DC(1, 1) + V.y * MC_DC(2, 1) + V.z * MC_DC(3, 1)) / w

  Y = (MC_DC(0, 2) + V.x * MC_DC(1, 2) + V.y * MC_DC(2, 2) + V.z * MC_DC(3, 2)) / w

End Sub



SUB Rotate(Byval V As ansicht Ptr, BYVAL A AS INTEGER, BYVAL W AS SINGLE)

  DIM AS SINGLE s = SIN(W * GRAD_RAD), c = COS(W * GRAD_RAD)

  DIM AS Single mcdc(3, 3), M(3, 3) = MAT1

  WITH *V

    FOR z AS INTEGER = 0 TO 3

      FOR s AS INTEGER = 0 TO 3

        mcdc(z, s) = .MC_DC(z, s)

      NEXT

    NEXT

    SELECT CASE AS CONST A

    CASE 1 : M(2, 2) = c : M(2, 3) = s : M(3, 2) = -s : M(3, 3) = c

    CASE 2 : M(1, 1) = c : M(1, 3) = s : M(3, 1) = -s : M(3, 3) = c

    CASE 3 : M(1, 1) = c : M(1, 2) = s : M(2, 1) = -s : M(2, 2) = c

    END SELECT

    MulMat(M(), mcdc(), .MC_DC())

  END WITH

END SUB



Dim Shared mycube(8) As vert

Dim As Integer i,j

For i = 1 To 8

        With mycube(i).crd

                Read .x,.y,.z

        End With

Next



Sub DrawCube(Byval A As ansicht Ptr)

  Dim As Single x(8), y(8)

  For i As Integer = 1 To 8

    (*A).MCtoDC(mycube(i).crd, x(i), y(i))

  Next



  (*A).Clr()

  Line (x(1), y(1)) - (x(2), y(2)),14

  Line - (x(3), y(3)),14

  Line - (x(4), y(4)),14

  Line - (x(1), y(1)),14

  Line - (x(5), y(5)),12

  Line - (x(6), y(6)),13

  Line - (x(7), y(7)),13

  Line - (x(8), y(8)),13

  Line - (x(5), y(5)),13

  Line (x(2), y(2)) - (x(6), y(6)),12

  Line (x(3), y(3)) - (x(7), y(7)),12

  Line (x(4), y(4)) - (x(8), y(8)),12

  Circle (x(1), y(1)),10,15

End Sub



DIM AS INTEGER x1 = 10, x2 = SCW\2-5, x3 = x2+10, x4 = SCW-10

DIM AS INTEGER y1 = 10, y2 = SCH\2-5, y3 = y2+10, y4 = SCH-10

Dim As Single Mnx = -1.5, Mny = -1.0, Six = 3.0

Dim As Single Vpd = 6, Fpd = 1.5, Bpd = -1.5



Dim As ansicht PTR Ans = New ansicht[3]



Ans[0].Vie(0.0, 0.0, 0.0, _

           0.0, -1.0, 0.0, _

           0.0, 0.0, 1.0, _

          Mnx, Mny, Six, Vpd, Fpd, Bpd)

Ans[0].Scr(x1, y2, x2, y1)



Ans[1].Vie(0.0, 0.0, 0.0, _

           -1.0, 0.0, 0.0, _

           0.0, 0.0, 1.0, _

          Mnx, Mny, Six, Vpd, Fpd, Bpd)

Ans[1].Scr(x3, y2, x4, y1)



Ans[2].Vie(0.0, 0.0, 0.0, _

           0.0, 0.0, 1.0, _

           0.0, 1.0, 0.0, _

          Mnx, Mny, Six, Vpd, Fpd, Bpd)

Ans[2].Scr(x1, y4, x2, y3)



For i = 0 TO 2

  NormM4(Ans[i].MC_WC())

  Ans[i].LocalInit()

  Ans[i].updateMats()

Next



Dim h As String

Dim As Integer axis_x,axis_y,axis_z,ax

Dim As Single ro,st=1.0

Print "rotate axes using keys (y,h / u,j / i,k)"

Do

  Locate 50,60

  Print "axis x=";axis_x;"  "

  Locate 51,60

  Print "axis y=";axis_y;"  "

  Locate 52,60

  Print "axis z=";axis_z;"  "

  For i = 0 To 2

    DrawCube(@Ans[i])

  Next

  Sleep : Do : h=InKey : Loop Until Len(h)

  Select Case h

    Case Chr(27), Chr(255) + "k"

      Exit Do

    Case "y"

      axis_z=(axis_z+st) Mod 360 : ax=3 : ro=st

    Case "h"

      axis_z=(axis_z-st) Mod 360 : ax=3 : ro=-st

    Case "u"

      axis_y=(axis_y+st) Mod 360 : ax=2 : ro=st

    Case "j"

      axis_y=(axis_y-st) Mod 360 : ax=2 : ro=-st

    Case "i"

      axis_x=(axis_x+st) Mod 360 : ax=1 : ro=st

    Case "k"

      axis_x=(axis_x-st) Mod 360 : ax=1 : ro=-st

    Case Else

      ax=0 : ro=0.0 : Continue Do

  End Select

  For i = 0 To 2

    Rotate(@Ans[i],ax,ro)

  Next : While len(inkey) : Wend

Loop

Delete[] Ans

End



'cube

Data -1, 1, 1

Data -1,-1, 1

Data  1,-1, 1

Data  1, 1, 1



Data -1, 1,-1

Data -1,-1,-1

Data  1,-1,-1

Data  1, 1,-1
Zusätzliche Informationen und Funktionen
Das Code-Beispiel wurde am 25.09.2010 von TJF angelegt.
Die aktuellste Version wurde am 28.04.2011 von TJF gespeichert.
Bearbeiten
Versionen