Public Class Form1
    Private Const NumX = 64
    Private Const NumY = 64
    Private img As New Bitmap(500, 300), gf As Graphics '表示用
    Private PI As Double = 3.14159265358979  ' π
    Private dlx, dx, dy As Double  ' 表示刻み幅、XY軸方向の単位メッシュ幅
    Private alpha, beta As Double   ' X(α)Y(β)軸との水平軸との角度
    Private Xlen, Ylen As Double  '　表示上のXY方向長さ
    Private curX, curY As Double   '　現在ペン位置
    Private dxCosA As Double       ' dx*cos(α)
    Private dyCosB As Double       ' dy*cos(β)
    Private dxSinA As Double       ' dx*sin(α)
    Private dySinB As Double       ' dy*sin(β)
    Private dlxTanA As Double      ' dlx*tan(α)
    Private dlxTanB As Double      ' dlx*tan(β)
    Private Steep As Double        ' 地形の険しさ
    Private ColorSV As Double      ' 色変化度合い
    Private Z(NumX + 1, NumY + 1) As Double '標高値
    Private Function GroundX(j As Integer, k As Integer) As Double ' X0=Y0=0のときのX座標
        Return dxCosA * j - dyCosB * k
    End Function
    Private Function GroundY(j As Integer, k As Integer) As Double '  X0=Y0=0のときのX座標
        Return dxSinA * j + dySinB * k
    End Function
    Private Function DrawPos(j As Integer, k As Integer) As Integer '  表示位置
        Return (0.5 + (Ylen + GroundX(j, k) / dlx))
    End Function
    Private Function setPx(j As Integer, k As Integer, X0 As Double, PH As Double) As Double
        Return PH * dlx + GroundX(j, k) + X0
    End Function
    Private Function setPy(j As Integer, k As Integer, Y0 As Double, PH As Double, fp As Double) As Double
        Return PH * dlxTanA + GroundY(j, k) + fp + Y0
    End Function
    Private Function setPy2(j As Integer, k As Integer, Y0 As Double, PH As Double, fp As Double) As Double ' 
        Return -PH * dlxTanA + GroundY(j, k) + fp + Y0
    End Function
    Private Sub setMap(L As Integer, U As Integer, W As Integer, dH As Double)
        If W < 2 Then Exit Sub
        Dim DW As Double = W, WW As Integer = DW / 2
        Z(L + WW, U) = (Z(L + W, U) + Z(L, U)) * 0.5 + dH * (Rnd() - 0.5)
        Z(L + WW, U + W) = (Z(L + W, U + W) + Z(L, U + W)) * 0.5 + dH * (Rnd() - 0.5)
        Z(L, U + WW) = (Z(L, U) + Z(L, U + W)) * 0.5 + dH * (Rnd() - 0.5)
        Z(L + W, U + WW) = (Z(L + W, U + W) + Z(L + W, U)) * 0.5 + dH * (Rnd() - 0.5)
        Z(L + WW, U + WW) = (Z(L + WW, U) + Z(L + WW, U + W) _
             + Z(L, U + WW) + Z(L + W, U + WW)) * 0.25 + dH * (Rnd() - 0.5) * 0.5
        setMap(L, U, WW, dH * Steep)
        setMap(L + WW, U, WW, dH * Steep)
        setMap(L, U + WW, WW, dH * Steep)
        setMap(L + WW, U + WW, WW, dH * Steep)
    End Sub
    Private Sub setData() 'データを設定
        Dim i As Integer, j As Integer, k As Integer
        For j = 0 To NumX
            For k = 0 To NumY
                Z(j, k) = 0
            Next
        Next
        setMap(0, 0, NumX - 1, Steep)
        For i = 1 To 5
            For k = 1 To NumY - 1
                Z(0, k) = (Z(1, k) + Z(0, k - 1) + Z(0, k + 1) + Z(0, k) * 2) / 5
            Next
            For j = 1 To NumX - 1
                Z(j, 0) = (Z(j - 1, 0) + Z(j + 1, 0) + Z(j, 1) + Z(j, 0) * 2) / 5
                For k = 1 To NumY - 1
                    Z(j, k) = (Z(j - 1, k) + Z(j + 1, k) + Z(j, k - 1) + Z(j, k + 1) + Z(j, k) * 2) / 6
                Next
            Next
        Next
        For j = 0 To NumX
            For k = 0 To NumY
                Z(j, k) = Z(j, k) * 100
            Next
        Next
    End Sub
    Private Function setColor(Z() As Double, N As Double) As Color
        Dim SZ As Double = 0, R As Integer
        For i = 0 To N
            SZ = SZ + Z(i)
        Next
        R = (SZ / (N * 4) + 1.001) * ColorSV * 127
        If R >= 512 Then Return Color.FromArgb(255, 0, 0)
        If (R >= 384) Then Return Color.FromArgb(255, 255 - 2 * (R - 384), 0)
        If (R >= 256) Then Return Color.FromArgb((R - 256) * 2, 255, 0)
        If (R >= 128) Then Return Color.FromArgb(0, R, 0)
        If (R < 0) Then Return Color.FromArgb(0, 0, 177)
        Return Color.FromArgb(0, R, 177 - R)
    End Function
    Private Sub drawTriangle(X() As Double, Y() As Double, CC As Color)
        Dim p(2) As Point, i As Integer
        For i = 0 To 2
            p(i).X = 20 + X(i) * 2 + 0.5
            p(i).Y = 400 - Y(i) * 2 + 0.5
        Next
        gf.FillPolygon(New SolidBrush(CC), p)
    End Sub
    Private Sub drawTetragon(X() As Double, Y() As Double, CC As Color)
        Dim p(3) As Point, i As Integer
        For i = 0 To 3
            p(i).X = 20 + X(i) * 2 + 0.5
            p(i).Y = 400 - Y(i) * 2 + 0.5
        Next
        gf.DrawPolygon(New Pen(CC), p)
    End Sub
    Private Function getZ(j As Integer, k As Integer) As Double
        If Z(j, k) >= -999 Then Return Z(j, k)
        Dim R As Double = 1000, N As Integer = 0, jj As Integer, kk As Integer
        For jj = j - 1 To j + 1 Step 2
            For kk = k - 1 To k + 1 Step 2
                If Z(jj, kk) > -999 And Z(jj, kk) < R Then R = Z(jj, kk)
            Next
        Next
        Return R
    End Function
    Private Sub setSquareXYZ(X0 As Double, Y0 As Double, j As Integer, k As Integer, _
                             AX() As Double, AY() As Double, Z() As Double)
        Dim jj As Integer = j - 1, kk As Integer = k - 1
        Z(0) = getZ(j, k) : Z(1) = getZ(j, kk)
        Z(2) = getZ(jj, kk) : Z(3) = getZ(jj, k)
        AX(0) = setPx(j, k, X0, 0) : AY(0) = setPy(j, k, Y0, 0, Z(0))
        AX(1) = setPx(j, kk, X0, 0) : AY(1) = setPy(j, kk, Y0, 0, Z(1))
        AX(2) = setPx(jj, kk, X0, 0) : AY(2) = setPy(jj, kk, Y0, 0, Z(2))
        AX(3) = setPx(jj, k, X0, 0) : AY(3) = setPy(jj, k, Y0, 0, Z(3))
    End Sub
    Private Sub hiddenLine() '画面の場合、この方法も使える（プロッタでは使えない）
        Cursor.Current = Cursors.WaitCursor
        gf = Graphics.FromImage(img) : gf.Clear(Color.White) '描画クリア
        Dim X0 As Double = 80, Y0 As Double = 100, maxS As Double = 0
        Dim AX(4) As Double, AY(4) As Double, AZ(4) As Double
        For k = NumY - 2 To 1 Step -1 ' 奥方向から四角形を描く
            For j = NumX - 2 To 1 Step -1
                If Z(j, k) > -999 Or Z(j - 1, k) > -999 Or _
                    Z(j, k - 1) > -999 Or Z(j - 1, k - 1) > -999 Then '標高値なしを省く
                    setSquareXYZ(X0, Y0, j, k, AX, AY, AZ)
                    '--------------------------------------------------------
                    ' 三角形に分けて色表示
                    Dim TX(3) As Double, TY(3) As Double, TZ(3) As Double
                    Dim CX As Double = 0, CY As Double = 0, CZ As Double = 0
                    For i = 0 To 3
                        CX = CX + AX(i) : CY = CY + AY(i) : CZ = CZ + AZ(i)
                    Next
                    CX = CX / 4 : CY = CY / 4 : CZ = CZ / 4
                    TX(0) = CX : TY(0) = CY : TZ(0) = CZ
                    Dim IB As Integer = 3
                    For i = 0 To 3
                        TX(1) = AX(IB) : TX(2) = AX(i)
                        TY(1) = AY(IB) : TY(2) = AY(i)
                        TZ(1) = AZ(IB) : TZ(2) = AZ(i)
                        drawTriangle(TX, TY, setColor(TZ, 3)) '三角形塗りつぶし
                        IB = i
                    Next
                    drawTetragon(AX, AY, Color.Black) '四角形枠線描画
                End If
            Next
        Next
        PictureBox1.Image = img : gf.Dispose()
        Cursor.Current = Cursors.Default
    End Sub
    Private Sub initialize()
        dlx = 0.1 : alpha = PI / 12 : beta = PI / 8 : dx = 2 : dy = 1.4
        dxCosA = dx * Math.Cos(alpha) : dyCosB = dy * Math.Cos(beta)
        dxSinA = dx * Math.Sin(alpha) : dySinB = dy * Math.Sin(beta)
        Xlen = (NumX - 1) * dxCosA : Ylen = (NumY - 1) * dyCosB
        dlxTanA = dlx * Math.Tan(alpha) : dlxTanB = dlx * Math.Tan(beta)
        curX = 0 : curY = 0
        Steep = 0.7 : ColorSV = 0.5
    End Sub
    Private Sub Form1_Load(sender As System.Object, e As System.EventArgs) Handles MyBase.Load
        initialize()
        Randomize()
    End Sub
    Private Sub Button1_Click(sender As System.Object, e As System.EventArgs) Handles Button1.Click
        Steep = Val(TextBox1.Text) : ColorSV = Val(TextBox2.Text)
        setData()
        hiddenLine()
    End Sub
    Private Sub Button2_Click(sender As System.Object, e As System.EventArgs) Handles Button2.Click
        ColorSV = Val(TextBox2.Text)
        hiddenLine()
    End Sub
End Class