Keskustelu: Koodit: VB6: Yksinkertainen 3D-sokkelo

'' Yleisiä muuttujia
Option Explicit
DefInt A-Z

Const MaXX = 8, MaXY = 8
' Bittikuviot
Const YlaSeina = 1, OikeaSeina = 2, AlaSeina = 4, VasenSeina = 8

Const Syvyys = 4

Dim Shared Kentta(1 To MaXX, 1 To MaXY) As Integer
Dim Shared Suunta, HX, HY, PiirJar(4), Maara(Syvyys)
Dim Shared DepCol(Syvyys) As Long


Sub FillVertical (bb As PictureBox, x1 As Integer, x2 As Integer, y1 As Integer, y2 As Integer, h1 As Integer, col As Long)
'' Täyttää nelikulmion tietyllä värillä; itse keksaistu koodi.
'' Melko nopea.
Dim ym As Double, x, xm, w
  ym = CDbl(Abs(y2 - y1)) / CDbl(x2 - x1)
  xm = Sgn(x2 - x1): w = (x2 - x1)
  For x = 0 To w Step xm
    bb.Line (x1 + x, y1 - (x * ym))-(x1 + x, y1 + h1 + (x * ym)), col
  Next x
End Sub

Sub LataaKentta (tied As String)
'' Lataa kentän tiedostosta
Dim a, B, ff
  ff = FreeFile
  Open tied For Input As #ff
    For a = 1 To MaXY: For B = 1 To MaXX
        Input #ff, Kentta(B, a)
      Next B
    Next a
  Close #ff
  '' Tässä jäi ~kesken; katselupiste ja sen suunta.
  HX = 4: HY = 4
  Suunta = 2
End Sub

Sub Liiku ()
' Liikutaan suuntaan <Suunta>.
Dim xm, ym, a
  xm = 0: ym = 0
  Select Case Suunta
    Case 0
      ym = -1
      a = 2
    Case 1
      xm = 1
      a = 3
    Case 2
      ym = 1
      a = 0
    Case 3
      xm = -1
      a = 1
  End Select
  ' Este?
  If (Kentta(HX, HY) And (2 ^ Suunta)) <> 0 Then Exit Sub
  ' Rajan yli?
  If HX + xm < 1 Or HX + xm > MaXX Or HY + ym < 1 Or HY + ym > MaXY Then
    Exit Sub
  End If
  ' ..este toiselta puolelta?
  If (Kentta(HX + xm, HY + ym) And (2 ^ a)) <> 0 Then Exit Sub
  HX = HX + xm: HY = HY + ym
End Sub

Sub Paivita ()
'' Piirtosuuntien & karttojen päivitystä suunnan mukaan.
  Select Case Suunta
    Case 0
      PiirJar(0) = 1: PiirJar(1) = 8
      PiirJar(2) = 2: PiirJar(3) = 4
    Case 1
      PiirJar(0) = 2: PiirJar(1) = 1
      PiirJar(2) = 4: PiirJar(3) = 8
    Case 2
      PiirJar(0) = 4: PiirJar(1) = 2
      PiirJar(2) = 8: PiirJar(3) = 1
    Case 3
      PiirJar(0) = 8: PiirJar(1) = 4
      PiirJar(2) = 1: PiirJar(3) = 2
  End Select
  Kuva.Cls
  MinWin.Cls
  Piirrakentta3D Kuva
  PiirraKenttaMin
End Sub

Sub Piirrakentta3D (MScreen As PictureBox)
'' Kaiken ydin - piirrä näkymä false 3D:nä.
'' Rautalankamalli: ota kommentit pois Line-käskyistä
'' ja kommentoi FillVertical-käsky.
Dim x, y, xx, yy, xm, ym, w, h, a, kx, ky, mw, mh
Dim B, xx2, yy2, mw2, mh2, pala, W2, h2
Dim kier, col As Long
  xm = 0: ym = 0
  col = QBColor(1)
  '' Piirtosuunta
  Select Case Suunta
    Case 0: ym = -1
    Case 1: xm = 1
    Case 2: ym = 1
    Case 3: xm = -1
  End Select
  '' Piirron alkuarvoja; palikoiden leveyksiä ja korkeuksia
  w = MScreen.Width / 16
  h = MScreen.Height / 16
  W2 = w / 2: h2 = h / 2
  kx = w * 8: ky = h * 8
  ' Rivit (takaa eteen)
  For a = Syvyys - 1 To 0 Step -1
    If ym <> 0 Then
      y = HY + (a * ym): x = HX
    Else
      x = HX + (a * xm): y = HY
    End If
    mw = w * (2 ^ (Syvyys - a - 1)): mh = h * (2 ^ (Syvyys - a - 1))
    mw2 = w * (2 ^ (Syvyys - a)): mh2 = h * (2 ^ (Syvyys - a))
    yy = ky - (h2 * (2 ^ (Syvyys - a - 1)))
    yy2 = ky - (h2 * (2 ^ (Syvyys - a)))
    For B = -Maara(a) To Maara(a)
      ' Onko ruutu kentällä?
      If (B + x > 0 And B + x <= MaXX And y > 0 And y <= MaXY And ym <> 0) Or (B + y > 0 And B + y <= MaXY And x > 0 And x <= MaXX And xm <> 0) Then
      ' Kierrä seinät järjestyksessä: taka, vasen, oikea, etu
        xx = kx - (W2 * (2 ^ (Syvyys - a - 1)))
        xx2 = kx - (W2 * (2 ^ (Syvyys - a)))
        If ym < 0 Or xm > 0 Then
          xx = xx + (B * mw)
          xx2 = xx2 + (B * mw2)
        Else
          xx = xx - (B * mw)
          xx2 = xx2 - (B * mw2)
        End If
        '' Piirretään seinät järjestyksessä
        For kier = 0 To 3
          If ym <> 0 Then pala = Kentta(B + x, y) Else pala = Kentta(x, B + y)
          If pala And PiirJar(kier) Then
            Select Case kier
              Case 0 ' takaseinä
                MScreen.Line (xx, yy)-(xx + mw, yy + mh), DepCol(a), BF
              Case 1 ' vasen seinä
'                MScreen.Line (xx, yy)-(xx2, yy2), DepCol(a)
'                MScreen.Line (xx, yy + mh)-(xx2, yy2 + mh2), DepCol(a)
'                MScreen.Line (xx2, yy2)-(xx2, yy2 + mh2), DepCol(a)
'                MScreen.Line (xx, yy)-(xx, yy + mh), DepCol(a)
                FillVertical MScreen, xx, xx2, yy, yy2, mh, DepCol(a)
              Case 2 ' oikea seinä
'                MScreen.Line (xx + mw, yy)-(xx2 + mw2, yy2), DepCol(a)
'                MScreen.Line (xx + mw, yy + mh)-(xx2 + mw2, yy2 + mh2), DepCol(a)
'                MScreen.Line (xx2 + mw2, yy2)-(xx2 + mw2, yy2 + mh2), DepCol(a)
'                MScreen.Line (xx + mw, yy)-(xx + mw, yy + mh), DepCol(a)
                FillVertical MScreen, xx + mw, xx2 + mw2, yy, yy2, mh, DepCol(a)
              Case 3 ' etuseinä
                If a <> 0 Then MScreen.Line (xx2, yy2)-(xx2 + mw2, yy2 + mh2), DepCol(a), BF
            End Select
          End If
        Next
      End If
    Next B
  Next a
End Sub

Sub PiirraKenttaMin ()
'' Minikartta.
Dim w, h, x, y, col As Long
  col = QBColor(1)
  w = MinWin.Width / MaXX
  h = MinWin.Height / MaXY
  MinWin.Cls
  '' Piirretään viiva, jos seinä on olemassa.
  For y = 1 To MaXY: For x = 1 To MaXX
      If Kentta(x, y) And YlaSeina Then MinWin.Line ((x - 1) * w, (y - 1) * h)-(x * w, (y - 1) * h), col
      If Kentta(x, y) And OikeaSeina Then MinWin.Line (x * w, (y - 1) * h)-(x * w, y * h), col
      If Kentta(x, y) And AlaSeina Then MinWin.Line ((x - 1) * w, y * h)-(x * w, y * h), col
      If Kentta(x, y) And VasenSeina Then MinWin.Line ((x - 1) * w, (y - 1) * h)-((x - 1) * w, y * h), col
    Next x
  Next y
  '' Piirrä katselupiste & suunta
  MinWin.Circle ((HX - 1) * w + (w / 2), (HY - 1) * h + (h / 2)), w / 5, col
  Select Case Suunta
    Case 0: MinWin.Circle ((HX - 1) * w + (w / 2), (HY - 1) * h + (h / 2) - 5), 2, col
    Case 1: MinWin.Circle ((HX - 1) * w + (w / 2) + 5, (HY - 1) * h + (h / 2)), 2, col
    Case 2: MinWin.Circle ((HX - 1) * w + (w / 2), (HY - 1) * h + (h / 2) + 5), 2, col
    Case 3: MinWin.Circle ((HX - 1) * w + (w / 2) - 5, (HY - 1) * h + (h / 2)), 2, col
  End Select
End Sub

Sub Command1_Click ()
  LataaKentta app.Path & "\kentta1.txt"
  Paivita
End Sub

Sub Form_Load ()
'' Initiaatiohässäkkä
  ' Perspektiivi...
  Maara(0) = 1: Maara(1) = 2: Maara(2) = 4: Maara(3) = 8
  '' Eri syvyyksien värit; muuttaa saa ja sopii
  DepCol(0) = RGB(128, 128, 128): DepCol(1) = RGB(64, 64, 64)
  DepCol(2) = RGB(32, 32, 32): DepCol(3) = RGB(0, 0, 0)
End Sub

Sub Form_KeyDown (KeyCode As Integer, Shift As Integer)
'' Näppäimet
  Select Case KeyCode
    Case 37
      Suunta = Suunta - 1
      If Suunta < 0 Then Suunta = 3
      Paivita
    Case 39
      Suunta = Suunta + 1
      If Suunta > 3 Then Suunta = 0
      Paivita
    Case 38
      Liiku
      Paivita
  End Select
End Sub