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 ZeroP As Double ' 正負の比率
Private middleV As Double ' 中央初期値
Private arroundV 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, RZ = 1 - ZeroP
Z(L + WW, U) = (Z(L + W, U) + Z(L, U)) * 0.5 + dH * (Rnd() - RZ)
Z(L + WW, U + W) = (Z(L + W, U + W) + Z(L, U + W)) * 0.5 + dH * (Rnd() - RZ)
Z(L, U + WW) = (Z(L, U) + Z(L, U + W)) * 0.5 + dH * (Rnd() - RZ)
Z(L + W, U + WW) = (Z(L + W, U + W) + Z(L + W, U)) * 0.5 + dH * (Rnd() - RZ)
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() - RZ) * 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
Z(j, 0) = arroundV
Z(j, NumY) = arroundV
Next
For j = 0 To NumY
Z(0, j) = arroundV
Z(NumX, 0) = arroundV
Next
Dim DW As Double = NumX, WW As Integer = DW / 2
Z(WW, WW) = middleV
setMap(0, 0, WW, Steep)
setMap(WW, 0, WW, Steep)
setMap(0, WW, WW, Steep)
setMap(WW, WW, WW, 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
If CheckBox1.Checked And Z(j, k) < 0 Then
Z(j, k) = 0
Else
Z(j, k) = Z(j, k) * 100
End If
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
If R < -510 Then Return Color.FromArgb(255, 127, 127)
Return Color.FromArgb(-R / 2, -R / 4, 127)
End If
Return Color.FromArgb(0, R, 177 - R)
End Function
Private Function screenX(X As Double) As Double
Return 20 + X * 2 + 0.5
End Function
Private Function screenY(Y As Double) As Double
Return 450 - Y * 2 + 0.5
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 = screenX(X(i)) : p(i).Y = screenY(Y(i))
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 = screenX(X(i)) : p(i).Y = screenY(Y(i))
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 : ZeroP = 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) : ZeroP = Val(TextBox2.Text)
ColorSV = Val(TextBox3.Text) : middleV = Val(TextBox4.Text)
arroundV = Val(TextBox5.Text)
setData() : hiddenLine()
End Sub
Private Sub Button2_Click(sender As System.Object, e As System.EventArgs) Handles Button2.Click
ColorSV = Val(TextBox3.Text)
hiddenLine()
End Sub
End Class