Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH14/SRC/FOLD.FRM

Visual Basic Form | 1996-05-02 | 14.7 KB | 476 lines

VERSION 4.00
Begin VB.Form FoldForm
   Appearance      =   0  'Flat
   BackColor       =   &H00C0C0C0&
   Caption         =   "Fold"
   ClientHeight    =   5310
   ClientLeft      =   1380
   ClientTop       =   1035
   ClientWidth     =   6870
   BeginProperty Font
      name            =   "MS Sans Serif"
      charset         =   1
      weight          =   700
      size            =   8.25
      underline       =   0   'False
      italic          =   0   'False
      strikethrough   =   0   'False
   EndProperty
   ForeColor       =   &H80000008&
   Height          =   6000
   KeyPreview      =   -1  'True
   Left            =   1320
   LinkTopic       =   "Form1"
   ScaleHeight     =   5310
   ScaleWidth      =   6870
   Top             =   405
   Width           =   6990
   Begin VB.TextBox FPSText
      Height          =   285
      Left            =   6480
      TabIndex        =   11
      Text            =   "10"
      Top             =   2040
      Width           =   375
   End
   Begin VB.CommandButton CmdGo
      Caption         =   "Go"
      Default         =   -1  'True
      Height          =   495
      Left            =   5640
      TabIndex        =   10
      Top             =   2520
      Width           =   975
   End
   Begin VB.TextBox DText
      Height          =   285
      Left            =   6000
      TabIndex        =   9
      Text            =   "5"
      Top             =   0
      Width           =   735
   End
   Begin VB.Frame Frame1
      Caption         =   "Post-Rotations"
      Height          =   1335
      Index           =   1
      Left            =   5400
      TabIndex        =   1
      Top             =   480
      Width           =   1455
      Begin VB.TextBox ZW2Text
         Height          =   285
         Left            =   600
         MaxLength       =   6
         TabIndex        =   4
         Text            =   "0.0"
         Top             =   960
         Width           =   735
      End
      Begin VB.TextBox YW2Text
         Height          =   285
         Left            =   600
         MaxLength       =   6
         TabIndex        =   3
         Text            =   "0.1"
         Top             =   600
         Width           =   735
      End
      Begin VB.TextBox XW2Text
         Height          =   285
         Left            =   600
         MaxLength       =   6
         TabIndex        =   2
         Text            =   "0.2"
         Top             =   240
         Width           =   735
      End
      Begin VB.Label Label1
         Caption         =   "Z"
         Height          =   255
         Index           =   11
         Left            =   240
         TabIndex        =   7
         Top             =   960
         Width           =   255
      End
      Begin VB.Label Label1
         Caption         =   "Y"
         Height          =   255
         Index           =   10
         Left            =   240
         TabIndex        =   6
         Top             =   600
         Width           =   255
      End
      Begin VB.Label Label1
         Caption         =   "X"
         Height          =   255
         Index           =   9
         Left            =   240
         TabIndex        =   5
         Top             =   240
         Width           =   255
      End
   End
   Begin VB.PictureBox Pict
      AutoRedraw      =   -1  'True
      Height          =   5295
      Left            =   0
      ScaleHeight     =   349
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   349
      TabIndex        =   0
      Top             =   0
      Width           =   5295
   End
   Begin VB.Label Label1
      Caption         =   "Frames/Sec"
      Height          =   255
      Index           =   0
      Left            =   5400
      TabIndex        =   12
      Top             =   2040
      Width           =   1095
   End
   Begin VB.Label Label1
      Caption         =   "D"
      Height          =   255
      Index           =   12
      Left            =   5640
      TabIndex        =   8
      Top             =   0
      Width           =   255
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
Attribute VB_Name = "FoldForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
' Location of focus point.
Const FocusX = 0#
Const FocusY = 0#
Const FocusZ = 0#
Dim ThePicture As ObjPicture
Dim TheCubes(1 To 8) As ObjPicture
Dim Running As Boolean
Dim Projector(1 To 5, 1 To 5) As Single
' ************************************************
' Animate the picture.
' ************************************************
Private Sub Animate()
Dim xw2_rot As Single
Dim yw2_rot As Single
Dim zw2_rot As Single
Dim XW2(1 To 5, 1 To 5) As Single
Dim YW2(1 To 5, 1 To 5) As Single
Dim ZW2(1 To 5, 1 To 5) As Single
Dim S(1 To 5, 1 To 5) As Single
Dim T(1 To 5, 1 To 5) As Single
Dim P(1 To 5, 1 To 5) As Single
Dim M12(1 To 5, 1 To 5) As Single
Dim M34(1 To 5, 1 To 5) As Single
Dim M1_4(1 To 5, 1 To 5) As Single
Dim M56(1 To 5, 1 To 5) As Single
Dim D As Single
Dim ms_per_frame As Long
Dim cube12 As ObjPicture
    If Not IsNumeric(XW2Text.Text) Then Exit Sub
    If Not IsNumeric(YW2Text.Text) Then Exit Sub
    If Not IsNumeric(ZW2Text.Text) Then Exit Sub
    If Not IsNumeric(DText.Text) Then Exit Sub
    If Not IsNumeric(FPSText) Then Exit Sub
    xw2_rot = CSng(XW2Text.Text)
    yw2_rot = CSng(YW2Text.Text)
    zw2_rot = CSng(ZW2Text.Text)
    D = CSng(DText.Text)
    ms_per_frame = 1000 / CLng(FPSText)
    ' Create fresh data.
    CreateData
    ' Calculate the matrices.
    m4XWRotate XW2, xw2_rot
    m4YWRotate YW2, yw2_rot
    m4ZWRotate ZW2, zw2_rot
    m4PerspectiveW P, D
    m4Scale S, 25, -25, 1, 1
    m4Translate T, Pict.ScaleWidth * 0.75, Pict.ScaleHeight / 2, 0, 0
    m4MatMultiplyFull M12, P, XW2
    m4MatMultiply M34, YW2, ZW2
    m4MatMultiplyFull M1_4, M12, M34
    m4MatMultiply M56, S, T
    m4MatMultiplyFull Projector, M1_4, M56
    ' Present the original image.
    If Not Running Then Exit Sub
    ThePicture.ApplyFull Projector
    Pict.Cls
    ThePicture.Draw Pict
    DoEvents
    ' Fold up cube 5.
    FoldYW ms_per_frame, TheCubes(5), 1, 0, PI / 2
    If Not Running Then Exit Sub
    ' Fold up cube 6.
    FoldZW ms_per_frame, TheCubes(6), -1, 0, -PI / 2
    If Not Running Then Exit Sub
    ' Fold up cube 4.
    FoldXW ms_per_frame, TheCubes(4), 1, 0, PI / 2
    If Not Running Then Exit Sub
    ' Fold up cube 7.
    FoldYW ms_per_frame, TheCubes(7), -1, 0, -PI / 2
    If Not Running Then Exit Sub
    ' Fold up cube 8.
    FoldZW ms_per_frame, TheCubes(8), 1, 0, PI / 2
    If Not Running Then Exit Sub
    ' Fold up cubes 2 and 1 together.
    Set cube12 = New ObjPicture
    cube12.objects.Add TheCubes(2)
    cube12.objects.Add TheCubes(1)
    FoldXW ms_per_frame, cube12, -1, 0, -PI / 2
    If Not Running Then Exit Sub
    ' Finish folding cube 1.
    FoldXW ms_per_frame, TheCubes(1), -1, 2, -PI / 2
    If Not Running Then Exit Sub
End Sub
' ************************************************
' Animate folding this cube across the X = x,
' W = w plane.
' ************************************************
Sub FoldXW(ms_per_frame As Long, cube As ObjPicture, x As Single, w As Single, theta As Single)
Const NUM_FRAMES = 20
Dim i As Single
Dim next_time As Long
Dim T1(1 To 5, 1 To 5) As Single
Dim R(1 To 5, 1 To 5) As Single
Dim T2(1 To 5, 1 To 5) As Single
Dim T1R(1 To 5, 1 To 5) As Single
Dim All(1 To 5, 1 To 5) As Single
    next_time = GetTickCount + ms_per_frame
    ' Create the transformation matrices.
    m4Translate T1, -x, 0, 0, -w
    m4Translate T2, x, 0, 0, w
    m4YZRotate R, theta / NUM_FRAMES
    m4MatMultiply T1R, T1, R
    m4MatMultiply All, T1R, T2
    For i = 1 To NUM_FRAMES
        If Not Running Then Exit Sub

        ' Rotate the cube.
        cube.Apply All
        cube.FixPoints

        ' Wait until it's time for the next image.
        WaitTill next_time
        next_time = GetTickCount + ms_per_frame
        ' Display the picture.
        ThePicture.ApplyFull Projector
        Pict.Cls
        ThePicture.Draw Pict
        DoEvents
    Next i
End Sub
' ************************************************
' Animate folding this cube across the Y = y,
' W = w plane.
' ************************************************
Sub FoldYW(ms_per_frame As Long, cube As ObjPicture, y As Single, w As Single, theta As Single)
Const NUM_FRAMES = 20
Dim i As Single
Dim next_time As Long
Dim T1(1 To 5, 1 To 5) As Single
Dim R(1 To 5, 1 To 5) As Single
Dim T2(1 To 5, 1 To 5) As Single
Dim T1R(1 To 5, 1 To 5) As Single
Dim All(1 To 5, 1 To 5) As Single
    next_time = GetTickCount + ms_per_frame
    ' Create the transformation matrices.
    m4Translate T1, 0, -y, 0, -w
    m4Translate T2, 0, y, 0, w
    m4XZRotate R, theta / NUM_FRAMES
    m4MatMultiply T1R, T1, R
    m4MatMultiply All, T1R, T2
    For i = 1 To NUM_FRAMES
        If Not Running Then Exit Sub

        ' Rotate the cube.
        cube.Apply All
        cube.FixPoints

        ' Wait until it's time for the next image.
        WaitTill next_time
        next_time = GetTickCount + ms_per_frame
        ' Display the picture.
        ThePicture.ApplyFull Projector
        Pict.Cls
        ThePicture.Draw Pict
        DoEvents
    Next i
End Sub
' ************************************************
' Animate folding this cube across the Z = z,
' W = w plane.
' ************************************************
Sub FoldZW(ms_per_frame As Long, cube As ObjPicture, z As Single, w As Single, theta As Single)
Const NUM_FRAMES = 20
Dim i As Single
Dim next_time As Long
Dim T1(1 To 5, 1 To 5) As Single
Dim R(1 To 5, 1 To 5) As Single
Dim T2(1 To 5, 1 To 5) As Single
Dim T1R(1 To 5, 1 To 5) As Single
Dim All(1 To 5, 1 To 5) As Single
    next_time = GetTickCount + ms_per_frame
    ' Create the transformation matrices.
    m4Translate T1, 0, 0, -z, -w
    m4Translate T2, 0, 0, z, w
    m4XYRotate R, theta / NUM_FRAMES
    m4MatMultiply T1R, T1, R
    m4MatMultiply All, T1R, T2
    For i = 1 To NUM_FRAMES
        If Not Running Then Exit Sub

        ' Rotate the cube.
        cube.Apply All
        cube.FixPoints

        ' Wait until it's time for the next image.
        WaitTill next_time
        next_time = GetTickCount + ms_per_frame
        ' Display the picture.
        ThePicture.ApplyFull Projector
        Pict.Cls
        ThePicture.Draw Pict
        DoEvents
    Next i
End Sub
' ************************************************
' Create a cube with the indicated minimum
' coordinates. W = 0 for all points.
' ************************************************
Sub CreateCube(cube As ObjPicture, xmin As Single, ymin As Single, zmin As Single)
Dim pline As ObjPolyline4D
Dim x As Single
Dim y As Single
Dim z As Single
    Set cube = New ObjPicture
    ThePicture.objects.Add cube
    Set pline = New ObjPolyline4D
    cube.objects.Add pline
    For x = xmin To xmin + 2 Step 2
        For y = ymin To ymin + 2 Step 2
            For z = zmin To zmin + 2 Step 2
                If x = xmin Then _
                    pline.AddSegment _
                        x, y, z, 0, _
                        x + 2, y, z, 0
                If y = ymin Then _
                    pline.AddSegment _
                        x, y, z, 0, _
                        x, y + 2, z, 0
                If z = zmin Then _
                    pline.AddSegment _
                        x, y, z, 0, _
                        x, y, z + 2, 0
            Next z
        Next y
    Next x
End Sub
' ************************************************
' Display the data as it currently is.
' ************************************************
Sub DrawData()
Dim xw2_rot As Single
Dim yw2_rot As Single
Dim zw2_rot As Single
Dim XW2(1 To 5, 1 To 5) As Single
Dim YW2(1 To 5, 1 To 5) As Single
Dim ZW2(1 To 5, 1 To 5) As Single
Dim S(1 To 5, 1 To 5) As Single
Dim T(1 To 5, 1 To 5) As Single
Dim P(1 To 5, 1 To 5) As Single
Dim M12(1 To 5, 1 To 5) As Single
Dim M34(1 To 5, 1 To 5) As Single
Dim M1_4(1 To 5, 1 To 5) As Single
Dim M56(1 To 5, 1 To 5) As Single
Dim D As Single
    If Not IsNumeric(XW2Text.Text) Then Exit Sub
    If Not IsNumeric(YW2Text.Text) Then Exit Sub
    If Not IsNumeric(ZW2Text.Text) Then Exit Sub
    If Not IsNumeric(DText.Text) Then Exit Sub
    xw2_rot = CSng(XW2Text.Text)
    yw2_rot = CSng(YW2Text.Text)
    zw2_rot = CSng(ZW2Text.Text)
    D = CSng(DText.Text)
    ' Calculate the matrices.
    m4XWRotate XW2, xw2_rot
    m4YWRotate YW2, yw2_rot
    m4ZWRotate ZW2, zw2_rot
    m4PerspectiveW P, D
    m4Scale S, 25, -25, 1, 1
    m4Translate T, Pict.ScaleWidth * 0.75, Pict.ScaleHeight / 2, 0, 0
    m4MatMultiplyFull M12, P, XW2
    m4MatMultiply M34, YW2, ZW2
    m4MatMultiplyFull M1_4, M12, M34
    m4MatMultiply M56, S, T
    m4MatMultiplyFull Projector, M1_4, M56
    ThePicture.ApplyFull Projector
    Pict.Cls
    ThePicture.Draw Pict
End Sub
Private Sub CmdGo_Click()
    If Running Then
        CmdGo.Caption = "Stopped"
        CmdGo.Enabled = False
        Running = False
    Else
        CmdGo.Caption = "Stop"
        Running = True
        Animate
        CmdGo.Enabled = True
        CmdGo.Caption = "Go"
        Running = False
    End If
End Sub
Private Sub DText_Change()
    DrawData
End Sub
Private Sub Form_Load()
    ' Create the data.
    CreateData
End Sub
' ************************************************
' Create the initial cubes.
' ************************************************
Sub CreateData()
    MousePointer = vbHourglass
    Refresh
    Set ThePicture = New ObjPicture
    CreateCube TheCubes(1), -5, -1, -1
    CreateCube TheCubes(2), -3, -1, -1
    CreateCube TheCubes(3), -1, -1, -1
    CreateCube TheCubes(4), 1, -1, -1
    CreateCube TheCubes(5), -1, 1, -1
    CreateCube TheCubes(6), -1, -1, -3
    CreateCube TheCubes(7), -1, -3, -1
    CreateCube TheCubes(8), -1, -1, 1
    MousePointer = vbDefault
End Sub
Private Sub Form_Unload(Cancel As Integer)
    End
End Sub
Private Sub mnuFileExit_Click()
    Unload Me
End Sub
Private Sub XW2Text_Change()
    DrawData
End Sub
Private Sub YW2Text_Change()
    DrawData
End Sub
Private Sub ZW2Text_Change()
    DrawData
End Sub