Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
3D-Würfel
| Uploader: |  max06 |
| Datum/Zeit: | 24.06.2008 23:16:57 |
' Steuerung:
' Pfeiltasten - rechts, links, hoch, runter
' Bild up/down - vor und zurück
' ESC - Beenden
'-----------------------------------------------------------------------------
' PAINT Funktionen
'-----------------------------------------------------------------------------
CONST ROT = 4
CONST CYAN = 3
CONST WEISS = 7
TYPE Raum3d
x AS INTEGER
y AS INTEGER
z AS INTEGER
END TYPE
TYPE Raum2d
x AS INTEGER
y AS INTEGER
END TYPE
DECLARE SUB Paint3dBlock (Ecke1 AS Raum3d, Ecke2 AS Raum3d)
DECLARE SUB PaintBlock (A AS Raum3d, B AS Raum3d, Farbe AS INTEGER, MitteX AS INTEGER)
DECLARE SUB Punkt3d (A AS Raum3d, Posi AS Raum2d, MitteX AS INTEGER)
DECLARE SUB PaintLinie (X1 AS INTEGER, Y1 AS INTEGER, X2 AS INTEGER, Y2 AS INTEGER, farbe As integer, Methode As Integer)
DECLARE SUB PaintPunkt (x AS INTEGER, y AS INTEGER, Farbe AS INTEGER)
' Parameter für die PaintLinie Funktion
CONST LINIE = 0
CONST RECHTECK = 1
CONST KASTEN = 2
'=============================================================================
' Hauptprogramm
'=============================================================================
DIM A AS Raum3d
DIM B AS Raum3d
DIM x AS INTEGER
DIM y AS INTEGER
DIM z AS INTEGER
Dim Shared i As Integer
Dim Shared j As Integer
Dim Shared Farbe As Integer
DIM Zeit AS SINGLE
DIM Seite AS INTEGER
DIM Eingabe AS STRING
SCREENres 1024, 768, 4, Seite
x = 250
y = 130
z = 0
DO
'-----------------
' Würfel zeichnen
'-----------------
LINE (0, 0)-(639, 349), 0, BF
A.x = x: A.y = y: A.z = z
B.x = x + 150: B.y = y + 100: B.z = z + 75
Paint3dBlock(A, B)
LOCATE 23, 1
COLOR 7
PRINT "x = "; x
PRINT "y = "; y
PRINT "z = "; z
Seite = 1 - Seite
' SCREEN 9, , Seite, 1 - Seite
'--------------------
' Warten auf Eingabe
'--------------------
DO
Eingabe = INKEY$
LOOP UNTIL LEN(Eingabe)
SELECT CASE Eingabe
'--- Hoch ---
CASE CHR$(255) + "H"
y = y - 5
'--- Runter ---
CASE CHR$(255) + "P"
y = y + 5
'--- Rechts ---
CASE CHR$(255) + "M"
x = x + 5
'--- Links ---
CASE CHR$(255) + "K"
x = x - 5
'--- Näher holen ---
CASE CHR$(255) + "I"
z = z + 5
'--- Weiter weg ---
CASE CHR$(255) + "Q"
z = z - 5
END SELECT
LOOP UNTIL Eingabe = CHR$(27)
SYSTEM
'=============================================================================
' Zeichnet einen rechteckigen Würfel mit dreidimensionalen Koordinaten zweimal
' so auf den Bildschirm, das dieser mit einer 3d-Brille räunlich gesehen
' werden kann.
'
' Parameter:
' Ecke1 - Erster Eckpunkt des Würfels
' Ecke2 - Gegenüberliegender Eckpunkt des Würfels
'=============================================================================
SUB Paint3dBlock (Ecke1 AS Raum3d, Ecke2 AS Raum3d)
PaintBlock(Ecke1, Ecke2, ROT, 280)
PaintBlock(Ecke1, Ecke2, CYAN, 360)
END SUB
'=============================================================================
' Zeichnet einen rechteckigen Würfel mit dreidimensionalen Koordinaten auf
' den Bildschirm unter zu Hilfename der SUB Punkt. Sie benötigt dazu zwei
' gegenüberliegende Punkte des Würfels als Übergabeparameter.
' (Die globale Variable 'Farbe' bestimmt die Farbe)
'
' Parameter:
' A - Erste Ecke des Würfels
' B - Gegenüberliegende Ecke des Würfels
' Farbe - Würfelfarbe
' MitteX - IN - X-Kooridnate des Fluchtpunktes
'=============================================================================
SUB PaintBlock (A AS Raum3d, B AS Raum3d, Farbe AS INTEGER, MitteX AS INTEGER)
DIM tBlock(1 TO 4, 1) AS Raum2d
DIM sBlock AS Raum3d
Punkt3d(A, tBlock(1, 0), MitteX)
Punkt3d(B, tBlock(3, 1), MitteX)
sBlock.z = A.z: sBlock.x = B.x: sBlock.y = B.y
Punkt3d(sBlock, tBlock(3, 0), MitteX)
sBlock.z = B.z: sBlock.x = A.x: sBlock.y = A.y
Punkt3d(sBlock, tBlock(1, 1), MitteX)
FOR i = 0 TO 1
tBlock(2, i).x = tBlock(3, i).x
tBlock(2, i).y = tBlock(1, i).y
tBlock(4, i).x = tBlock(1, i).x
tBlock(4, i).y = tBlock(3, i).y
NEXT i
FOR i = 1 TO 4
PaintLinie(tBlock(i, 0).x, tBlock(i, 0).y, tBlock(i, 1).x, tBlock(i, 1).y, Farbe, LINIE)
NEXT i
PaintLinie(tBlock(1, 0).x, tBlock(1, 0).y, tBlock(3, 0).x, tBlock(4, 0).y, Farbe, RECHTECK)
PaintLinie(tBlock(1, 1).x, tBlock(1, 1).y, tBlock(3, 1).x, tBlock(4, 1).y, Farbe, RECHTECK)
END SUB
'=============================================================================
' Graphik-Anweisung, die eine Gerade oder ein Rechteck auf dem Bildschirm
' zeichnet.
'
' Parameter:
' X1, Y1 -> Startkoordinaten der Linie / des Rechteckes
' X2, Y2 -> Zielkoordinaten der Linie / des Rechteckes
' Farbe -> Farbe der Linie / des Rechteckes
' Methode = LINIE -> Linie zeichnen
' = RECHTECK -> Rechteck zeichnen
' = KASTEN -> ausgefülltes Rechteck zeichnen
'=============================================================================
SUB PaintLinie (X1 AS INTEGER, Y1 AS INTEGER, X2 AS INTEGER, Y2 AS INTEGER, farbe As integer, Methode As Integer)
DIM mX AS INTEGER ' 1 -> X2 >= X1 -1 -> X1 > X2
DIM mY AS INTEGER ' 1 -> Y2 >= Y1 -1 -> Y1 > Y2
DIM pX2 AS INTEGER
DIM pY2 AS INTEGER
IF X2 >= X1 THEN
mX = 1
ELSE
mX = -1
END IF
IF Y2 >= Y1 THEN
mY = 1
ELSE
mY = -1
END IF
SELECT CASE Methode
'----- Linie zeichnen --------------------------------------------------------
CASE LINIE
DIM E AS INTEGER
DIM dx AS INTEGER ' Differenz zwischen X1 und X2
DIM dy AS INTEGER ' Differenz zwischen Y1 und Y2
DIM pX AS INTEGER ' speichern die aktuelle Position ab
DIM pY AS INTEGER
Dim As Integer Steep = 0
E = 0
dx = ABS(X2 - X1) ' Differenz berechnen
dy = ABS(Y2 - Y1)
pX = X1 ' Variablen auf Anfangswert setzen
pY = Y1
E = 2 * dy - dx
IF (dy > dx) THEN '----- dY > dX -----
FOR i = 0 TO dy - 1
PaintPunkt(pX, pY, farbe)
DO WHILE E >= 0
pX = pX + mX
E = E - dy * 2
LOOP
pY = pY + mY
E = E + dx * 2
NEXT i
ELSE '----- dX >= dY -----
FOR i = 0 TO dx - 1
PaintPunkt(pX, pY, farbe)
DO WHILE E >= 0
pY = pY + mY
E = E - dx * 2
LOOP
pX = pX + mX
E = E + dy * 2
NEXT i
END IF
PaintPunkt(INT(pX2), INT(pY2), farbe)
'----- Rechteck zeichnen -----------------------------------------------------
CASE RECHTECK
FOR i = X1 TO X2 STEP mX
PaintPunkt(i, Y1, farbe)
PaintPunkt(i, Y2, farbe)
NEXT i
FOR i = Y1 + 1 TO Y2 - 1 STEP mY
PaintPunkt(X1, i, farbe)
PaintPunkt(X2, i, farbe)
NEXT i
'----- ausgefülltes Viereck zeichnen -----------------------------------------
CASE KASTEN
FOR i = X1 TO X2 STEP mX
FOR j = Y1 TO Y2 STEP mY
PaintPunkt(i, j, farbe)
NEXT j, i
END SELECT
END SUB
'=============================================================================
' Graphik-Anweisung, die einen Punkt auf dem Bildschirm zeichnet.
' Speziel für dieses Programm wird der Punkt nur dann in der gewünschten
' Farbe gezeichnet, wenn der Bildschirmpunkt vorher noch leer war.
' Hatte der Bildschirm bereits eine andere Farbe an dieser Stelle wird der
' Punkt weiß gezeichnet.
'
' Parameter:
' X -> x-Koordinate des Punktes
' Y -> y-Koordinate des Punktes
' Farbe -> Farbe des Punktes
'=============================================================================
SUB PaintPunkt (x AS INTEGER, y AS INTEGER, Farbe AS INTEGER)
DIM Alt AS INTEGER
Alt = POINT(x, y)
IF Alt = 0 THEN
PSET (x, y), Farbe
ELSEIF Alt <> Farbe THEN
PSET (x, y), WEISS
END IF
END SUB
'=============================================================================
' Rechnet die dreidimensionale Koordinate 'Raum' in eine Zweidimensionale
' 'Posi' um, für die Ausgabe am Bildschirm
'
' Parameter:
' Posi3d - IN - Koordinaten des Punktes im Dreidimensionalen Raum
' Pori2d - OUT - Berechnete Bildschirmkoordinaten des Punktes
' MitteX - IN - X-Koordinate des Fluchtpunktes
'=============================================================================
SUB Punkt3d (Posi3d AS Raum3d, Posi2d AS Raum2d, MitteX AS INTEGER)
'Mitte-> X: 320 Y:175
DIM div AS DOUBLE
div = 1.002 ^ Posi3d.z
Posi2d.x = (Posi3d.x - MitteX) / div + MitteX
Posi2d.y = (Posi3d.y - 175) / div + 175
END Sub