Оглавление
§ Описание
Когда-то я очень хотел создать трехмерную графику на Бейсике, и вот спустя много лет, наконец-то, взялся за дело и сделал это. Но и не только. Помимо самой графики, также научился использовать буфер для того, чтобы рисовать сначала в нем, а потом показывать на экране. Это нерационально, но все-таки, это работает.
Скриншот экрана окна Бейсика
§ Основная программа
SCREEN 13
CONST NEAR = 0.5
TYPE vec2i
x AS INTEGER
y AS INTEGER
END TYPE
TYPE vec3
x AS SINGLE
y AS SINGLE
z AS SINGLE
u AS SINGLE
v AS SINGLE
END TYPE
TYPE trg
A1 AS SINGLE: A2 AS SINGLE: A3 AS SINGLE
B1 AS SINGLE: B2 AS SINGLE: B3 AS SINGLE
C1 AS SINGLE: C2 AS SINGLE: C3 AS SINGLE
D1 AS SINGLE: D2 AS SINGLE: D3 AS SINGLE
END TYPE
' Point list for triangle
DIM SHARED vc(0 TO 7) AS vec3
DIM SHARED tile(0 TO 15, 0 TO 15) AS INTEGER
' Matrix operation (ma - camera, mb - operation)
DIM SHARED ma(0 TO 3, 0 TO 3) AS SINGLE
DIM SHARED mb(0 TO 3, 0 TO 3) AS SINGLE
DIM SHARED cam AS vec3
DIM SHARED rot AS vec3
DIM wr(0 TO 3, 0 TO 3, 0 TO 3) AS INTEGER
' Vertex (4 back, 4 front)
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
FACES:
' Quads faces a,b,c,d|tex
DATA 0, 4, 7, 3
DATA 0, 1, 5, 4
DATA 4, 5, 6, 7
DATA 1, 0, 3, 2
DATA 2, 3, 7, 6
DATA 5, 1, 2, 6
' Read all vertexes
FOR i = 0 TO 7: READ vc(i).x, vc(i).y, vc(i).z: NEXT
' Sprites
LOADPALETTE ' Loading Palette from CRAFT.BMP
' Camera position
cam.x = 1.5: cam.y = 3: cam.z = -4
rot.x = 0: rot.y = 0: rot.z = 0
' World definition
wr(0,0,3)=1
wr(0,0,2)=2
wr(0,0,1)=3
wr(0,0,0)=4
wr(2,2,0)=1
wr(2,1,2)=2
CLEARBUF
FOR k = 0 TO 3
FOR i = 0 TO 3
FOR j = 0 TO 3
t = wr(j, i, k)
IF t > 0 THEN
LOADTILE t MOD 16, t \ 16
DRAWCUBE 2*j, 2*i, 2*k
END IF
NEXT
NEXT
NEXT
RESTOREBUF
' Draw 1 or 2 Triangle
SUB RENDER (p0 AS vec3, p1 AS vec3, p2 AS vec3)
DIM q(0 TO 2) AS vec3
DIM p(0 TO 3) AS vec3
q(0) = p0: q(1) = p1: q(2) = p2
DIM a AS vec3
DIM b AS vec3
DIM c AS vec3
DIM k AS INTEGER
k = 0
' Apply camera transform
FOR i = 0 TO 2
' Camera transform
qx = q(i).x * ma(0, 0) + q(i).y * ma(0, 1) + q(i).z * ma(0, 2) + ma(0, 3)
qy = q(i).x * ma(1, 0) + q(i).y * ma(1, 1) + q(i).z * ma(1, 2) + ma(1, 3)
qz = q(i).x * ma(2, 0) + q(i).y * ma(2, 1) + q(i).z * ma(2, 2) + ma(2, 3)
' Copy new result
q(i).x = qx: q(i).y = qy: q(i).z = qz
NEXT
' Search clipping
FOR i = 0 TO 2
a = q(i)
b = q((i + 1) MOD 3)
' One point in front of NEAR
IF a.z >= NEAR OR b.z >= NEAR THEN
' Add visible point
IF a.z >= NEAR THEN p(k) = a: k = k + 1
' a.z must be >= b.z
IF (a.z < b.z) THEN SWAP a, b
' Different sides, calc intermediate point
IF (a.z >= NEAR AND b.z < NEAR) THEN
t = (NEAR - b.z) / (a.z - b.z)
c.x = b.x + t * (a.x - b.x)
c.y = b.y + t * (a.y - b.y)
c.z = NEAR
c.u = b.u + t * (a.u - b.u)
c.v = b.v + t * (a.v - b.v)
p(k) = c: k = k + 1
END IF
END IF
NEXT
IF k = 3 OR k = 4 THEN DRAWTRI p(0), p(1), p(2)
IF k = 4 THEN DRAWTRI p(0), p(2), p(3)
END SUB
' Drawing triangle
SUB DRAWTRI (a AS vec3, b AS vec3, c AS vec3)
' Declare dimension
DIM p(0 TO 2) AS vec2i
DIM h(0 TO 2) AS vec3
DIM tri AS trg
DIM cb AS STRING * 320
DIM db(0 TO 319) AS SINGLE
' Copy data
h(0) = a: h(1) = b: h(2) = c
' Make UV-diff
FOR i = 1 TO 2
h(i).u = h(i).u - h(0).u
h(i).v = h(i).v - h(0).v
NEXT
' Projection
FOR i = 0 TO 2
p(i).x = 160 + 100 * h(i).x / h(i).z
p(i).y = 100 - 100 * h(i).y / h(i).z
NEXT
' Check front side
ABx = p(1).x - p(0).x: ABy = p(1).y - p(0).y
ACx = p(2).x - p(0).x: ACy = p(2).y - p(0).y
IF ABy * ACx - ABx * ACy > 0 THEN EXIT SUB
' Sorting
FOR i = 0 TO 2
FOR j = i + 1 TO 2
IF p(i).y > p(j).y THEN SWAP p(i), p(j)
NEXT
NEXT
' Get projection & calculate triangle
CALC h(0), h(1), h(2), tri
' Top -> Bottom. Get diff (C.x - A.x) / (C.y - A.y)
Ax = p(0).x
ACy = (p(2).y - p(0).y): IF ACy = 0 THEN ACy = 1
AC = (p(2).x - p(0).x) / ACy
ABz = h(1).z - h(0).z
ACz = h(2).z - h(0).z
FOR i = 0 TO 1
' Get diff (B/C.x - A/B.x) / (B/B.y - A/B.y)
Bx = p(i).x
By = p(i + 1).y
ABy = By - p(i).y: IF ABy = 0 THEN ABy = 1
AB = (p(i + 1).x - p(i).x) / ABy
' Y0..Y1-1; Y1..Y2
IF i = 0 THEN By = By - 1
' Drawing lines
FOR y = p(i).y TO By
IF y >= 0 AND y <= 199 THEN
' Row has been opened
th = 0
x1 = INT(Ax)
x2 = INT(Bx)
IF x1 > x2 THEN SWAP x1, x2
' Show Only visible area
IF x1 < 320 AND x2 >= 0 THEN
' Corrections
x1 = x1 - 2
x2 = x2 + 2
IF x1 < 0 THEN x1 = 0
IF x2 > 319 THEN x2 = 319
' Start position
dx = x1 - 160
dy = 100 - y
dz = 100
' Coord calc
u = dx * tri.A1 + dy * tri.A2 + dz * tri.A3
v = dx * tri.B1 + dy * tri.B2 + dz * tri.B3
D = dx * tri.C1 + dy * tri.C2 + dz * tri.C3
FOR x = x1 TO x2
' Triangle visible
IF D <> 0 AND u >= 0 AND v >= 0 AND u + v < D THEN
ux = u / D
vx = v / D
cz = h(0).z + ux * ABz + vx * ACz
' Open Row
IF th = 0 THEN
th = 1
DEF SEG = VARSEG(cb): BLOAD "TMP\CX" + STR$(y) + ".BIN", VARPTR(cb): DEF SEG
DEF SEG = VARSEG(db(0)): BLOAD "TMP\DX" + STR$(y) + ".BIN", VARPTR(db(0)): DEF SEG
END IF
' Check depth buffer
IF cz < db(x) THEN
' Texture coord and zcoord
tx = INT(h(0).u + ux * h(1).u + vx * h(2).u)
ty = INT(h(0).v + ux * h(1).v + vx * h(2).v)
' Clamp
IF tx < 0 THEN tx = 0 ELSE IF tx > 15 THEN tx = 15
IF ty < 0 THEN ty = 0 ELSE IF ty > 15 THEN ty = 15
cl% = tile(tx, ty)
IF cl% <> 0 THEN
' PSET (x, y), cl%
MID$(cb, 1 + x, 1) = CHR$(cl%)
db(x) = cz
END IF
END IF
END IF
u = u + tri.A1
v = v + tri.B1
D = D + tri.C1
NEXT
END IF
' Save to temporary line
IF th > 0 THEN
DEF SEG = VARSEG(cb): BSAVE "TMP\CX" + STR$(y) + ".BIN", VARPTR(cb), 320: DEF SEG
DEF SEG = VARSEG(db(0)): BSAVE "TMP\DX" + STR$(y) + ".BIN", VARPTR(db(0)), 1280: DEF SEG
END IF
END IF
Ax = Ax + AC
Bx = Bx + AB
NEXT
NEXT
END SUB
' Draw cube for x,y,z
SUB DRAWCUBE(x AS SINGLE, y AS SINGLE, z AS SINGLE)
DIM p(0 TO 2) AS vec3
' Load camera and set cube position
MATIDENT 0
' Camera rotation
CAMROT rot.z, 2
CAMROT rot.x, 0
CAMROT rot.y, 1
' Set cube position
CAMTRAN x - cam.x, y - cam.y, z - cam.z
RESTORE FACES
' 6 Faces (0..5)
FOR i = 0 TO 5
READ f0, f1, f2, f3
' Triangle 1
p(0) = vc(f0): p(0).u = 0: p(0).v = 0
p(1) = vc(f1): p(1).u = 16: p(1).v = 0
p(2) = vc(f2): p(2).u = 16: p(2).v = 16
RENDER p(0), p(1), p(2)
' Triangle 2
p(0) = vc(f0): p(0).u = 0: p(0).v = 0
p(1) = vc(f2): p(1).u = 16: p(1).v = 16
p(2) = vc(f3): p(2).u = 0: p(2).v = 16
RENDER p(0), p(1), p(2)
NEXT
END SUB
' Calculate parameters => tri
SUB CALC (p0 AS vec3, p1 AS vec3, p2 AS vec3, t AS trg)
' Coord triangle
Ax = p0.x: Ay = p0.y: Az = p0.z
Bx = p1.x: By = p1.y: Bz = p1.z
Cx = p2.x: Cy = p2.y: Cz = p2.z
' Diff
ABx = Bx - Ax: ACx = Cx - Ax
ABy = By - Ay: ACy = Cy - Ay
ABz = Bz - Az: ACz = Cz - Az
' u
t.A1 = (Ay * ACz - Az * ACy)
t.A2 = (Az * ACx - Ax * ACz)
t.A3 = (Ax * ACy - Ay * ACx)
' v
t.B1 = (Az * ABy - Ay * ABz)
t.B2 = (Ax * ABz - Az * ABx)
t.B3 = (Ay * ABx - Ax * ABy)
' D
t.C1 = (ABz * ACy - ABy * ACz)
t.C2 = (ABx * ACz - ABz * ACx)
t.C3 = (ABy * ACx - ABx * ACy)
END SUB
' a - angle, axis - 0-X,1-Y,2-Z
SUB CAMROT (a AS SINGLE, axis AS INTEGER)
sina = SIN(a)
cosa = COS(a)
MATIDENT 1
SELECT CASE axis
CASE 0: ' X Axis
mb(1, 1) = cosa: mb(1, 2) = -sina
mb(2, 1) = sina: mb(2, 2) = cosa
CASE 1: ' Y Axis
mb(0, 0) = cosa: mb(0, 2) = sina
mb(2, 0) = -sina: mb(2, 2) = cosa
CASE 2: ' Z Axis
mb(0, 0) = cosa: mb(0, 1) = -sina
mb(1, 0) = sina: mb(1, 1) = cosa
END SELECT
MATMULT
END SUB
' B = <translate matrix>
SUB CAMTRAN (x AS SINGLE, y AS SINGLE, z AS SINGLE)
MATIDENT 1
mb(0, 3) = x
mb(1, 3) = y
mb(2, 3) = z
MATMULT
END SUB
' A=1, B=1 OR C=1
SUB MATIDENT (id AS INTEGER)
FOR i = 0 TO 3
FOR j = 0 TO 3
SELECT CASE id
CASE 0: IF i = j THEN ma(i, j) = 1 ELSE ma(i, j) = 0
CASE 1: IF i = j THEN mb(i, j) = 1 ELSE mb(i, j) = 0
END SELECT
NEXT
NEXT
END SUB
' A = A x B
SUB MATMULT
DIM mt(0 TO 3, 0 TO 3) AS SINGLE
' Mult
FOR i = 0 TO 3
FOR j = 0 TO 3
s = 0
FOR k = 0 TO 3: s = s + ma(i, k) * mb(k, j): NEXT
mt(i, j) = s
NEXT
NEXT
' Copy result to A
FOR i = 0 TO 3: FOR j = 0 TO 3: ma(i, j) = mt(i, j): NEXT: NEXT
END SUB
' Clear Color/ZBuf
SUB CLEARBUF
DIM cb AS STRING * 320
DIM db(0 TO 319) AS SINGLE
FOR i = 0 TO 319
cb = cb + CHR$(0)
db(i) = 32767
NEXT
FOR i = 0 TO 199
DEF SEG = VARSEG(cb): BSAVE "TMP\CX" + STR$(i) + ".BIN", VARPTR(cb), 320: DEF SEG
DEF SEG = VARSEG(db(0)): BSAVE "TMP\DX" + STR$(i) + ".BIN", VARPTR(db(0)), 1280: DEF SEG
NEXT
END SUB
' Draw buffer on screen
SUB RESTOREBUF
DIM cb AS STRING * 320
FOR y = 0 TO 199
DEF SEG = &HA000
BLOAD "TMP\CX" + STR$(y) + ".BIN", 320 * y
DEF SEG
NEXT
END SUB
' Read palette for DAC
SUB LOADPALETTE
DIM pal AS STRING * 3
OPEN "CRAFT.BMP" FOR BINARY AS #1
FOR i = 1 TO 255
GET #1, &H36 + 1 + i * 4, pal
OUT 968, i
OUT 969, ASC(MID$(pal, 3, 1)) \ 4
OUT 969, ASC(MID$(pal, 2, 1)) \ 4
OUT 969, ASC(MID$(pal, 1, 1)) \ 4
NEXT i
CLOSE #1
END SUB
' Load Tile 16x16 Into The DIM
SUB LOADTILE (j AS INTEGER, i AS INTEGER)
DIM dat AS STRING * 16
OPEN "CRAFT.BMP" FOR BINARY AS #1
FOR y = 0 TO 15
GET #1, &H437 + (255 - 16 * i - y) * 256 + 16 * j, dat
FOR x = 0 TO 15: tile(x, y) = ASC(MID$(dat, 1 + x, 1)): NEXT
NEXT
CLOSE #1
END SUB