線に沿う玉の運動を描く⑩ 別のアプローチ

chemiphys.hateblo.jp
chemiphys.hateblo.jp

一連の考えを一度捨てました。
波動のシミュレーションを作ったときと同じように考えてみよう。

表示・非表示を制御する。

横方向は等間隔にしたい。じゃあ等間隔にするなら，速さをどう表現しようか。。

うーん。。

等間隔なら時間の短さで速さを示すしかない。正確さを求めているわけではなく，それっぽさを求めているので，大胆に見切るところは見切ろう。

Sleep無しの状況を一瞬と見立て，高さの平方根とSleepの数値を組み合わせてみたらどうだろう。。

こんな感じで，すごい大雑把に考えを組み立てていきました。

曲線の把握については，

①直線で書いてもいいが書くの結構大変だからそれはやめたい。

②色の違いで把握したいが，時間がかかるので，ちょっと後回し。

じゃあ・・と　すごい力業でやりました。

slopeという適当な斜面と　玉数,最低h　という２つのテキストボックスを準備します。形その他は適当に。

こんな感じの動きをします。準備で　必要な玉を描画しておいて，アニメーションで表示・非表示を制御して動かしています。

今回は準備時に当たり判定を用いているだけで，クラスモジュールの良さはあまり活かせてはいません。

とりあえず，作ってみた状態。とりあえず使えはする。

このあとブラッシュアップしないとですね。。

前のより楽だ。

あと，　斜面が途切れた時のことを考えないとイケナイデス。

標準モジュール

Option Explicit
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
Public Const Rate As Currency = 1
Const SID = 1

Sub 準備()
    Dim TSlide As Slide: Set TSlide = ActivePresentation.Slides(SID)
    Dim Ball As Shape
    Dim shpSlope As Shape: Set shpSlope = TSlide.Shapes("slope")
    Dim y0 As Long: y0 = 30
    Dim dx As Long: dx = 10
    Dim dy As Long: dy = 2
    Dim x0 As Long: x0 = 30
    Dim i As Long, j As Long
    Dim ydash As Long
    Dim check As CorrCls: Set check = New CorrCls
    Dim s As Shape
    
    TSlide.Shapes.Range.Visible = msoTrue
    On Error Resume Next
    Do
        For Each s In TSlide.Shapes
            If Left(s.Name, 4) = "Ball" Then s.Delete
        Next
        DoEvents
    Loop Until TSlide.Shapes.Count = 3
    
    On Error GoTo 0
    
    ActivePresentation.SlideShowSettings.Run
    
    i = 1: j = 1
    ydash = y0
    Do
        Set Ball = MakeBall(TSlide, i, 40, vbYellow, x0 + (i - 1) * dx, ydash)
        Do
            check.当たり判定 Ball, shpSlope, False
            If check.bln当たり = True Then Exit Do
            Ball.Top = Ball.Top + dy
            Ball.TextFrame.TextRange = " "
            DoEvents
        Loop Until Ball.Top >= ActivePresentation.SlideMaster.Height
        
        If check.bln当たり = False Then GoTo Flag:
        
        If Ball.Top - 50 > y0 Then ydash = Ball.Top - 50
        
        i = i + 1
        
        If Ball.Top < TSlide.Shapes("ball1").Top And i > 10 Then
Flag:
            Ball.Delete
            Exit Do
        End If
    Loop Until Ball.Left + Ball.Width / 2 >= ActivePresentation.SlideMaster.Width
    

    i = i - 2
    TSlide.Shapes("玉数").TextFrame.TextRange = i
    Dim hmax As Currency, tmpTop As Currency
    For i = 1 To CLng(TSlide.Shapes("玉数").TextFrame.TextRange)
        tmpTop = TSlide.Shapes("ball" & i).Top
        If tmpTop > hmax Then hmax = tmpTop
    Next
    TSlide.Shapes("最低h").TextFrame.TextRange = hmax
    SlideShowWindows(1).View.Exit
End Sub

Function MakeBall(pslide As Slide, id As Long, 直径 As Long, 色 As Long, pX As Long, pY As Long) As Shape
    With pslide.Shapes.AddShape(msoShapeOval, pX, pY, 直径, 直径)
        .Fill.ForeColor.RGB = 色
        .Line.ForeColor.RGB = RGB(0, 0, 0)
        .Line.Weight = 2
        .Name = "Ball" & id
    End With
    Set MakeBall = pslide.Shapes("Ball" & id)
End Function

Sub アニメーション()
    Dim TSlide As Slide: Set TSlide = ActivePresentation.Slides(SID)
    Dim Ball数 As Long: Ball数 = CLng(TSlide.Shapes("玉数").TextFrame.TextRange)
    Dim s As Shape, Keisuu As Currency
    Dim i As Long, di As Long
    Dim hmax As Long: hmax = CLng(TSlide.Shapes("最低h").TextFrame.TextRange)
    
    ActivePresentation.SlideShowSettings.Run
    
    Keisuu = 20
    
    TSlide.Shapes.Range.Visible = msoFalse
    TSlide.Shapes("slope").Visible = msoTrue
    TSlide.Shapes("玉数").Visible = msoTrue
    TSlide.Shapes("最低h").Visible = msoTrue
    DoEvents
    i = 1
    di = 1
    Do
        TSlide.Shapes("ball" & i).Visible = msoTrue
        TSlide.Shapes("slope").TextFrame.TextRange = " "
        
        Sleep CLng(Sqr((hmax - TSlide.Shapes("ball" & i).Top) * Keisuu) + 1)
        
        DoEvents
        TSlide.Shapes("ball" & i).Visible = msoFalse
        i = i + di
        
        If i = Ball数 Then
            If TSlide.Shapes("ball1").Top + 10 < TSlide.Shapes("ball" & i).Top Then Exit Do
        End If
        If i = Ball数 Then di = di * (-1)
        If i = 0 Then di = 1: i = 1
    Loop
    
    SlideShowWindows(1).View.Exit
End Sub

Corr.Cls.cls

Option Explicit
Const PI As Currency = 3.1415
Private pAngle As Currency
Private pAngleCol As Currency
Private pDist As Currency
Private pDistCol As Currency
Private pblnColl As Boolean
Property Get bln当たり() As Boolean
    bln当たり = pblnColl
End Property
Property Get 角度() As Currency
    角度 = pAngle
End Property

Property Get 距離() As Currency
    距離 = pDist
End Property

Property Get 重なり距離() As Currency
    重なり距離 = pDistCol
End Property

Public Sub 当たり判定(sShp As Shape, tShp As Shape, blnMove As Boolean)
    Dim pslide As Slide: Set pslide = ActivePresentation.Slides(sShp.Parent.SlideIndex)
    Dim lngShpNo As Long: lngShpNo = pslide.Shapes.Count
    
    pslide.Shapes.Range(Array(sShp.Name, tShp.Name)).Duplicate.MergeShapes msoMergeIntersect
    
    Dim sS As ShpCls: Set sS = New ShpCls: sS.SetShp sShp
    Dim tS As ShpCls: Set tS = New ShpCls: tS.SetShp tShp
    
    pAngle = Angle(tS.X - sS.X, tS.Y - sS.Y)
    pDist = Sqr((tS.X - sS.X) ^ 2 + (tS.Y - sS.Y) ^ 2)

    If pslide.Shapes.Count = lngShpNo Then
        pblnColl = False
        Exit Sub
    End If
    
    pblnColl = True
    Dim dS As ShpCls: Set dS = New ShpCls: dS.SetShp pslide.Shapes(pslide.Shapes.Count)
    dS.X = dS.X - 12: dS.Y = dS.Y - 12 'Duplicateのずれの訂正
        
'    With pslide.Shapes.AddLine(sS.X, sS.Y, dS.X, dS.Y)
'        .Line.ForeColor.RGB = vbBlue
'    End With

    pDistCol = Sqr((dS.X - sS.X) ^ 2 + (dS.Y - sS.Y) ^ 2)
    'pslide.Shapes.AddShape(msoShapeOval, dS.X, dS.Y, 10, 10).Fill.ForeColor.RGB = vbRed
        
    If blnMove = True Then
        sS.X = dS.X + (sS.Width / 2 - pDistCol) * Cos(pAngle)
        sS.Y = dS.Y - (sS.Width / 2 - pDistCol) * Sin(pAngle)
    End If

    dS.Delete
End Sub

Function Angle(X As Currency, Y As Currency)
    Dim pHosei As Currency
    If Abs(X) < 0.01 Then
        If Y > 0 Then
            Angle = PI / 2
        ElseIf Y < 0 Then
            Angle = -PI / 2
        Else
            Angle = 0 '(;´▽｀A``
        End If
    Else
        If X > 0 Then
            If Y >= 0 Then pHosei = 0 Else pHosei = 2 * PI
        Else
            If Y >= 0 Then pHosei = PI Else pHosei = PI
        End If
        Angle = Atn(Y / X)
    End If
    Angle = Angle + pHosei
End Function

ShpCls.Cls

Option Explicit
Const PI = 3.1415
Private pShp As Shape
Private pV As Currency
Private pVAngle As Currency
Private pA As Currency
Private pAAngle As Currency

Public Sub SetShp(図形 As Shape)
    Set pShp = 図形
End Sub

Property Get X() As Currency
    X = pShp.Left + pShp.Width / 2
End Property
Property Let X(X座標 As Currency)
    pShp.Left = X座標 - pShp.Width / 2
End Property

Property Get Y() As Currency
    Y = pShp.Top + pShp.Height / 2
End Property
Property Let Y(Y座標 As Currency)
    pShp.Top = Y座標 - pShp.Height / 2
End Property

Property Get Left() As Currency
    Left = pShp.Left
End Property
Property Let Left(pLeft As Currency)
    pShp.Left = pLeft
End Property

Property Get Right() As Currency
    Right = pShp.Left + pShp.Width
End Property
Property Let Right(pRight As Currency)
    pShp.Left = pRight - pShp.Width
End Property

Property Get Top() As Currency
    Top = pShp.Top
End Property
Property Let Top(pTop As Currency)
    pShp.Top = pTop
End Property

Property Get Bottom() As Currency
    Bottom = pShp.Top + pShp.Height
End Property
Property Let Bottom(pBottom As Currency)
    pShp.Top = pBottom - pShp.Height
End Property
Property Get Width() As Currency
    Width = pShp.Width
End Property
Property Let Width(pWidth As Currency)
    pShp.Width = pWidth
End Property

Property Get Height() As Currency
    Height = pShp.Height
End Property
Property Let Height(pHeight As Currency)
    pShp.Height = pHeight
End Property
Public Sub Delete()
    pShp.Delete
End Sub

Property Get 速度角度() As Currency
    速度角度 = pVAngle
End Property
Public Sub SetV(速度 As Currency, 速度角度 As Currency)
    pV = 速度
    pVAngle = 速度角度
End Sub

Public Sub SetA(加速度 As Currency, 加速度角度 As Currency)
    pA = 加速度
    pAAngle = 加速度角度
End Sub

Public Sub Move()
    Me.X = Me.X + pV * Cos(pVAngle)
    Me.Y = Me.Y + pV * Sin(pVAngle)
    pV = Sqr((pV * Cos(pVAngle) + pA * Cos(pAAngle)) ^ 2 + (pV * Sin(pVAngle) + pA * Sin(pAAngle)) ^ 2)
    pVAngle = Angle(pV * Cos(pVAngle) + pA * Cos(pAAngle), pV * Sin(pVAngle) + pA * Sin(pAAngle))
    
End Sub

Function Angle(X As Currency, Y As Currency)
    Dim pHosei As Currency
    If Abs(X) < 0.001 Then
        If Y > 0 Then
            Angle = PI / 2
        ElseIf Y < 0 Then
            Angle = -PI / 2
        Else
            Angle = PI / 2 '(;´▽｀A``
        End If
    Else
        If X > 0 Then
            If Y >= 0 Then pHosei = 0 Else pHosei = 2 * PI
        Else
            If Y >= 0 Then pHosei = PI Else pHosei = PI
        End If
        Angle = Atn(Y / X)
    End If
    Angle = Angle + pHosei
End Function