home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / Physics_on20307011132006.psc / Form1.frm < prev    next >
Text File  |  2006-11-13  |  12KB  |  425 lines
  1. VERSION 5.00
  2. Begin VB.Form Form1 
  3.    AutoRedraw      =   -1  'True
  4.    BackColor       =   &H00000000&
  5.    Caption         =   "Simple physics on bitmap"
  6.    ClientHeight    =   15165
  7.    ClientLeft      =   -105
  8.    ClientTop       =   1440
  9.    ClientWidth     =   23880
  10.    LinkTopic       =   "Form1"
  11.    ScaleHeight     =   1011
  12.    ScaleMode       =   3  'Pixel
  13.    ScaleWidth      =   1592
  14.    Begin VB.PictureBox Pic3 
  15.       AutoRedraw      =   -1  'True
  16.       AutoSize        =   -1  'True
  17.       Height          =   60060
  18.       Left            =   18000
  19.       Picture         =   "Form1.frx":0000
  20.       ScaleHeight     =   60000
  21.       ScaleWidth      =   30000
  22.       TabIndex        =   10
  23.       Top             =   11760
  24.       Visible         =   0   'False
  25.       Width           =   30060
  26.    End
  27.    Begin VB.Timer DebugUpdate 
  28.       Interval        =   30
  29.       Left            =   8280
  30.       Top             =   120
  31.    End
  32.    Begin VB.PictureBox Pic1 
  33.       AutoRedraw      =   -1  'True
  34.       AutoSize        =   -1  'True
  35.       DrawWidth       =   20
  36.       Height          =   60060
  37.       Left            =   16320
  38.       Picture         =   "Form1.frx":55236
  39.       ScaleHeight     =   4000
  40.       ScaleMode       =   3  'Pixel
  41.       ScaleWidth      =   2000
  42.       TabIndex        =   9
  43.       Top             =   9240
  44.       Visible         =   0   'False
  45.       Width           =   30060
  46.    End
  47.    Begin VB.Frame Frame2 
  48.       Caption         =   "Speed"
  49.       Height          =   2175
  50.       Left            =   0
  51.       TabIndex        =   3
  52.       Top             =   0
  53.       Width           =   1215
  54.       Begin VB.CommandButton Command1 
  55.          Caption         =   "Normal"
  56.          Height          =   375
  57.          Left            =   120
  58.          TabIndex        =   8
  59.          Top             =   240
  60.          Width           =   975
  61.       End
  62.       Begin VB.CommandButton Command2 
  63.          Caption         =   "Slow"
  64.          Height          =   375
  65.          Left            =   120
  66.          TabIndex        =   7
  67.          Top             =   600
  68.          Width           =   975
  69.       End
  70.       Begin VB.CommandButton Command3 
  71.          Caption         =   "Very Slow"
  72.          Height          =   375
  73.          Left            =   120
  74.          TabIndex        =   6
  75.          Top             =   960
  76.          Width           =   975
  77.       End
  78.       Begin VB.CommandButton Command4 
  79.          Caption         =   "Stop"
  80.          Height          =   375
  81.          Left            =   120
  82.          TabIndex        =   5
  83.          Top             =   1320
  84.          Width           =   975
  85.       End
  86.       Begin VB.CommandButton Command5 
  87.          Caption         =   "Step"
  88.          Height          =   375
  89.          Left            =   120
  90.          TabIndex        =   4
  91.          Top             =   1680
  92.          Width           =   975
  93.       End
  94.    End
  95.    Begin VB.Timer ScrollScreen 
  96.       Enabled         =   0   'False
  97.       Interval        =   10
  98.       Left            =   7680
  99.       Top             =   120
  100.    End
  101.    Begin VB.Frame Frame1 
  102.       BackColor       =   &H00000000&
  103.       Caption         =   "Debug"
  104.       ForeColor       =   &H00FFFF00&
  105.       Height          =   4335
  106.       Left            =   20040
  107.       TabIndex        =   1
  108.       Top             =   0
  109.       Width           =   3855
  110.       Begin VB.Label Label1 
  111.          BackColor       =   &H00000000&
  112.          Caption         =   "Debug"
  113.          BeginProperty Font 
  114.             Name            =   "System"
  115.             Size            =   9.75
  116.             Charset         =   238
  117.             Weight          =   700
  118.             Underline       =   0   'False
  119.             Italic          =   0   'False
  120.             Strikethrough   =   0   'False
  121.          EndProperty
  122.          ForeColor       =   &H00FFFF00&
  123.          Height          =   3975
  124.          Left            =   120
  125.          TabIndex        =   2
  126.          Top             =   240
  127.          Width           =   3495
  128.       End
  129.    End
  130.    Begin VB.Timer Timer1 
  131.       Left            =   7080
  132.       Top             =   120
  133.    End
  134.    Begin VB.PictureBox Pic2 
  135.       AutoRedraw      =   -1  'True
  136.       AutoSize        =   -1  'True
  137.       BorderStyle     =   0  'None
  138.       DrawWidth       =   20
  139.       Height          =   60000
  140.       Left            =   1080
  141.       Picture         =   "Form1.frx":5AD2B
  142.       ScaleHeight     =   4000
  143.       ScaleMode       =   3  'Pixel
  144.       ScaleWidth      =   2000
  145.       TabIndex        =   0
  146.       Top             =   2640
  147.       Width           =   30000
  148.       Begin VB.Shape obj 
  149.          BackColor       =   &H00FFFF00&
  150.          BackStyle       =   1  'Opaque
  151.          BorderColor     =   &H00000000&
  152.          Height          =   375
  153.          Left            =   3360
  154.          Shape           =   3  'Circle
  155.          Top             =   3360
  156.          Width           =   375
  157.       End
  158.    End
  159. End
  160. Attribute VB_Name = "Form1"
  161. Attribute VB_GlobalNameSpace = False
  162. Attribute VB_Creatable = False
  163. Attribute VB_PredeclaredId = True
  164. Attribute VB_Exposed = False
  165. Dim KeyLeft, KeyRight, KeyShift As Boolean
  166. Dim OSpeed As Integer
  167. Dim XKin, YKin As Double
  168. Dim Xpos, Ypos As Double
  169. Dim DrawOn As Boolean
  170. Dim LastX, LastY As Single
  171. Dim tempA, tempB
  172. Dim Roling As Boolean
  173. Dim FormWidth, FormHeight As Integer
  174. Dim ScroolB As Boolean
  175. Dim ScroolX, ScroolY As Integer
  176. 'Basic Parametters
  177. '-------------------------
  178. Const Bounce As Double = 3 'Boncynes of the ball. smaller the number the more it bounces
  179. Const AirResistance As Double = 0.999 'How fast the ball decelerates. 1 is frictionles ,0 is total stop
  180. Const GroundFriction As Double = 0.999 'How fast the ball decelerates when on the ground. 1 is frictionles,0 is total stop
  181. Const GravityStrenth As Double = 1 'How fast the ball falls, the biger the numbaer the faster it falls
  182. '-------------------------
  183.  
  184. 'The Speed controls
  185. Private Sub Command1_Click()
  186. Timer1.Interval = 30
  187. ScrollScreen.Enabled = True
  188. End Sub
  189.  
  190. Private Sub Command2_Click()
  191. Timer1.Interval = 100
  192. ScrollScreen.Enabled = True
  193. End Sub
  194.  
  195. Private Sub Command3_Click()
  196. Timer1.Interval = 200
  197. ScrollScreen.Enabled = True
  198. End Sub
  199.  
  200. Private Sub Command4_Click()
  201. Timer1.Interval = 0
  202. ScrollScreen.Enabled = False
  203. End Sub
  204.  
  205. Private Sub Command5_Click()
  206. Timer1_Timer
  207. End Sub
  208.  
  209. Private Sub DebugUpdate_Timer()
  210. 'DEBUG
  211. Label1.Caption = "X Kinetic :" & vbNewLine & XKin & vbNewLine & CharBarPN(XKin) & vbNewLine _
  212. & "Y Kinetic :" & vbNewLine & YKin & vbNewLine & CharBarPN(YKin) & vbNewLine _
  213. & "X Position :" & vbNewLine & Xpos & vbNewLine _
  214. & "Y Position :" & vbNewLine & Ypos & vbNewLine _
  215. & "Hill Right :" & vbNewLine & tempA & vbNewLine & CharBar(tempA) & vbNewLine _
  216. & "Hill Left :" & vbNewLine & tempB & vbNewLine & CharBar(tempB) & vbNewLine
  217. End Sub
  218.  
  219. Private Sub Form_Resize() ' Ajdust evrything when form resized
  220. Frame1.Left = Form1.Width / 15 - Frame1.Width - 10
  221. FormWidth = Form1.Width / 15
  222. FormHeight = Form1.Height / 15
  223. End Sub
  224.  
  225.  
  226. 'Left Right Buttns
  227. Private Sub Pic2_KeyDown(KeyCode As Integer, Shift As Integer)
  228. If KeyCode = 16 Then KeyShift = True
  229. If KeyCode = 37 Then KeyLeft = True
  230. If KeyCode = 39 Then KeyRight = True
  231. End Sub
  232.  
  233. Private Sub Pic2_KeyUp(KeyCode As Integer, Shift As Integer)
  234. If KeyCode = 16 Then KeyShift = False
  235. If KeyCode = 37 Then KeyLeft = False
  236. If KeyCode = 39 Then KeyRight = False
  237. End Sub
  238.  
  239. Private Sub Form_Load() 'Start up this puppy
  240. LoadBitmap
  241. Xpos = obj.Left
  242. Ypos = obj.Top
  243. End Sub
  244.  
  245. Private Sub Pic2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'Stuff to make mouse interaction work
  246. If Button = 1 Then 'Check wich button on mouse pushed
  247.     DrawOn = True
  248. ElseIf Button = 4 Then
  249.     ScroolB = True
  250.     ScroolX = X
  251.     ScroolY = Y
  252. Else
  253.     Xpos = X
  254.     Ypos = Y
  255.     XKin = 0
  256.     YKin = 0
  257. End If
  258. End Sub
  259.  
  260. Private Sub Pic2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  261. If DrawOn = True Then 'DrawWalls
  262.     If KeyShift = False Then
  263.         Pic1.Line (LastX, LastY)-(X, Y), RGB(0, 0, 0)
  264.         Pic2.Line (LastX, LastY)-(X, Y), RGB(100, 100, 0)
  265.     Else
  266.         Pic1.Line (LastX, LastY)-(X, Y), vbWhite
  267.         Pic2.PaintPicture Pic3, X - 13, Y - 13, 25, 25, X - 13, Y - 13, 25, 25
  268.     End If
  269. End If
  270.  
  271. If ScroolB = True Then 'Scrool
  272. Pic2.Left = Pic2.Left - ScroolX + X
  273. Pic2.Top = Pic2.Top - ScroolY + Y
  274. ScrollScreen.Enabled = False
  275. End If
  276. LastX = X 'Used for drawing walls
  277. LastY = Y
  278. End Sub
  279.  
  280. Private Sub Pic2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  281. If Timer1.Interval <> 0 Then ScrollScreen.Enabled = True
  282. ScroolB = False
  283. DrawOn = False
  284. LoadBitmap
  285. End Sub
  286.  
  287. Private Sub Picture1_Click()
  288.  
  289. End Sub
  290.  
  291. Private Sub ScrollScreen_Timer()
  292. On Error Resume Next
  293. If obj.Left + Pic2.Left < FormWidth / 5 Then Pic2.Left = Pic2.Left - (obj.Left + Pic2.Left - FormWidth / 5) / (FormWidth \ 100)
  294. If obj.Left + Pic2.Left > FormWidth / 1.2 Then Pic2.Left = Pic2.Left - (obj.Left + Pic2.Left - FormWidth / 1.2) / (FormWidth \ 100)
  295. If obj.Top + Pic2.Top < FormHeight / 5 Then Pic2.Top = Pic2.Top - (obj.Top + Pic2.Top - FormHeight / 5) / (FormHeight \ 100)
  296. If obj.Top + Pic2.Top > FormHeight / 1.5 Then Pic2.Top = Pic2.Top - (obj.Top + Pic2.Top - FormHeight / 1.5) / (FormHeight \ 100)
  297. End Sub
  298.  
  299. Private Sub Timer1_Timer()
  300. GoOverGround 'Make shure ball didnt go trugh the ground
  301. 'Hill roll
  302. tempA = GroundHigh(Xpos - 5, Ypos + 27)
  303. tempB = GroundHigh(Xpos + 30, Ypos + 27)
  304. XKin = XKin + tempA / 10 * (YKin / 10)
  305. XKin = XKin - tempB / 10 * (YKin / 10)
  306.  
  307. 'X axsis colision detection
  308. If GroundCol(CSng(Xpos), CSng(Ypos) - 10) = True And XKin < 0 Then
  309.     XKin = Abs(XKin) / 5
  310. End If
  311. If GroundCol(Xpos + 25, Ypos - 10) = True And XKin > 0 Then
  312.     XKin = 0 - Abs(XKin) / Bounce
  313. End If
  314.  
  315. 'Y axsis colision detection
  316. If GroundCol(Xpos + 13, Ypos + 28) = True Then
  317.     XKin = XKin - (tempB * YKin) / 50
  318.     XKin = XKin + (tempA * YKin) / 50
  319.     YKin = 0 - Abs(YKin) / Bounce
  320.     GoOverGround
  321. End If
  322. If GroundCol(Xpos + 13, Ypos) = True Then
  323.     XKin = XKin - (tempB * YKin) / 50
  324.     XKin = XKin + (tempA * YKin) / 50
  325.     YKin = Abs(YKin) / Bounce
  326.     GoOverGround
  327. End If
  328. 'Gravity
  329. If GroundCol(Xpos + 13, Ypos + 23) = False Then
  330.     YKin = YKin + GravityStrenth
  331. End If
  332.  
  333.  
  334.  
  335.  
  336.  
  337.  
  338. 'Direction keys
  339. If KeyLeft = True Then
  340.     Xpos = Xpos - 10
  341.     XKin = 0
  342. End If
  343. If KeyRight = True Then
  344.     Xpos = Xpos + 10
  345.     XKin = 0
  346. End If
  347.  
  348.  
  349.  
  350.  
  351. 'AirResistance
  352. XKin = XKin * AirResistance
  353. YKin = YKin * AirResistance
  354. 'GroundRessitance
  355. If GroundCol(Xpos + 13, Ypos + 28) Then XKin = XKin * GroundFriction
  356.  
  357.  
  358. 'Update position
  359.  
  360. Xpos = Xpos + XKin
  361. Ypos = Ypos + YKin
  362. 'MoveObject
  363.  
  364. obj.Left = Xpos
  365. obj.Top = Ypos
  366.  
  367.  
  368. End Sub
  369.  
  370.  
  371. Private Function CharBar(val) As String
  372. For i = 0 To val
  373. CharBar = CharBar & "I"
  374. Next i
  375. For i = 0 To 50 - val
  376. CharBar = CharBar & "."
  377. Next i
  378. End Function
  379.  
  380.  
  381. Private Function CharBarPN(val) As String
  382. CharBarPN = CharBarPN & "["
  383.  
  384. If val > 25 Then val = 25
  385. If val < -25 Then val = -25
  386. If val < 0 Then
  387.     For i = 0 To 25 - Abs(val)
  388.         CharBarPN = CharBarPN & "."
  389.     Next i
  390.     For i = 0 To Abs(val)
  391.         CharBarPN = CharBarPN & "I"
  392.     Next i
  393.     CharBarPN = CharBarPN & ".........................."
  394. Else
  395.     CharBarPN = CharBarPN & ".........................."
  396.     For i = 0 To val
  397.         CharBarPN = CharBarPN & "I"
  398.     Next i
  399.     For i = 0 To 25 - val
  400.         CharBarPN = CharBarPN & "."
  401.     Next i
  402.  
  403. End If
  404. CharBarPN = CharBarPN & "]"
  405. End Function
  406.  
  407.  
  408. Private Function GroundHigh(X As Single, Y As Single) As Integer
  409. Do Until GroundCol(X, Y - i) = False
  410. If i = 100 Then Exit Do
  411.     i = i + 1
  412. Loop
  413. If i < 100 Then GroundHigh = i
  414. End Function
  415.  
  416. Private Sub GoOverGround()
  417. Dim i As Integer
  418. Do Until GroundCol(Xpos + 13, Ypos + 23 - i) = False
  419. If i = 100 Then Exit Do
  420.     i = i + 1
  421. Loop
  422. If i < 100 Then Ypos = Ypos - i
  423.  
  424. End Sub
  425.