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