My地球儀(その３)

ソースコードの続き。

---

    'Fit the image size
    Private Function reSizeImage(ByRef hr As Integer, ByRef wr As Integer, ByRef limage As Image)

        Dim NewRect As Rectangle
        Dim r As Double = S / hr
        Dim Quality As Drawing2D.InterpolationMode = Drawing2D.InterpolationMode.HighQualityBicubic
        NewRect.Width = CInt(limage.Size.Width * r)
        NewRect.Height = CInt(limage.Size.Height * r)
        Dim Dimage As New Bitmap(NewRect.Width, NewRect.Height)
        Dim g As Graphics = Graphics.FromImage(Dimage)
        g.InterpolationMode = Quality
        g.DrawImage(limage, NewRect)
        limage = Dimage
        hr = limage.Size.Height
        wr = limage.Size.Width
        Return {hr, wr, limage}

    End Function

    Private Sub PictureBox2_MouseDown(sender As Object, e As MouseEventArgs) Handles PictureBox2.MouseDown

        mb2 = True

    End Sub

    Private Sub PictureBox2_MouseUp(sender As Object, e As MouseEventArgs) Handles PictureBox2.MouseUp

        mb = False
        mb2 = False

    End Sub

    Private Sub TextBox1_TextChanged(sender As Object, e As EventArgs) Handles TextBox1.TextChanged

        URL = TextBox1.Text
        DN = DN + 1
        IloadFileName = "Download" & DN.ToString & ".jpg"
        GC.Collect()

    End Sub

    Private Sub TextBox2_TextChanged(sender As Object, e As EventArgs) Handles TextBox2.TextChanged

        URL2 = TextBox2.Text
        DN2 = DN2 + 1
        IloadFileName2 = "Download2" & DN2.ToString & ".jpg"
        GC.Collect()

    End Sub

End Class

---

おしまい。 

My地球儀(その２)

ソースコードの続き。

---

'Matrix for transformation from flat to sphere

    Private Sub transMat()

        Dim f As Double
        Dim ch As Integer

        For i As Integer = 0 To H - 1
            y(i) = H / Math.PI * Math.Acos(1 - 2 * i / H)
            For j As Integer = 0 To H - 1
                x(j, i) = H + 1
                ch = Math.Sqrt((i - H / 2) * (i - H / 2) + (j - H / 2) * (j - H / 2))
                If ch < H / 2 Then
                    f = (1 - 2 * j / H) / Math.Sin(y(i) * Math.PI / H)
                    If f > 0.99 Then f = 0.99
                    If f < -1 Then f = -1
                    x(j, i) = H / Math.PI * Math.Acos(f)
                End If
            Next
        Next

    End Sub

    'Image of sphere
    Private Sub Sphere()

        Dim canvas1 As New Bitmap(W, H)
        Dim canvas2 As New Bitmap(H, H)
        canvas1 = mixImage
        Dim xt As Integer
        Dim c As Color
        Dim kk As Integer
        kk = keido / 360 * W

        For i As Integer = 0 To H - 1
            For j As Integer = 0 To H - 1
                If x(j, i) >= 0 And x(j, i) Then
                    xt = x(j, i) - kk
                    If xt < 0 Then xt = xt + W
                    c = canvas1.GetPixel(xt, y(i))
                Else
                    c = Color.Black
                End If
                canvas2.SetPixel(j, i, c)
            Next
        Next

        PictureBox2.Image = canvas2

    End Sub

    'Map of shadow(Day & Night)
    Private Sub shadow()

        Dim aSeason As Double
        Dim pSeason As Double
        Dim sTime As Double
        Dim yDay(W - 1) As Integer
        Dim canvas1 As New Bitmap(W, H)
        Dim canvas2 As New Bitmap(W, H)
        Dim canvas3 As New Bitmap(W, H)

        canvas1 = LoadImage
        canvas2 = LoadImage2
        pSeason = TextBox3.Text
        aSeason = Math.Tan((90 - 23.4 * Math.Sin(pSeason)) / 180 * Math.PI)
        sTime = TextBox6.Text
        sTime = sTime * 360

        For j As Integer = 0 To W - 1
            yDay(j) = Math.Atan(aSeason * Math.Cos((j / W * 360 + sTime - 180) / 180 * Math.PI)) / Math.PI * H + H / 2
        Next

        Dim c As Color
        Dim c1 As Color
        Dim c2 As Color
        Dim cR As Byte
        Dim cG As Byte
        Dim cB As Byte
        Dim cA As Byte
        Dim jkk As Integer
        Dim ikk As Integer
        Dim DorN(W - 1, H - 1) As Integer ' 1 = Day , 0 = Night
        Dim Dsum As Integer
        Dim Eve As Integer = W / 24 * 2
        Dim Eve2 As Integer

        For j As Integer = 0 To W - 1
            For i As Integer = 0 To H - 1
                c1 = canvas1.GetPixel(j, i)
                c2 = canvas2.GetPixel(j, i)
                If pSeason < Math.PI Then
                    If i > yDay(j) Then
                        DorN(j, i) = 1
                        c = c1
                    Else
                        DorN(j, i) = 0
                        c = c2
                    End If
                Else
                    If i > yDay(j) Then
                        DorN(j, i) = 0
                        c = c2
                    Else
                        DorN(j, i) = 1
                        c = c1
                    End If

                End If
                canvas3.SetPixel(j, i, c)
            Next
        Next

        For j As Integer = 0 To W - 1
            For i As Integer = 0 To H - 1
                c1 = canvas1.GetPixel(j, i)
                c2 = canvas2.GetPixel(j, i)
                Dsum = 0
                For jk As Integer = 0 To Eve
                    For ik As Integer = 0 To Eve
                        jkk = j + jk - Eve / 2
                        If jkk < 0 Then jkk = jkk + W
                        If jkk > W - 1 Then jkk = jkk - W
                        ikk = i + ik - Eve / 2
                        If ikk < 0 Then
                            ikk = -ikk
                            jkk = jkk + W / 2
                        End If
                        If ikk > H - 1 Then
                            ikk = (H - 1) + (H - 1 - ikk)
                            jkk = jkk + W / 2
                        End If
                        If jkk > W - 1 Then jkk = jkk - W
                        Dsum = Dsum + DorN(jkk, ikk)
                    Next
                Next
                Eve2 = (Eve + 1) * (Eve + 1)
                If Dsum > 0 And Dsum < Eve2 Then
                    cR = c2.R / Eve2 * (Eve2 - Dsum) + c1.R / Eve2 * Dsum
                    cG = c2.G / Eve2 * (Eve2 - Dsum) + c1.G / Eve2 * Dsum
                    cB = c2.B / Eve2 * (Eve2 - Dsum) + c1.B / Eve2 * Dsum
                    cA = c2.A / Eve2 * (Eve2 - Dsum) + c1.A / Eve2 * Dsum
                    c = Color.FromArgb(cA, cR, cG, cB)
                    canvas3.SetPixel(j, i, c)
                End If
            Next
        Next

        PictureBox4.SizeMode = PictureBoxSizeMode.StretchImage
        mixImage = canvas3
        PictureBox4.Image = mixImage

    End Sub
 

---

My地球儀

パパの夏休みの自由研究です。
先日、顔認識アプリを作った勢いで
今度は地球儀アプリです。

「おい、製図の練習をしろ！」

という声も天から聞こえてきますが、
やはり夏休みだから．．．

こういうのはハマって凝りだすときりがない。
建築課題のときも同じでしたが。

平面地図を球体に貼り付ける部分と
朝晩の2種類の画像を明暗境界線で合成する部分が
メインです。

画像はNASAの"BlueMarble"というプロジェクトから
引用させて頂き．．．

http://earthobservatory.nasa.gov/Features/BlueMarble/

いい頭の体操になりました^^;
（「何の役に立つのか？」という突っ込みは妻だけで十分）

平面地図における季節ごとの明暗境界線の変化が面白いです。
子どもにも興味を持って貰えました。



備忘録で算数の式。



ソースも少し。

---

Public Class Form2

    Dim LoadImage As Image
    Dim LoadImage2 As Image
    Dim mixImage As Image
    Dim statusMouse As Boolean = True
    Dim x(,) As Integer
    Dim y() As Integer
    Dim H As Integer
    Dim W As Integer
    Dim H2 As Integer
    Dim W2 As Integer
    Dim S As Integer = 350
    Dim mb As Boolean = False
    Dim mb2 As Boolean = False
    Dim mx As Integer
    Dim xl As Integer
    Dim dx As Double
    Dim keido As Double = 0
    Dim DN As Integer = 0
    Dim DN2 As Integer = 0
    Dim Internet As Net.WebClient = New Net.WebClient()
    Dim URL As String = "http://eoimages.gsfc.nasa.gov/images/imagerecords/73000/73801/world.topo.bathy.200409.3x5400x2700.jpg"
    Dim URL2 As String = "http://eoimages.gsfc.nasa.gov/images/imagerecords/55000/55167/earth_lights_lrg.jpg"
    Dim URL3 As String = "http://earthobservatory.nasa.gov/Features/BlueMarble/"
    Dim LoadFileName As String
    Dim IloadFileName As String = "Download1.jpg"
    Dim LoadFileName2 As String
    Dim IloadFileName2 As String = "Download2.jpg"
    Dim titleName As String = "perspectives from Blue Marble - NASA Earth Observatory"
    Dim pUTC As Integer = 9

    Private Sub Form2_Load(sender As Object, e As EventArgs) Handles MyBase.Load

        TextBox1.Text = URL
        TextBox2.Text = URL2
        TextBox3.Text = 1.57
        TextBox4.Text = Now.Date
        TextBox5.Text = Now.TimeOfDay.ToString
        TextBox7.Text = pUTC.ToString
        Label1.Text = "Position = " & mx
        Label2.Text = "delta = " & dx
        Label5.Text = "keido = " & keido
        Label3.Text = titleName
        Label4.Text = URL3
        Label11.Text = Now

    End Sub

    '"Load" button
    Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click

        Internet.DownloadFile(URL, IloadFileName)
        LoadFileName = IloadFileName
        LoadImage = Image.FromFile(LoadFileName)
        PictureBox1.SizeMode = PictureBoxSizeMode.StretchImage
        H = LoadImage.Height
        W = LoadImage.Width

        Internet.DownloadFile(URL2, IloadFileName2)
        LoadFileName2 = iloadFileName2
        LoadImage2 = Image.FromFile(LoadFileName2)
        PictureBox3.SizeMode = PictureBoxSizeMode.StretchImage
        H2 = LoadImage2.Height
        W2 = LoadImage2.Width

        If H > S Then reSizeImage(H, W, LoadImage)
        If H2 > S Then reSizeImage(H2, W2, LoadImage2)

        PictureBox1.Image = LoadImage
        PictureBox3.Image = LoadImage2
        mixImage = LoadImage
        PictureBox4.SizeMode = PictureBoxSizeMode.StretchImage
        PictureBox4.Image = mixImage

        PictureBox2.SizeMode = PictureBoxSizeMode.StretchImage
        ReDim y(H - 1)
        ReDim x(H - 1, H - 1)

        For i As Integer = 0 To H - 1
            y(i) = 0
            For j As Integer = 0 To H - 1
                x(i, j) = 0
            Next
        Next

        Dim pm As Point
        pm = System.Windows.Forms.Cursor.Position

        transMat()
        Sphere()
        Timer1.Start()
        Timer1.Interval = 100

    End Sub

    '"Marble" button
    Private Sub Button3_Click(sender As Object, e As EventArgs) Handles Button3.Click

        Dim pSeason As Double
        Dim pDate As Date
        Dim sDate As Integer
        pDate = TextBox4.Text
        sDate = pDate.DayOfYear
        pSeason = (sDate / 365.25 - 0.72) * 2 * Math.PI
        If pSeason < 0 Then pSeason = pSeason + 2 * Math.PI
        TextBox3.Text = pSeason

        Dim pTime As Date
        Dim sHur As Integer
        Dim sMin As Integer
        Dim sSec As Integer
        Dim sTime As Double

        pTime = TextBox5.Text
        sHur = pTime.Hour
        If sHur < pUTC Then sHur = sHur - pUTC Else sHur = sHur + (24 - pUTC)
        sMin = pTime.Minute
        sSec = pTime.Second
        sTime = (sHur * 3600 + sMin * 60 + sSec) / 24 / 3600
        TextBox6.Text = sTime.ToString

        shadow()
        Timer2.Start()
        Timer2.Interval = 300000

    End Sub

    '"Now" button
    Private Sub Button4_Click(sender As Object, e As EventArgs) Handles Button4.Click

        TextBox4.Text = Now.Date
        TextBox5.Text = Now.TimeOfDay.ToString

    End Sub

    'Rotate the earth
    Private Sub Timer1_Tick(sender As Object, e As EventArgs) Handles Timer1.Tick

        keido = keido + 1
        xl = mx

        If mb2 = True Then
            mx = System.Windows.Forms.Cursor.Position.X
            If mb = False Then
                xl = mx
                mb = True
            End If
        End If

        dx = mx - xl
        If Math.Abs(dx) > 360 Then dx = 0
        keido = keido + dx

        If keido < 0 Then keido = keido + 360
        If keido >= 360 Then keido = keido - 360

        Label1.Text = "Position = " & mx
        Label2.Text = "delta = " & dx
        Label5.Text = "keido = " & keido
        Label11.Text = Now

        Sphere()

    End Sub

    'Update shadow every 5 minutes
    Private Sub Timer2_Tick(sender As Object, e As EventArgs) Handles Timer2.Tick

        TextBox4.Text = Now.Date
        TextBox5.Text = Now.TimeOfDay.ToString
        shadow()

    End Sub

(続きは次記事へ）

---

明日からは製図に集中します！