Текстурированный куб с использованием Quick Basic 4.5

Текстурированный куб с использованием Quick Basic 4.5 — Лисья нора

Главная

Лента

Блог

Сервисы

Проекты

Главная » Проекты » Программы Quick Basic 4.5 » Текстурированный куб с использованием Quick Basic 4.5

§ Описание

Когда-то я очень хотел создать трехмерную графику на Бейсике, и вот спустя много лет, наконец-то, взялся за дело и сделал это. Но и не только. Помимо самой графики, также научился использовать буфер для того, чтобы рисовать сначала в нем, а потом показывать на экране. Это нерационально, но все-таки, это работает.

Скриншот экрана окна Бейсика. А также можно скачать CRAFT.BMP, для источника данных.

§ Основная программа

#RENDERDRAWTRIDRAWCUBECALCCAMROTCAMTRANMATIDENTMATMULTCLEARBUFRESTOREBUFLOADPALETTELOADTILE
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

Оглавление

§ Описание

§ Основная программа