yivSyJ1T

1'**********************
2'  Bad Cats(1989)
3' VPX table by unclewilly,Clark Kent, Dark
4' version 1.0
5'**********************
6
7Option Explicit
8Randomize
9Dim FlipLag
10FlipLag = 0  'Enable/Disable FlipperLag Fix  0 is disable 1 is enable
11Dim xx, DNS
12Dns = table1.NightDay
13
14If DNS <= 5 or DNS >= 75 then
15	For each xx in aGiLights:xx.intensity = xx.intensity *(1-(DNS/100)):Next
16	For each xx in aAllFlashers:xx.opacity = xx.opacity *(1-(DNS/100)):Next
17	For each xx in AllLamps:xx.intensity = xx.intensity *(1-(DNS/100)):Next
18	For each xx in TargetDropGi:xx.intensity = xx.intensity *(1-(DNS/100)):Next
19else 
20	If DNS <= 40 or DNS >= 80 Then
21		For each xx in aGiLights:xx.intensity = xx.intensity *(.5-(DNS/100)):Next
22		For each xx in aAllFlashers:xx.opacity = xx.opacity *(.5-(DNS/100)):Next
23		For each xx in AllLamps:xx.intensity = xx.intensity *(.5-(DNS/100)):Next
24	For each xx in TargetDropGi:xx.intensity = xx.intensity *(.5-(DNS/100)):Next
25	else
26		For each xx in aGiLights:xx.intensity = xx.intensity *(.7-(DNS/100)):Next
27		For each xx in aAllFlashers:xx.opacity = xx.opacity *(.7-(DNS/100)):Next
28		For each xx in AllLamps:xx.intensity = xx.intensity *(.7-(DNS/100)):Next
29	For each xx in TargetDropGi:xx.intensity = xx.intensity *(.7-(DNS/100)):Next
30	end if
31end if
32
33
34
35solGI 0
36
37On Error Resume Next
38ExecuteGlobal GetTextFile("controller.vbs")
39If Err Then MsgBox "You need the controller.vbs in order to run this table, available in the vp10 package"
40On Error Goto 0
41
42
43
44
45
46'LoadVPM "01550000", "S11.vbs", 3.26
47'Last Updated in VBS v3.36
48
49
50
51
52LoadController("VPM")
53'Option Explicit
54LoadCore
55Private Sub LoadCore
56	On Error Resume Next
57	If VPBuildVersion < 0 Or Err Then
58		Dim fso : Set fso = CreateObject("Scripting.FileSystemObject") : Err.Clear
59		'ExecuteGlobal fso.OpenTextFile("core.vbs", 1).ReadAll    : If Err Then MsgBox "Can't open ""core.vbs""" : Exit Sub
60		ExecuteGlobal fso.OpenTextFile("VPMKeys.vbs", 1).ReadAll : If Err Then MsgBox "Can't open ""vpmkeys.vbs""" : Exit Sub
61	Else
62		'ExecuteGlobal GetTextFile("core.vbs")    : If Err Then MsgBox "Can't open ""core.vbs"""    : Exit Sub
63		ExecuteGlobal GetTextFile("VPMKeys.vbs") : If Err Then MsgBox "Can't open ""vpmkeys.vbs""" : Exit Sub
64	End If
65End Sub
66
67'Option Explicit
68Const VPinMAMEDriverVer = 3.56
69'=======================
70' VPinMAME driver core.
71'=======================
72' New in 3.56 (Update by )
73'
74' New in 3.55 (Update by nFozzy)
75' - Prevent 'object not a collection' errors if vpmNudge.TiltObj isn't set
76' - Support for double leaf flipper switches
77'   - For now, keybinds for these staged flippers are defined in VPMKeys.vbs. By default they are set to LeftFlipperKey and RightFlipperKey, disabling them.
78'   - Adapting older tables requires vpmFlips: Create upper flipper subs and point SolCallback(sULFlipper) and SolCallback(sURFlipper) to them.
79'   - This may break compatibility with some older WPC tables that use the 'cSingleLFlip' method (More info in WPC.vbs), note that close to no 'modern' (e.g. VP8/VP9/VPX) table uses this anyway
80' - Integrated FastFlips, (new object vpmFlips): Low latency flipper response for games with pre-solid state flippers
81'   - Ensure 'vpmInit me' is called in the table init section
82'   - UseSolenoids = 2 enables and auto sets the game-on solenoid (based on GameOnSolenoid in the system .vbs script)
83'   - Important info on supported WPC games is documented in WPC.vbs
84'   - Pre-solid-state flipper games (except Zaccaria and LTD) should work perfectly. This includes Bally/Williams WPCs up to Terminator 2 / Party Zone
85'   - Data East / early Segas will work perfectly, unless they have ROM-controlled flipper effects
86'   - Fliptronics and WPC-S games (Addams Family through Jack Bot / WHO Dunnit) will work with caveats (no ROM controlled flipper effects, beware stuck balls. More info in WPC.vbs)
87'   - Sega Whitestar (Apollo 13 / Goldeneye / etc), WPC95 (Congo / AFM / etc), and Capcom and everything onward will not work
88'   - There's also a debug test command which may be useful if it's not working properly. Open the debug window (Accessible from the VP-escape menu, press the ">" button to bring up the text field) and type in 'vpmFlips.DebugTest'
89'
90' New in 3.54 (Update by mfuegemann & nFozzy & Ninuzzu/Tom Tower & Toxie)
91' - Added UltraDMD_Options.vbs to configure Ultra DMD based tables globally (see the file itself for detailed descriptions)
92' - Added sam.vbs
93' - Added Class1812.vbs
94' - Added inder_centaur.vbs
95' - Restore basic functionality of cvpmDropTarget.CreateEvents for drop targets with an animation time (e.g. VP10 and newer)
96' - Minor cleanups and code unifications for all machines
97' - Add keyConfigurations to VPMKeys.vbs for Taito and also remap the hardcoded keycode '13' to keySoundDiag
98'
99' New in 3.53 (Update by Toxie)
100' - Add more key mappings to help dialog
101'
102' New in 3.52 (Update by DJRobX & Toxie)
103' - Change default interval of the PinMAME timer to -1 (frame-sync'ed) if VP10.2 (or newer) is running
104' - Add modulated solenoids to support ROM controlled fading flashers:
105'   To use, add "UseVPMModSol=True" to the table script
106'   Also use SolModCallback instead of SolCallback to receive level changes as input: It will be a level from 0 to 255.
107'   Just continue to use SolCallback if you only care about boolean values though, as it will only fire if level changes from on to off.
108'   Note: vpmInit MUST BE CALLED or VPM will not switch modes (if you are only getting 0 and 1 from SolModCallback then that may be the issue)
109'
110' New in 3.51 (Update by mfuegemann & Arngrim & Toxie)
111' - gts1.vbs dip fix
112' - Add comments to cvpmDropTarget.CreateEvents: do not use this anymore in VP10 and above, as drop targets have an animation time nowadays
113' - Change default interval of the PinMAME timer to 3 if VP10 (or newer) is running, and leave it at 1 for everything else
114' - Fix missing SlingshotThreshold() when using VP8.X
115' - (Controller.vbs changes)
116'   - now its allowed to have each toy to be set to 0 (sound effect), 1 (DOF) or 2 (both)
117'   - new DOF types: DOFFlippers, DOFTargets, DOFDropTargets
118'   - all values are now stored in the registry (HKEY_CURRENT_USER\SOFTWARE\Visual Pinball\Controller\), and can also be changed from within VP10.2 and above
119'   - InitializeOptions call added to the controller init, for tables that want to use this functionality during gameplay (options menu via F6)
120'
121' New in 3.50 (Update by Toxie & mfuegemann & Arngrim)
122' - Added MAC.vbs & IronBalls.vbs & Lancelot.vbs & Antar.vbs
123' - (Core changes)
124'   - Increased NVOffset limit from 10 to 32
125'   - Use temporary variables for Switch() calls to workaround current PROC issues
126'   - Controller.vbs user-folder detection fix, and add simple PROC usage via LoadPROC (see Controller.vbs for details)
127'   - Add UseVPMNVRAM = true to the table script (place before LoadVPM, or otherwise calling core.vbs)
128'     to make changed content of NVRAM available (since last update) via the NVRAMCallback (delivers a three dimensional array with: location, new value, old value)
129'     (requires VPM 2.7 or newer)
130'
131' New in 3.49 (Update by Arngrim)
132' - Add new Controller.vbs to abstract DOF, B2S, VPM and EM controller loading, usage and sound/effect handling,
133'   see Controller.vbs header on how to use it exactly
134'
135' New in 3.48 (Update by JimmyFingers)
136' - (Core changes)
137'   - Changed vpmNudge.TiltObj handling to use Bumper.Threshold / Wall.SlingshotThreshold temporary value changes rather than force / SlingshotStrength changes to disable tiltobj array objects
138'   - There existed a bug in VP since at least the 9.x versions where the Wall.SlingshotStrength value being set by scripting during game play did change the value but the slingshot behaviour / "Slingshot Force" (from the editor) of the wall object did not change (i.e. did not have an effect); As a result the attempted disabling of bumpers and slingshots after a tilt event on supported games (that can send a relay for vpmNudge.SolGameOn ) would only work for the bumper objects
139'   - Using thresholds instead also now has added benefit by not actually triggering the related _Hit or _Slingshot routines so animations, sound processing, and other potential nested subroutine calls will also not activate resulting in a better tilt simulation
140'   Note: NudgePlugin option .vbs files were also updated as they contain and are reassigned the vpmNudge routines when invoked
141'
142' New in 3.47 (Update by Toxie)
143' - (Core changes)
144'   - Add UseVPMColoredDMD = true to the table script (place before LoadVPM, or otherwise calling core.vbs)
145'     to automatically pass the raw colored DMD data (RGB from 0..255) from VPM to VP (see VP10+ for details on how to display it)
146'
147' New in 3.46 (Update by KieferSkunk)
148' - (Core changes)
149'   - Added two new classes: cvpmTrough and cvpmSaucer
150'     - cvpmTrough takes over for cvpmBallStack in non-Saucer mode.
151'       - Can handle any number of balls (no more "out of bounds" errors with lots of balls)
152'       - Accurately simulates ball movement and switch interaction in a real trough
153'     - cvpmSaucer takes over for cvpmBallStack in Saucer mode.
154'     - cvpmBallStack is now considered "legacy" - kept for compatibility with existing tables.  (No changes)
155'   - Updated vbsdoc.html with these new classes.
156'   - Added two helper functions, vpMin(a, b) and vpMax(a, b).
157'     - These each take two numbers (or strings) and return the lower or higher of the two (respectively).
158'
159' New in 3.45 (Update by KieferSkunk)
160' - (Core changes)
161'   - Rewrote cvpmDictionary as a wrapper around Microsoft's Scripting.Dictionary object.
162'     This provides two major benefits:
163'     (1) Improved performance: Keys are stored by hash/reference, not by index, and existence checks and key location are now O(1) instead of O(N) operations.
164'     (2) Keys and Items can now both be primitive types or objects.  You can use integers, strings, etc. as keys, and you can use any object as an Item.
165'         Note: The only restriction is that a Key cannot be a Scripting.Dictionary or an Array.
166'   - cvpmTurnTable now smoothly changes speeds and directions.  You can adjust the following properties to change the turntable's behavior:
167'     - MaxSpeed: Sets new maximum spin speed.  If motor is on, turntable will smoothly accelerate to new speed.
168'     - SpinUp: Sets new spin-up rate.  If currently accelerating, turntable will accelerate at the new rate.
169'     - SpinDown: Sets new spin-down rate.  If currently slowing to a stop, turntable will decelerate at the new rate.
170'     - SpinCW: True for clockwise rotation, False for counter-clockwise.  If motor is on, switching this will smoothly reverse the turntable's direction.
171'
172' New in 3.44 (Update by Toxie)
173' - (Core changes)
174'	- Added ability to define default ball mass (in VP Units) inside table script.
175'		Defaults to 1 unit if undefined. Example...
176'			Const BallMass = 2 '(place before LoadVPM, or otherwise calling core.vbs)
177'       Note that this should be used if changing the ball size via BallSize,
178'       as the mass is of course proportional to the radius of the ball: m=k*r^3.
179'       One can also use the diameter/size like in VP, so BallMass=k*BallSize^3 with k=1/125000.
180'       Example: BallSize = 55, so BallMass = (55*55*55)/125000 = 1.331.
181'   - Add UseVPMDMD = true to the table script (place before LoadVPM, or otherwise calling core.vbs)
182'     to automatically pass the raw DMD data (levels from 0..100) from VPM to VP (see VP10+ for details on how to display it)
183'   - Add toggleKeyCoinDoor in VPMKeys.vbs to choose between a real coindoor setup (e.g. cabinets) and the 'classic' on/off behaviour (e.g desktops/keyboards)
184'   - Add inverseKeyCoinDoor in VPMKeys.vbs to in addition choose between the behaviour of a real coindoor switch (key pressed = closed, key not pressed = open)
185'     or the inverted behaviour (key pressed = open, key not pressed = closed)
186'   - Increase maximum number of balls/conMaxBalls to 13 and conStackSw to 8 (for Apollo 13), use InitSw8() then instead of InitSw()
187'   - Deprecate vpmSolFlip2, as VP10 does not feature speed on flippers anymore
188'
189' New in 3.43 (Update by Koadic)
190' - (Core Changes)
191'	- Minor adjustment to vbs loading via LoadScript to account for files in nonstandard locations
192'	- Fix minor bugs when loading some tables
193
194' New in 3.42 (Update by Koadic)
195' - (Core Changes)
196'	- Minor adjustment to vpmInit to unpause controller before stopping controller
197'
198' New in 3.41 (Update by Koadic)
199' - (Core Changes)
200'	- Modified vpmInit routine:
201'		Added creation of _Exit routine to vpmInit to perform Controller.Stop (will retroactively effect all tables using vpmInit call)
202'		Modified vpmInit to create _Paused, _UnPaused, and _Exit separately, so if any don't exit, they will be created individually
203'		Modified Error handling to fix bug where vmpInit might throw "Invalid procedure call or argument" error
204'		 and cause table not to work due to improper Table_Init scripting.
205'	- Added 2 functions: CheckScript(file) and LoadScript(file) that can return True/False as well as the latter loading the script if true.
206'	   These check for existance in either the Tables and Scripts directory and can return a boolean value as well as the LoadScript autoloading
207'		the file, as opposed to my previous methods only checking the local folder containing the table being run. 
208'	   CheckScript(file) checks for existance, and if found returns a True value
209'	   LoadScript(file) checks for existance, and if found, loads specified file (via ExecuteGlobal GetTextFile(file)) and returns a True value
210'		Examples:
211'			If LoadScript("thefile.vbs") Then DoThisOtherThing	' If Loadscript found 'thefile' and loaded it (returned true) then do this other thing
212'			LoadScript("somefile.vbs")							' Checks for 'somefile' and loads it if it exists
213'	- Reworked CheckLEDWiz routine into generic LoadScript(file) routine to allow for better detection of script in the VP tables
214'	   or scripts directory, not just current directory containing the table.
215'	- Added ability to load NudgePlugIn.vbs and if found, it will be loaded and replace current default nudging class.
216'		- This detection and autoloading can allow for 'on demand' replacement of other core components as well in the future.
217'	- Added ability to load GlobalPlugIn.vbs containing any custom scripting the user wants loaded with the core.vbs (instead of modifying the core)
218' -(Other Additions)
219'	- Updated B2BCollision.vbs with vpmBallCreate method and renamed new file to B2B.vbs (to maintain compatiblity with tables using old file).
220'
221' New in 3.40 (Update by Koadic)
222' - (Core Changes)
223'	- Modified NVOffset routine to allow use of alternative controllers (like dB2S B2S.Server)
224' New in 3.39 (Update by Koadic)
225' - (Core Changes)
226'	- Hopefully fixed bug introduced in 3.37 when using a VP version older than 9.0.10
227' New in 3.38 (Update by Koadic)
228' - (Core Changes)
229'	- Added automatic detection of ledcontrol.vbs and enabling for LedWiz use, allowing concurrent use by both users and non users of an LedWiz
230' New in 3.37 (Update by Koadic)
231' - (Core Changes)
232'	- Added ability to define default ballsize (in VP Units) inside table script.
233'		Defaults to 50 vp units if undefined. Example...
234'			Const BallSize = 47 '(place before LoadVPM, or otherwise calling core.vbs)	
235' New in 3.36 (update courtesy of Koadic)
236' - (Core Changes)
237'   - Added VPMVol routine for allowing setting of Global VPM Volume (normally adjustable from '~' key, but otherwise unsaveable without this)
238' - (System VBS Alterations)
239'   - Added keyVPMVolume in VPMKeys.vbs, set to use the F12 key
240'   - Added call to VPMVol routine in each system's .vbs file, allowing end-user to access the new routine
241' New in 3.35 (Update courtesy of Koadic)
242' - (Core Changes)
243'   - Added NVOffset routine for allowing use of multiple nvram files per romset name
244' New in 3.34 (Update by Destruk)
245' - (System VBS Additions)
246'   - Added Play2.vbs
247' New in 3.33 (Update by Destruk)
248' - (System VBS Additions)
249'   - Added LTD.vbs
250' New in 3.32 (Update by Destruk)
251' - (System VBS Alterations)
252'   - Added Playmatic Replay setting switches
253' New in 3.31 (Update by Destruk)
254' - (System VBS Additions)
255'   - Added play1.vbs
256' New in 3.30 (Update by Destruk)
257' - (System VBS Additions)
258'   - Added zacproto.vbs
259' New in 3.29 (Update by Noah)
260' - (System VBS Additions)
261'   - Added jvh.vbs and ali.vbs by Destruk for Jac van Ham and Allied Leisure
262' Corrected VPBuild Number for slingshots/bumpers and ball decals - Seeker
263' New in 3.27 (Update by PD)
264' - (System VBS Additions)
265'   - Added gts1.vbs by Inkochnito for Gottlieb System 1
266' New in 3.26 (Update by PD)
267' - (Core Changes)
268'    - Added "GICallback2" function to support Steve Ellenoff's new support in VPM for Dimming GI in WMS games
269'      GICallback returns numeric values 0-8 instead of a boolean 0 or 1 (on/off) like GICallback does.
270'      Existing tables will need to be altered to support dimming levels and need to use GICallback2 instead.
271'      The old GICallback is left intact so older tables are not broken by the new code
272'
273' New in 3.25 (release 2) (Update by PD)
274' - (Core Changes)
275'    - Restored former flipper speed due to complaints about some tables having BTTF problem returned and a resolution
276'      of arguments over the settings
277'    - New Optional Flipper Code Added (vpmSolFlip2) that let's you specify both up and down-swing speeds in the script
278'      plus the ability to turn flipper sounds on or off for that call
279'      Format: vpmSolFlip2 (Flip1obj, Flip2obj, UpSpeed, DownSpeed, SoundOn, Enable) 
280'
281' New in 3.24 (Update by PD)
282' - (Core Changes)
283'    - Altered flipper code so the upswing defaults to your downswing (i.e. VBS no longer adds a different value)
284'      (This change was done due to arguments over issues now resolved)
285'    - I have decreased the return strength setting to be very low, though.  So any downswing hits (say from a ball
286'      heading to the trough) won't get hit with any real power.  So, assuming you have a reasonably fast upswing,
287'      you won't get any balls through the flipper and any balls hit by the underside won't get pegged anymore, which
288'      is a more realistic behavior.
289'
290' New in 3.23 (Update by PD)
291' - (System.vbs Additions)
292'    - SlamtTilt definitions added to AlvinG and Capcom systems
293'    - High Score Reset Switch Added to Williams System7 (S7.vbs)
294'    - Sleic.vbs system added (courtesy of Destruk)
295'    - Peper.vbs system added (courtesy of Destruk)
296'    - Juegos.vbs system added (courtesy of Destruk)
297'
298' New in 3.22 (Update by PD)
299' - (Core Changes)
300'   - Outhole switch handling updated so it resets correctly with an F3 reset.  
301'     This affects mostly Gottlieb System3 games (Thanks Racerxme for pointing this out)
302'   - Flipper handling modified to have a low return strength setting so any balls under such flippers
303'     won't get hit hard.  This allows the higher 'flipper fix' return speed without the associated hard hit issue.
304' - (System.vbs Additions)
305'   -Inder.vbs test switches updated (Thanks Peter)
306'   -Bally.vbs swSoundDiag value changed to -6 (Thanks Racerxme)
307'
308' New in 3.21 (Update by PD)
309' -(Core Changes)
310'   - Attemped bug fix in the Impulse Plunger object that could cause weak plunges sometimes on full pulls
311'   
312' -(System.vbs Additions)
313'   -Zac1.vbs has the program enable switch added to it (Thanks TomB)
314'   -GamePlan.vbs has the accounting reset switch added to it (Thanks Incochnito)
315'
316' -(Other Additions)
317'   -PD Light System VBS file updated to V5.5 (adds fading reel pop bumper handler and checklight function)
318'
319' New in 3.20 (Update by PD)
320' -(System.vbs Additions)
321'   -Apparently Atari2.vbs uses 81/83 for the flipper switches and Atar1.vbs uses 82/84 so this repairs
322'    the Atari2.vbs file.
323'
324' New in 3.19 (Update by PD)
325' -(System.vbs Additions)
326'   - Fixed the swLLFlip and swLRFlip switch numbers in the Atari1.vbs, Atari2.vbs and Atari.vbs files
327'     SolFlipper should now work with Atari tables using the updated file
328'
329' New in 3.18 (Update by PD)
330' -(System.vbs Additions)
331'   - Added Atari1.vbs and Atari2.vbs files (Thanks to Inkochnito).  
332'     -The old Atari.vbs file is now obsolete, but included for backwards compatability with any existing tables
333'      that may have used it. New Tables should use the appropriate Atari1.vbs or Atari2.vbs files.
334'
335' New in 3.17 (Update by PD)
336' -(System.vbs Additions)
337'   -Fixed wrong switch definition in Sys80.vbs for the self-test switch.  The operator menus should work now.
338'    (Thanks to Inkochnito for pointing it out).
339'   -Added inder.vbs, nuova.vbs, spinball.vbs and mrgame.vbs files (Thanks to Destruk)
340'
341' New in 3.16 (Update by PD)
342' -(System.vbs Additions)
343'   -Added "BeginModal" and "EndModal" statements to each system (required for latest versions of VP ( >V6.1) to
344'    avoid problems during the VPM "F3" reset.
345' -(Other Additions)
346'   - PDLightSystem Core updated to version 5.4
347'
348' New in 3.15 (Update by PD)
349' -(Core Additions)
350'   - Added a new higher resolution Impulse Plunger Object 
351'      (It uses a trigger to plunge the ball.  It can be a variable Manual Plunger or function as an Automatic Plunger)
352'      (It also features random variance options and optional pull / plunge sounds)
353'
354' -(System.vbs Additions)
355'   - Fixed wrong switch number for Tilt & Slam Tilt in Sega.vbs
356'   - Added Master CPU Enter switch to S7.vbs for Dip Switch control in Williams System7
357'
358' -(Other Additions)
359'   - Added PDLightSystem.vbs (V5.3) file to archive 
360'     (open it with a text editor to see how to use it; it's called separately like the core file)
361'
362' New in 3.14 (Update by PD)
363' -(System.vbs Additions)
364'   - Added latest Zac1.vbs and Zac2.vbs files to archive
365'
366' New in 3.13 (Update by PD)
367' -(Core Additions)
368'   - Added Destruk's code to "Add" or "Remove" a ball from the table when "B" is pressed.
369'   - Added "AutoplungeS" call which is the same as "Autoplunger" except it will play a specified sound when fired
370'
371' -(System.vbs Additions)
372'   - Taito.vbs updated to fix service menu keys and default dip switch menu added
373'   - Dip Switch / Option Menu "class" code added to all table VBS scripts to ease menu coding for table authors
374'   - Fixed some labeling errors and organization and added a "Last Updated" version comment at the start of each file
375'
376' New in 3.12
377'   - Made flipper return speed a constant conFlipRetSpeed
378'   - set conFlipRetSpeed to 0.137 to reduce ball thru flipper problem
379'
380' New in 3.11
381'   - Added a short delay between balls in the ballstacks to ensure
382'     that the game registers the switches as off when balls are rolling
383'     in the trough. All balls should probably move at the same time but it is
384'     a bit tricky to implement without changing a lot of code.
385'   - Removed support for the wshltdlg.dll since funtionality is in VPM now
386' New in 3.10
387'   - Public release
388' Put this at the top of the table file
389'LoadVPM "02000000", "xxx.VBS", 3.15
390'Const cGameName    = "xxxx" ' PinMAME short game name
391'Const UseSolenoids = True
392'Const UseLamps     = True
393''Standard sound
394'Const SSolenoidOn  = "SolOn"       'Solenoid activates
395'Const SSolenoidOff = "SolOff"      'Solenoid deactivates
396'Const SFlipperOn   = "FlipperUp"   'Flipper activated
397'Const SFlipperOff  = "FlipperDown" 'Flipper deactivated
398'Const SCoin        = "Quarter"     'Coin inserted
399''Callbacks
400'Set LampCallback   = GetRef("UpdateMultipleLamps")
401'Set GICallback     = GetRef("UpdateGI")  ' Original GI Callback (returns boolean on and off values only)
402'Set GICallback2    = GetRef("UpdateGI")  ' New GI Callback supports Newer VPM Dimming GI and returns values numeric 0-8)
403'Set MotorCallback  = GetRef("UpdateMotors")
404'
405'Sub LoadVPM(VPMver, VBSfile, VBSver)
406'	On Error Resume Next
407'		If ScriptEngineMajorVersion < 5 Then MsgBox "VB Script Engine 5.0 or higher required"
408'		ExecuteGlobal GetTextFile(VBSfile)
409'		If Err Then MsgBox "Unable to open " & VBSfile & ". Ensure that it is in the same folder as this table. " & vbNewLine & Err.Description : Err.Clear
410'		Set Controller = CreateObject("VPinMAME.Controller")
411'		If Err Then MsgBox "Can't Load VPinMAME." & vbNewLine & Err.Description
412'		If VPMver>"" Then If Controller.Version < VPMver Or Err Then MsgBox "VPinMAME ver " & VPMver & " required." : Err.Clear
413'		If VPinMAMEDriverVer < VBSver Or Err Then MsgBox VBSFile & " ver " & VBSver & " or higher required."
414'End Sub
415'
416'Sub Table_KeyDown(ByVal keycode)
417'	If vpmKeyDown(keycode) Then Exit Sub
418'	If keycode = PlungerKey Then Plunger.Pullback
419'End Sub
420'Sub Table_KeyUp(ByVal keycode)
421'	If vpmKeyUp(keycode) Then Exit Sub
422'	If keycode = PlungerKey Then Plunger.Fire
423'End Sub
424'
425'Const cCredits  = ""
426'Sub Table_Init
427'	vpmInit Me
428'	On Error Resume Next
429'		With Controller
430'			.GameName = cGameName
431'			If Err Then MsgBox "Can't start Game " & cGameName & vbNewLine & Err.Description : Exit Sub
432'			.SplashInfoLine = cCredits
433'			.HandleMechanics = 0
434'			.ShowDMDOnly = True : .ShowFrame = False : .ShowTitle = False
435'			.Run : If Err Then MsgBox Err.Description
436'		End With
437'	On Error Goto 0
438'' Nudging
439'	vpmNudge.TiltSwitch = swTilt
440'	vpmNudge.Sensitivity = 5
441'	vpmNudge.TiltObj = Array(Bumper1,Bumper2,LeftslingShot,RightslingShot)
442'' Map switches and lamps
443'	vpmCreateEvents colSwObjects ' collection of triggers etc
444'	vpmMapLights    colLamps     ' collection of all lamps
445'' Trough handler
446'	Set bsTrough = New cvpmBallStack
447'	bsTrough.InitNoTrough BallRelease, swOuthole, 90, 2
448'	'or
449'	bsTrough.InitSw swOuthole,swTrough1,swTrough2,0,0,0,0
450'---------------------------------------------------------------
451Dim Controller   ' VPinMAME Controller Object
452Dim vpmTimer     ' Timer Object
453Dim vpmNudge     ' Nudge handler Object
454Dim Lights(200)  ' Put all lamps in an array for easier handling
455' If more than one lamp is connected, fill this with an array of each light
456Dim vpmMultiLights() : ReDim vpmMultiLights(0)
457Private gNextMechNo : gNextMechNo = 0 ' keep track of created mech handlers (would be nice with static members)
458
459' Callbacks
460Dim SolCallback(68) ' Solenoids (parsed at Runtime)
461Dim SolModCallback(68) ' Solenoid modulated callbacks (parsed at Runtime) 
462Dim SolPrevState(68) ' When modulating solenoids are in use, needed to keep positive value levels from changing boolean state
463Dim LampCallback    ' Called after lamps are updated
464Dim GICallback      ' Called for each changed GI String
465Dim GICallback2     ' Called for each changed GI String
466Dim MotorCallback   ' Called after solenoids are updated
467Dim vpmCreateBall   ' Called whenever a vpm class needs to create a ball
468Dim BSize:If IsEmpty(Eval("BallSize"))=true Then BSize=25 Else BSize = BallSize/2
469Dim BMass:If IsEmpty(Eval("BallMass"))=true Then BMass=1 Else BMass = BallMass
470Dim UseDMD:If IsEmpty(Eval("UseVPMDMD"))=true Then UseDMD=false Else UseDMD = UseVPMDMD
471Dim UseModSol:If IsEmpty(Eval("UseVPMModSol"))=true Then UseModSol=false Else UseModSol = UseVPMModSol
472Dim UseColoredDMD:If IsEmpty(Eval("UseVPMColoredDMD"))=true Then UseColoredDMD=false Else UseColoredDMD = UseVPMColoredDMD
473Dim UseNVRAM:If IsEmpty(Eval("UseVPMNVRAM"))=true Then UseNVRAM=false Else UseNVRAM = UseVPMNVRAM
474Dim NVRAMCallback
475
476' Assign Null Default Sub so script won't error if only one is defined in a script (should redefine in your script)
477Set GICallback = GetRef("NullSub")
478Set GICallback2 = GetRef("NullSub")
479
480' Game specific info
481Dim ExtraKeyHelp    ' Help string for game specific keys
482Dim vpmShowDips     ' Show DIPs function
483'-----------------------------------------------------------------------------
484' These helper functions require the following objects on the table:
485'   PinMAMETimer   : Timer object
486'   PulseTimer     : Timer object
487
488
489
490'   Beta Class (move me)
491' cvpmFlips (Object = vpmFlips) low latency flipper handling for games with pre-solid state flippers (fastflips)
492'   (Public) .Solenoid			- Integer, Flipper Solenoid number. vpmInit sets this to GameOnSolenoid from (whatever system .vbs)
493'   (Public) .TiltSol			- Boolean, control flipper enabled / tilts. This is handled automatically in the main loop if 'UseSolenoids' is used.
494'   (Public) .TiltObjects		- Boolean, Automatically calls vpmnudge.SolGameOn to disable slingshots and bumpers in vpmnudge.TiltObj array when tilted. (Default True)
495'   (Public) .Delay				- Integer input. Adds a buffer to the flipper solenoid response. Hack for some fliptronic / WPC-S WPCs that may have solenoid jitter. (Default 0)
496'   (Public) .CallbackL			- String input. Points to Left Flipper callback sub.  If UseSolenoids = 2, vpmInit automatically steals SolCallback(sLLFlipper).
497'   (Public) .CallbackR 		- String input. Points to Right Flipper callback sub. If UseSolenoids = 2, vpmInit automatically steals SolCallback(sLRFlipper).
498'   (Public) .CallbackUL		- String input. Upper Left Flipper callback sub.	 If UseSolenoids = 2, vpmInit automatically steals SolCallback(sULFlipper). 
499'   (Public) .CallbackUR		- String input. Upper Right Flipper callback sub.	 If UseSolenoids = 2, vpmInit automatically steals SolCallback(sURFlipper). 
500'   -debug commands-
501'   (Public) .DebugOn			- Boolean, debug always-on flippers
502'   (Public) .DebugTest			- Reports any discovered errors in debug box
503'   (Public) .PrintSols			- Print any enabled solenoids in the debug box (Debug for finding tilt solenoids)
504
505' Available classes:
506' ------------------
507' cvpmTimer (Object = vpmTimer)
508'   (Public)  .PulseSwitch   - pulse switch and call callback after delay (default)
509'   (Public)  .PulseSw       - pulse switch
510'   (Public)  .AddTimer      - call callback after delay
511'   (Public)  .Reset         - Re-set all ballStacks
512'   (Friend)  .InitTimer     - initialise fast or slow timer
513'   (Friend)  .EnableUpdate  - Add/remove automatic update for an instance
514'   (Private) .Update        - called from slow timer
515'   (Private) .FastUpdate    - called from fast timer
516'   (Friend)  .AddResetObj   - Add object that needs to catch reset
517'
518' cvpmTrough (Create as many as needed)
519'   (Public) .IsTrough         - Get or Set whether this trough is the default trough (first trough sets this by default)
520'   (Public) .Size             - Get or Set total number of balls trough can hold
521'   (Public) .EntrySw          - Set switch number for trough entry (if any) - eg. Outhole
522'   (Public) .AddSw            - Assign a switch at a specific slot
523'   (Public) .InitSwitches     - Set trough switches using an array, from exit slot back toward entrance.
524'   (Public) .InitExit         - Setup exit kicker, force and direction
525'   (Public) .InitExitVariance - Modify exit kick direction and force (+/-, min force = 1)
526'   (Public) .InitEntrySounds  - Sounds to play when a ball enters the trough
527'   (Public) .InitExitSounds   - Sounds to play when the exit kicker fires
528'   (Public) .CreateEvents     - Auto-generate hit events for VP entry kicker(s) associated with this trough
529'   (Public) .MaxBallsPerKick  - Set maximum number of balls to kick out (default 1)
530'   (Public) .MaxSlotsPerKick  - Set maximum slots from which to get balls when kicking out (default 1)
531'   (Public) .Balls            - Get current balls in trough, or set initial number of balls in trough
532'   (Public) .BallsPending     - Get number of balls waiting in trough entry
533'   (Public) .Reset            - Reset and update all trough switches
534'   (Friend) .Update           - Called from vpmTimer to update ball positions and switches
535'   (Public) .AddBall          - Add a ball to the trough from a kicker.  If kicker is the exit kicker, stacks ball at exit.
536'   (Public) .SolIn            - Solenoid handler for entry solenoid
537'   (Public) .SolOut           - Solenoid handler for exit solenoid
538'
539' cvpmSaucer (Create as many as needed)
540'   (Public) .InitKicker       - Setup main kicker, switch, exit direction and force (including Z force)
541'   (Public) .InitExitVariance - Modify kick direction and force (+/-, min force = 1)
542'   (Public) .InitAltKick      - Set alternate direction and force (including Z force) - for saucers with two kickers
543'   (Public) .InitSounds       - Sounds to play when a ball enters the saucer or the kicker fires
544'   (Public) .CreateEvents     - Auto-generate hit event for VP kicker(s) associated with this saucer
545'   (Public) .AddBall          - Add a ball to the saucer from a kicker.
546'   (Public) .HasBall          - True if the saucer is occupied.
547'   (Public) .solOut           - Fire the primary exit kicker.  Ejects ball if one is present.
548'   (Public) .solOutAlt        - Fire the secondary exit kicker.  Ejects ball with alternate forces if present.
549'
550' cvpmBallStack (DEPRECATED, but create as many as needed)
551'   (Public) .InitSw        - init switches used in stack
552'   (Public) .InitSaucer    - init saucer
553'   (Public) .InitNoTrough  - init a single ball, no trough handler
554'   (Public) .InitKick      - init exit kicker
555'   (Public) .InitAltKick   - init second kickout direction
556'   (Public) .CreateEvents  - Create addball events for kickers
557'   (Public) .KickZ         - Z axis kickout angle (radians)
558'   (Public) .KickBalls     - Maximum number of balls kicked out at the same time
559'   (Public) .KickForceVar  - Initial ExitKicker Force value varies by this much (+/-, minimum force = 1)
560'   (Public) .KickAngleVar  - ExitKicker Angle value varies by this much (+/-)
561'   (Public) .BallColour    - Set ball colour
562'   (Public) .TempBallImage  - Set ball image for next ball only
563'   (Public) .TempBallColour - Set ball colour for next ball only
564'   (Public) .BallImage     - Set ball image
565'   (Public) .InitAddSnd    - Sounds when ball enters stack
566'   (Public) .InitEntrySnd  - Sounds for Entry kicker
567'   (Public) .InitExitSnd   - Sounds for Exit kicker
568'   (Public) .AddBall       - add ball in "kicker" to stack
569'   (Public) .SolIn         - Solenoid handler for entry solenoid
570'   (Public) .EntrySol_On   - entry solenoid fired
571'   (Public) .SolOut        - Solenoid handler for exit solenoid
572'   (Public) .SolOutAlt     - Solenoid handler for exit solenoid 2nd direction
573'   (Public) .ExitSol_On    - exit solenoid fired
574'   (Public) .ExitAltSol_On - 2nd exit solenoid fired
575'   (Public) .Balls         - get/set number of balls in stack (default)
576'   (Public) .BallsPending  - get number of balls waiting to come in to stack
577'   (Public) .IsTrough      - Specify that this is the main ball trough
578'   (Public) .Reset         - reset and update all ballstack switches
579'   (Friend) .Update        - Update ball positions (from vpmTimer class)
580'  Obsolete
581'   (Public) .SolExit       - exit solenoid handler
582'   (Public) .SolEntry      - Entry solenoid handler
583'   (Public) .InitProxy     - Init proxy switch
584
585' cvpmNudge (Object = vpmNudge)
586'   Hopefully we can add a real pendulum simulator in the future
587'   (Public)  .TiltSwitch   - set tilt switch
588'   (Public)  .Senitivity   - Set tiltsensitivity (0-10)
589'   (Public)  .TiltObj      - Set objects affected by tilt
590'   (Public)  .DoNudge dir,power  - Nudge table
591'   (Public)  .SolGameOn    - Game On solenoid handler
592'   (Private) .Update       - Handle tilting
593'
594' cvpmDropTarget (create as many as needed)
595'   (Public)  .InitDrop     - initialise DropTarget bank
596'   (Public)  .CreateEvents - Create Hit events
597'   (Public)  .InitSnd      - sound to use for targets
598'   (Public)  .AnyUpSw      - Set AnyUp switch
599'   (Public)  .AllDownSw    - Set all down switch
600'   (Public)  .AllDown      - All targets down?
601'   (Public)  .Hit          - A target had been hit
602'   (Public)  .SolHit       - Solenoid handler for dropping a target
603'   (Public)  .SolUnHit     - Solenoid handler for raising a target
604'   (Public)  .SolDropDown  - Solenoid handler for Bank down
605'   (Public)  .SolDropUp    - Solenoid handler for Bank reset
606'   (Public)  .DropSol_On   - Reset target bank
607'   (Friend)  .SetAllDn     - check alldown & anyup switches
608'
609' cvpmMagnet (create as many as needed)
610'   (Public)  .InitMagnet   - initialise magnet
611'   (Public)  .CreateEvents - Create Hit/Unhit events
612'   (Public)  .Solenoid     - Set solenoid that controls magnet
613'   (Public)  .GrabCenter   - Magnet grabs ball at center
614'   (Public)  .MagnetOn     - Turn magnet on and off
615'   (Public)  .X            - Move magnet
616'   (Public)  .Y            - Move magnet
617'   (Public)  .Strength     - Change strength
618'   (Public)  .Size         - Change magnet reach
619'   (Public)  .AddBall      - A ball has come within range
620'   (Public)  .RemoveBall   - A ball is out of reach for the magnet
621'   (Public)  .Balls        - Balls currently within magnets reach
622'   (Public)  .AttractBall  - attract ball to magnet
623'   (Private) .Update       - update all balls (called from timer)
624'   (Private) .Reset        - handle emulation reset
625'  Obsolete
626'   (Public)  .Range        - Change magnet reach
627
628' cvpmTurnTable (create as many as needed)
629'   (Public)  .InitTurnTable - initialise turntable
630'   (Public)  .CreateEvents  - Create Hit/Unhit events
631'   (Public)  .MaxSpeed      - Maximum speed
632'   (Public)  .SpinUp        - Speedup acceleration
633'   (Public)  .SpinDown      - Retardation
634'   (Public)  .Speed         - Current speed
635'   (Public)  .MotorOn       - Motor On/Off
636'   (Public)  .SpinCW        - Control direction
637'   (Public)  .SolMotorState - Motor on/off solenoid handler
638'   (Public)  .AddBall       - A ball has come withing range
639'   (Public)  .RemoveBall    - A ball is out of reach for the magnet
640'   (Public)  .Balls         - Balls currently within magnets reach
641'   (Public)  .AffectBall    - affect a ball
642'   (Private) .Update        - update all balls (called from timer)
643'   (Private) .Reset         - handle emulation reset
644
645' cvpmMech (create as many as needed)
646'   (Public)  .Sol1, Sol2    - Controlling solenoids
647'   (Public)  .MType         - type of mechanics
648'   (Public)  .Length, Steps
649'   (Public)  .Acc, Ret      - Acceleration, retardation
650'   (Public)  .AddSw         - Automatically controlled switches
651'   (Public)  .AddPulseSw    - Automatically pulsed switches
652'   (Public)  .Callback      - Update graphics function
653'   (Public)  .Start         - Start mechanics handler
654'   (Public)  .Position      - Current position
655'   (Public)  .Speed         - Current Speed
656'   (Private) .Update
657'   (Private) .Reset
658'
659' cvpmCaptiveBall (create as many as needed)
660'   (Public)  .InitCaptive   - Initialise captive balls
661'   (Public)  .CreateEvents  - Create events for captive ball
662'   (Public)  .ForceTrans    - Amount of force tranferred to captive ball (0-1)
663'   (Public)  .MinForce      - Minimum force applied to the ball
664'   (Public)  .NailedBalls   - Number of "nailed" balls infront of captive ball
665'   (Public)  .RestSwitch    - Switch activated when ball is in rest position
666'   (Public)  .Start         - Create moving ball etc.
667'   (Public)  .TrigHit       - trigger in front of ball hit (or unhit)
668'   (Public)  .BallHit       - Wall in front of ball hit
669'   (Public)  .BallReturn    - Captive ball has returned to kicker
670'   (Private) .Reset
671'
672' cvpmVLock (create as many as needed)
673'   (Public)  .InitVLock     - Initialise the visible ball stack
674'   (Public)  .ExitDir       - Balls exit angle (like kickers)
675'   (Public)  .ExitForce     - Force of balls kicked out
676'   (Public)  .KickForceVar  - Vary kickout force
677'   (Public)  .InitSnd       - Sounds to make on kickout
678'   (Public)  .Balls         - Number of balls in Lock
679'   (Public)  .SolExit       - Solenoid event
680'   (Public)  .CreateEvents  - Create events needed
681'   (Public)  .TrigHit       - called from trigger hit event
682'   (Public)  .TrigUnhit     - called from trigger unhit event
683'   (Public)  .KickHit       - called from kicier hit event
684'
685' cvpmDips (create as many as needed) => (Dip Switch And/Or Table Options Menu)
686'   (Public)  .AddForm       - create a form (AKA dialogue)
687'   (Public)  .AddChk        - add a chckbox
688'   (Public)  .AddChkExtra   -   -  "" -     for non-dip settings
689'   (Public)  .AddFrame      - add a frame with checkboxes or option buttons
690'   (Public)  .AddFrameExtra -  - "" - for non-dip settings
691'   (Public)  .AddLabel      - add a label (text string)
692'   (Public)  .ViewDips      - Show form
693'   (Public)  .ViewDipsExtra -  - "" -  with non-dip settings
694'
695' cvpmImpulseP (create as many as needed) => (Impulse Plunger Object using a Trigger to Plunge Manual/Auto)
696'   (Public)  .InitImpulseP - Initialise Impulse Plunger Object (Trigger, Plunger Power, Time to Full Plunge [0 = Auto])
697'   (Public)  .CreateEvents - Create Hit/Unhit events
698'   (Public)  .Strength     - Change plunger strength
699'   (Public)  .Time         - Change plunger time (in seconds) to full plunger strength (0 = Auto Plunger)
700'   (Public)  .Pullback     - Pull the plunger back
701'   (Public)  .Fire	    - Fires / Releases the Plunger (Manual or Auto depending on Timing Value given)
702'   (Public)  .AutoFire	    - Fires / Releases the Plunger at Maximum Strength +/- Random variation (i.e. Instant Auto)
703'   (Public)  .Switch	    - Switch Number to activate when ball is sitting on plunger trigger (if any)
704'   (Public)  .Random       - Sets the multiplier level of random variance to add (0 = No Variance / Default) 
705'   (Public)  .InitEntrySnd - Plays Sound as Plunger is Pulled Back
706'   (Public)  .InitExitSnd  - Plays Sound as Plunger is Fired (WithBall,WithoutBall)
707'
708' Generic solenoid handlers:
709' --------------------------
710' vpmSolFlipper flipObj1, flipObj2  		- "flips flippers". Set unused to Nothing
711' vpmSolFlip2   flipObj1, flipObj2, flipSpeedUp, flipSpeedDn, sndOn).  Set unused to Nothing
712' vpmSolDiverter divObj, sound      		- open/close diverter (flipper) with/without sound
713' vpmSolWall wallObj, sound            		- Raise/Drop wall with/without sound
714' vpmSolToggleWall wall1, wall2, sound		- Toggle between two walls
715' vpmSolToggleObj obj1,obj2,sound   		- Toggle any objects
716' vpmSolAutoPlunger plungerObj, var, enabled  	- Autoplunger/kickback
717' vpmSolAutoPlungeS plungerObj, sound, var, enabled - Autoplunger/kickback With Specified Sound To Play
718' vpmSolGate obj, sound             		- Open/close gate
719' vpmSolSound sound                 		- Play sound only
720' vpmFlasher flashObj               		- Flashes flasher
721'
722' Generating events:
723' ------------------
724' vpmCreateEvents
725' cpmCreateLights
726'
727' Variables declared (to be filled in):
728' ---------------------------------------
729' SolCallback()  - handler for each solenoid
730' Lights()       - Lamps
731'
732' Constants used (must be defined):
733' ---------------------------------
734' UseSolenoids   - Update solenoids
735' MotorCallback  - Called once every update for mechanics or custom sol handler
736' UseLamps       - Update lamps
737' LampCallback   - Sub to call after lamps are updated
738'                  (or every update if UseLamps is false)
739' GICallback     - Sub to call to update GI strings
740' GICallback2    - Sub to call to update GI strings
741' SFlipperOn     - Flipper activate sound
742' SFlipperOff    - Flipper deactivate sound
743' SSolenoidOn    - Solenoid activate sound
744' SSolenoidOff   - Solenoid deactivate sound
745' SCoin          - Coin Sound
746' ExtraKeyHelp   - Game specific keys in help window
747'
748' Exported variables:
749' -------------------
750' vpmTimer      - Timer class for PulseSwitch etc
751' vpmNudge      - Class for table nudge handling
752'-----------------------------------------------------
753Private Function PinMAMEInterval
754        If VPBuildVersion >= 10200 Then
755                PinMAMEInterval = -1 ' VP10.2 introduced special frame-sync'ed timers
756        Else
757            If VPBuildVersion >= 10000 Then
758                PinMAMEInterval = 3  ' as old VP9 timers pretended to run at 1000Hz but actually did only a max of 100Hz (e.g. corresponding nowadays to interval=10), we do something inbetween for VP10+ by default
759            Else
760                PinMAMEInterval = 1
761            End If
762        End If
763End Function
764
765Private Const conStackSw    = 8  ' Stack switches
766Private Const conMaxBalls   = 13 ' Because of Apollo 13
767Private Const conMaxTimers  = 20 ' Spinners can generate a lot of timers
768Private Const conTimerPulse = 40 ' Timer runs at 25Hz
769Private Const conFastTicks  = 4  ' Fast is 4 times per timer pulse
770Private Const conMaxSwHit   = 5  ' Don't stack up more than 5 events for each switch
771
772' DEPRECATED Flipper constants:
773Private Const conFlipRetStrength = 0.01  ' Flipper return strength
774Private Const conFlipRetSpeed    = 0.137 ' Flipper return speed
775
776Function CheckScript(file) 'Checks Tables and Scripts directories for specified vbs file, and if it exitst, will load it.
777	CheckScript = False
778  On Error Resume Next
779	Dim TablesDirectory:TablesDirectory = Left(UserDirectory,InStrRev(UserDirectory,"\",InStrRev(UserDirectory,"\")-1))&"Tables\"
780	Dim ScriptsDirectory:ScriptsDirectory = Left(UserDirectory,InStrRev(UserDirectory,"\",InStrRev(UserDirectory,"\")-1))&"Scripts\"
781	dim check:Set check = CreateObject("Scripting.FileSystemObject")
782	If check.FileExists(tablesdirectory & file) Or check.FileExists(scriptsdirectory & file) Or check.FileExists(file) Then CheckScript = True
783  On Error Goto 0
784End Function
785
786Function LoadScript(file) 'Checks Tables and Scripts directories for specified vbs file, and if it exitst, will load it.
787	LoadScript = False
788  On Error Resume Next
789	If CheckScript(file) Then ExecuteGlobal GetTextFile(file):LoadScript = True
790  On Error Goto 0
791End Function
792
793' Dictionary
794' At one point, Microsoft had made Scripting.Dictionary "unsafe for scripting", but it's
795' been a long time since that was true.  So now, to maintain compatibility with all tables
796' and scripts that use cvpmDictionary, this class is now a simple wrapper around Microsoft's
797' more efficient implementation.
798Class cvpmDictionary
799    Private mDict
800	Private Sub Class_Initialize : Set mDict = CreateObject("Scripting.Dictionary") : End Sub
801
802    ' DEPRECATED: MS Dictionaries are not index-based.  Use "Exists" method instead.
803	Private Function FindKey(aKey)
804		Dim ii, key : FindKey = -1
805		If mDict.Count > 0 Then
806		    ii = 0
807		    For Each key In mDict.Keys
808		        If key = aKey Then FindKey = ii : Exit Function
809			Next
810		End If
811	End Function
812
813	Public Property Get Count : Count = mDict.Count : End Property
814
815	Public Property Get Item(aKey)
816	    Item = Empty
817	    If mDict.Exists(aKey) Then
818	        If IsObject(mDict(aKey)) Then
819	            Set Item = mDict(aKey)
820	        Else
821	            Item = mDict(aKey)
822	        End If
823	    End If
824	End Property
825
826	Public Property Let Item(aKey, aData)
827	    If IsObject(aData) Then
828	        Set mDict(aKey) = aData
829	    Else
830	        mDict(aKey) = aData
831	    End If
832	End Property
833
834	Public Property Set Key(aKey)
835	    ' This function is (and always has been) a no-op.  Previous definition
836	    ' just looked up aKey in the keys list, and if found, set the key to itself.
837	End Property
838
839	Public Sub Add(aKey, aItem)
840	    If IsObject(aItem) Then
841	        Set mDict(aKey) = aItem
842	    Else
843	        mDict(aKey) = aItem
844	    End If
845	End Sub
846
847	Public Sub Remove(aKey)      : mDict.Remove(aKey)          : End Sub
848	Public Sub      RemoveAll    : mDict.RemoveAll             : End Sub
849	Public Function Exists(aKey) : Exists = mDict.Exists(aKey) : End Function
850	Public Function Items        : Items  = mDict.Items        : End Function
851	Public Function Keys         : Keys   = mDict.Keys         : End Function
852End Class
853
854'--------------------
855'       Timer
856'--------------------
857Class cvpmTimer
858	Private mQue, mNow, mTimers
859	Private mSlowUpdates, mFastUpdates, mResets, mFastTimer
860
861	Private Sub Class_Initialize
862		ReDim mQue(conMaxTimers) : mNow = 0 : mTimers = 0
863		Set mSlowUpdates = New cvpmDictionary
864		Set mFastUpdates = New cvpmDictionary
865		Set mResets      = New cvpmDictionary
866	End Sub
867
868	Public Sub InitTimer(aTimerObj, aFast)
869		If aFast Then
870			Set mFastTimer = aTimerObj
871			aTimerObj.TimerInterval = conTimerPulse \ conFastTicks
872			aTimerObj.TimerEnabled = False
873			vpmBuildEvent aTimerObj, "Timer", "vpmTimer.FastUpdate"
874		Else
875			aTimerObj.Interval = conTimerPulse : aTimerObj.Enabled = True
876			vpmBuildEvent aTimerObj, "Timer", "vpmTimer.Update"
877		End If
878	End Sub
879
880	Sub EnableUpdate(aClass, aFast, aEnabled)
881		On Error Resume Next
882		If aFast Then
883			If aEnabled Then mFastUpdates.Add aClass, 0 : Else mFastUpdates.Remove aClass
884			mFastTimer.TimerEnabled = mFastUpdates.Count > 0
885		Else
886			If aEnabled Then mSlowUpdates.Add aClass, 0 : Else mSlowUpdates.Remove aClass
887		End If
888	End Sub
889
890	Public Sub Reset
891		Dim obj : For Each obj In mResets.Keys : obj.Reset : Next
892	End Sub
893
894	Public Sub FastUpdate
895		Dim obj : For Each obj In mFastUpdates.Keys : obj.Update : Next
896	End Sub
897
898	Public Sub Update
899		Dim ii, jj, sw, obj, mQuecopy
900
901		For Each obj In mSlowUpdates.Keys : obj.Update : Next
902		If mTimers = 0 Then Exit Sub
903		mNow = mNow + 1 : ii = 1
904
905		Do While ii <= mTimers
906			If mQue(ii)(0) <= mNow Then
907				If mQue(ii)(1) = 0 Then
908					If isObject(mQue(ii)(3)) Then
909						Call mQue(ii)(3)(mQue(ii)(2))
910					ElseIf varType(mQue(ii)(3)) = vbString Then
911						If mQue(ii)(3) > "" Then Execute mQue(ii)(3) & " " & mQue(ii)(2) & " "
912					End If
913					mTimers = mTimers - 1
914					For jj = ii To mTimers : mQue(jj) = mQue(jj+1) : Next : ii = ii - 1
915				ElseIf mQue(ii)(1) = 1 Then
916					mQuecopy = mQue(ii)(2)
917					Controller.Switch(mQuecopy) = False
918					mQue(ii)(0) = mNow + mQue(ii)(4) : mQue(ii)(1) = 0
919				Else '2
920					mQuecopy = mQue(ii)(2)
921					Controller.Switch(mQuecopy) = True
922					mQue(ii)(1) = 1
923				End If
924			End If
925			ii = ii + 1
926		Loop
927	End Sub
928
929	Public Sub AddResetObj(aObj)  : mResets.Add aObj, 0 : End Sub
930
931	Public Sub PulseSw(aSwNo) : PulseSwitch aSwNo, 0, 0 : End Sub
932
933	Public Default Sub PulseSwitch(aSwNo, aDelay, aCallback)
934		Dim ii, count, last
935		count = 0
936		For ii = 1 To mTimers
937			If mQue(ii)(1) > 0 And mQue(ii)(2) = aSwNo Then count = count + 1 : last = ii
938		Next
939		If count >= conMaxSwHit Or mTimers = conMaxTimers Then Exit Sub
940		mTimers = mTimers + 1 : mQue(mTimers) = Array(mNow, 2, aSwNo, aCallback, aDelay\conTimerPulse)
941		If count Then mQue(mTimers)(0) = mQue(last)(0) + mQue(last)(1)
942	End Sub
943
944	Public Sub AddTimer(aDelay, aCallback)
945		If mTimers = conMaxTimers Then Exit Sub
946		mTimers = mTimers + 1
947		mQue(mTimers) = Array(mNow + aDelay \ conTimerPulse, 0, 0, aCallback)
948	End Sub
949	
950	Public Sub AddTimer2(aDelay, aCallback, aID)
951		If mTimers = conMaxTimers Then Exit Sub
952		mTimers = mTimers + 1
953		mQue(mTimers) = Array(mNow + aDelay \ conTimerPulse, 0, aID, aCallback)
954	End Sub
955End Class
956
957'--------------------
958'     Trough
959'--------------------
960Class cvpmTrough
961    ' Takes over for older cvpmBallStack in "trough mode".  Theory of operation:
962    ' A trough can hold up to N balls, and has N*2 "slots".  A ball effectively takes
963    ' up two slots, so no two adjacent slots (0 and 1) can be occupied at the same time.
964    ' Switches are assigned to even slots only, which means that as balls move through
965    ' the trough, each switch is allowed to flip between open and closed.
966    ' Slot 0 is the exit, and can have additional balls "stacked" on it, simulating balls
967    ' falling onto the exit kicker instead of coming in from the entrance.  Extra balls
968    ' can be queued up at the entrance, and will enter the trough only if there's room
969    ' for them.
970
971    Private mSlot(), mSw(), mEntrySw
972    Private mBallsInEntry, mMaxBallsPerKick, mStackExitBalls
973    Private mExitKicker, mExitDir, mExitForce, mDirVar, mForceVar
974    Private mSounds
975
976    ' If you want to see what the trough is doing internally, add a TextBox to your table
977    ' named "DebugBox" (recommend Courier New or FixedSys at a small font size) and set
978    ' this variable to true via .isDebug = True.
979	Private mDebug
980
981    Private Sub Class_Initialize
982        Dim ii
983
984        ReDim mSw(conMaxBalls), mSlot(conMaxBalls * 2)
985        For ii = 0 to UBound(mSlot) : mSlot(ii) = 0 : Next   ' All slots empty to start
986        For ii = 0 to UBound(mSw)   : mSw(ii) = 0   : Next   ' All switches unassigned to start.
987        mEntrySw = 0
988
989        Set mExitKicker = Nothing
990        mExitDir = 0 : mExitForce = 1 : mDirVar = 0 : mForceVar = 0
991        mBallsInEntry = 0 : mMaxBallsPerKick = 1 : mStackExitBalls = 1
992
993        Set mSounds = New cvpmDictionary
994
995		mDebug = False
996
997        If Not IsObject(vpmTrough) Then Set vpmTrough = Me
998    End Sub
999
1000    Public Property Let IsTrough(aYes)
1001        If aYes Then
1002            Set vpmTrough = Me
1003        ElseIf Me Is vpmTrough Then
1004            Set vpmTrough = Nothing
1005        End If
1006    End Property
1007
1008    Public Property Get IsTrough
1009        IsTrough = (Me Is vpmTrough)
1010    End Property
1011
1012    ' Initialization
1013
1014    Public Property Let isDebug(enabled) : mDebug = enabled : End Property
1015
1016    Public Property Let Size(aSize)
1017        Dim oldSize, newSize, ii
1018        oldSize = UBound(mSw)
1019        newSize = vpMax(1, aSize)
1020
1021        ReDim Preserve mSlot(newSize * 2)
1022        ReDim Preserve mSw(newSize)
1023        For ii = oldSize+1 To newSize : mSw(ii) = 0 : Next
1024        For ii = (oldSize*2) + 1 to (newSize*2) : mSlot(ii) = 0 : Next
1025    End Property
1026    Public Property Get Size : Size = UBound(mSw) : End Property
1027
1028    ' Set EntrySw = 0 if you want balls to just fall into the trough automatically.
1029    ' Set it to a real switch number to indicate that a ball is occupying an entry kicker.
1030    ' The ROM in the controller is then responsible for kicking the ball into the trough.
1031    Public Property Let EntrySw(swNo) : mEntrySw = swNo : End Property
1032
1033    ' Assign switches, starting from slot 0 and going to entrance.
1034    ' This sub allows you to pass in as many switches as you wish.
1035    Public Sub InitSwitches(switchArray)
1036        If Not IsArray(switchArray) Then
1037            Err.Raise 17, "cvpmTrough.InitSwitches: Input must be an array."
1038        End If
1039
1040        Dim ii
1041        For ii = 0 to UBound(mSw)
1042            If ii > UBound(switchArray) Then
1043                mSw(ii) = 0
1044            Else
1045                mSw(ii) = switchArray(ii)
1046            End If
1047        Next
1048    End Sub
1049
1050    ' Alternative: Assign a switch to a specific slot.
1051    Public Sub AddSw(slotNo, swNo)
1052        If slotNo < 0 OR slotNo > UBound(mSw) Then Exit Sub
1053        mSw(slotNo) = swNo
1054    End Sub
1055
1056    ' MaxBallsPerKick: Kick up to N balls total per exit kick.  Balls are only kicked from Slot 0.
1057    ' StackExitBalls: Automatically stack up to N balls in Slot 0 regardless of where they came from.
1058
1059    ' Example: Subway where exit kicker is on the same level as the trough and a ball can
1060    ' come in from the exit: StackExitBalls = 1, MaxBallsPerKick = 2.  If Slot 0 has 1
1061    ' ball and Slot 1 is occupied, only one ball will be kicked.  If Slot 0 has 2 or more
1062    ' balls, it'll kick out 2 balls.
1063
1064    ' Example: Twilight Zone Slot Kicker: Kicker is below trough, so if a ball is in the
1065    ' exit chute, another ball can fall into the chute as well whether it came in from the
1066    ' exit (Slot Machine) or any other entrance (Piano, Camera).  In both cases, the kicker
1067    ' will eject 2 balls at once.  Set StackExitBalls = 2, maxBallsPerKick = 2 to simulate.
1068
1069    Public Property Let MaxBallsPerKick(n) : mMaxBallsPerKick = vpMax(1, n) : End Property
1070    Public Property Let StackExitBalls(n) : mStackExitBalls = vpMax(1, n) : End Property
1071
1072    Public Sub InitExit(aKicker, aDir, aForce)
1073        If TypeName(aKicker) <> "Kicker" Then
1074            Err.Raise 17, "cvpmTrough.InitExit: Cannot use object of type '" & TypeName(aKicker) & "'."
1075        End If
1076
1077        Set mExitKicker = aKicker
1078        mExitDir = aDir
1079        mExitForce = vpMax(1, aForce)
1080    End Sub
1081
1082    Public Sub InitExitVariance(aDirVar, aForceVar)
1083        mDirVar = aDirVar
1084        mForceVar = aForceVar
1085    End Sub
1086
1087    ' Setup sounds
1088    Public Sub InitEntrySounds(addSound, entrySoundEmpty, entrySoundBall)
1089        mSounds.Item("add") = addSound
1090        mSounds.Item("entry") = entrySoundEmpty
1091        mSounds.Item("entryBall") = entrySoundBall
1092    End Sub
1093
1094    Public Sub InitExitSounds(exitSoundEmpty, exitSoundBall)
1095        mSounds.Item("exit") = exitSoundEmpty
1096        mSounds.Item("exitBall") = exitSoundBall
1097    End Sub
1098
1099    ' Start trough with this many balls
1100    Public Property Let Balls(numBalls)
1101        Dim ii, ballsAdded
1102
1103        ' First clear all slots.
1104        For ii = 0 to UBound(mSlot) : mSlot(ii) = 0 : Next
1105
1106        ' Now put a ball in each even-numbered slot up to the number requested.
1107        ' First, stack exit slot.  (Note, we may get a negative number. vpMin/vpMax prevent that.)
1108        mSlot(0) = vpMax(0, vpMin(mStackExitBalls, numBalls))
1109        ballsAdded = mSlot(0)
1110
1111        ' Fill remaining slots.
1112        For ii = 1 to vpMin(numBalls - mSlot(0), UBound(mSw))
1113            mSlot(ii*2) = 1
1114            ballsAdded = ballsAdded + 1
1115        Next
1116
1117        ' If we asked to put more balls in the trough than it can handle, queue up the rest.
1118        mBallsInEntry = vpMax(0, numBalls-ballsAdded)
1119
1120        UpdateTroughSwitches
1121    End Property
1122
1123    Public Property Get Balls
1124        Balls = 0
1125        Dim ii : For ii = 0 to UBound(mSlot) : Balls = Balls + mSlot(ii) : Next
1126    End Property
1127
1128    Public Property Get BallsPending : BallsPending = mBallsInEntry : End Property
1129
1130    ' Auto-generate events for any entry kickers (eg. outhole, TZ Camera and Piano, etc.)
1131    ' Accepts a single kicker, an Array, or a Collection.
1132	Public Sub CreateEvents(aName, aKicker)
1133		Dim obj, tmp
1134		If Not vpmCheckEvent(aName, Me) Then Exit Sub
1135		vpmSetArray tmp, aKicker
1136		For Each obj In tmp
1137			If isObject(obj) Then
1138				vpmBuildEvent obj, "Hit", aName & ".AddBall Me"
1139			Else
1140				vpmBuildEvent mKicker, "Hit", aName & ".AddBall Me"
1141			End If
1142		Next
1143	End Sub
1144
1145    ' VPM Update management
1146
1147	Private Property Let NeedUpdate(aEnabled) : vpmTimer.EnableUpdate Me, False, aEnabled : End Property
1148
1149	Public Sub Reset
1150		Dim mEntrySwcopy
1151		UpdateTroughSwitches
1152		If mEntrySw Then
1153			mEntrySwcopy = mEntrySw
1154			Controller.Switch(mEntrySwcopy) = (mBallsInEntry > 0)
1155		End If
1156	End Sub
1157
1158	Public Sub Update
1159		NeedUpdate = AdvanceBalls
1160		UpdateTroughSwitches
1161    End Sub
1162
1163    ' Switch and slot management
1164
1165    Private Sub setSw(slotNo, enabled)
1166        Dim mSwcopy
1167        If mSw(slotNo) Then
1168            mSwcopy = mSw(slotNo)
1169            Controller.Switch(mSwcopy) = enabled
1170        End If
1171    End Sub
1172
1173    Private Sub UpdateTroughSwitches
1174		Dim ii, mSwcopy
1175		For ii = 0 to UBound(mSw)
1176			If mSw(ii) Then
1177				mSwcopy = mSw(ii)
1178				Controller.Switch(mSwcopy) = (mSlot(ii*2) > 0)
1179			End If
1180		Next
1181		If mDebug Then UpdateDebugBox
1182    End Sub
1183
1184	Private Sub UpdateDebugBox   ' Requires a textbox named DebugBox
1185		Dim str, ii, mSwcopy
1186		str = "Entry: " & mBallsInEntry & " (sw" & mEntrySw & " = "
1187		If mEntrySw > 0 Then
1188			mSwcopy = mEntrySw
1189			str = str & Controller.Switch(mSwcopy)
1190		Else
1191			str = str & "n/a"
1192		End If
1193		str = str & ")" & vbNewLine
1194
1195		str = str & "["
1196		For ii = UBound(mSlot) To 0 Step -1 : str = str & mSlot(ii) : Next
1197		str = str & "]" & vbNewLine
1198
1199		str = str & "["
1200		For ii = UBound(mSlot) To 0 Step -1
1201			If ii Mod 2 = 0 Then
1202				If mSw(ii\2) Then
1203					mSwcopy = mSw(ii\2)
1204					If Controller.Switch(mSwcopy) Then
1205						str = str & "1"
1206					Else
1207						str = str & "0"
1208					End If
1209				Else
1210					str = str & "-"
1211				End If
1212			Else
1213				str = str & " "
1214			End If
1215		Next
1216		str = str & "]"
1217
1218		DebugBox.Text = str
1219	End Sub
1220
1221    Private Function AdvanceBalls
1222        Dim ii, canMove, maxSlot
1223        maxSlot = UBound(mSlot)
1224        AdvanceBalls = False
1225
1226        ' Move balls through slots, one slot at a time.
1227        For ii = 0 to maxSlot
1228            If mSlot(ii) Then               ' Ball in this slot.
1229				canMove = False
1230
1231                ' Can this ball move?  (Slot 0 = no)
1232                If ii = 0 Then
1233                    ' Slot 0 never moves (except when ejected)
1234                    canMove = False
1235				ElseIf ii = 1 Then
1236					' Slot 1 automatically moves to Slot 0
1237					canMove = True
1238				ElseIf ii = 2 Then
1239				    ' Slot 2 moves if the number of balls in slot 0 is less than the stack target.
1240				    canMove = (mSlot(0) < mStackExitBalls)
1241				Else
1242					' Only move if there is no ball in ii-1 or ii-2.
1243					canMove = (mSlot(ii-2) = 0) AND (mSlot(ii-1) = 0)
1244				End If
1245
1246                If canMove Then
1247                    mSlot(ii) = mSlot(ii) - 1
1248                    mSlot(ii-1) = mSlot(ii-1) + 1
1249                    AdvanceBalls = True       ' Mark balls as having moved.
1250                End If
1251            End If
1252        Next
1253
1254        ' If balls are supposed to fall into the trough without going through a kicker,
1255        ' see if any balls are pending and try to add one automatically if so.
1256        If mBallsInEntry > 0 AND mEntrySw <= 0 Then
1257            AdvanceBalls = AddBallAtEntrance OR AdvanceBalls
1258        End If
1259    End Function
1260
1261    ' Ball management
1262
1263    Private Function AddBallAtEntrance
1264        Dim mSwcopy
1265        Dim maxSlot : maxSlot = UBound(mSlot)
1266        AddBallAtEntrance = False
1267
1268        ' Only add a ball if there's room for it at the entrance.
1269        ' If the trough is full (or the entrance is occupied), the ball will remain
1270        ' in the entry queue.  In a kicker-gated trough, the entry switch will remain
1271        ' pressed down, usually resulting in the machine retrying the load.  In a fall-in
1272        ' trough, the ball will just remain queued until the entrance opens up.
1273        If mSlot(maxSlot) = 0 AND mSlot(maxSlot-1) = 0 Then
1274            mSlot(maxSlot) = 1
1275            mBallsInEntry = vpMax(0, mBallsInEntry - 1)
1276            If mBallsInEntry = 0 AND mEntrySw Then
1277                mSwcopy = mEntrySw
1278                Controller.Switch(mSwcopy) = False
1279            End If
1280            AddBallAtEntrance = True
1281        End If
1282    End Function
1283
1284    Public Sub AddBall(aKicker)
1285        Dim mSwcopy
1286        Dim addDone : addDone = False
1287        If IsObject(aKicker) Then
1288            aKicker.DestroyBall
1289            If aKicker Is mExitKicker Then
1290                ' Ball fell in from exit.  Stack it up on Slot 0.
1291                mSlot(0) = mSlot(0) + 1
1292                NeedUpdate = True
1293                UpdateTroughSwitches
1294                addDone = True
1295            End If
1296        End If
1297
1298        If Not addDone Then
1299            ' Ball came in from entrance.  Queue it up for entry.
1300            mBallsInEntry = mBallsInEntry + 1
1301		If mEntrySw > 0 Then
1302			mSwcopy = mEntrySw
1303			' Trough has an entry kicker.  Ball will not enter trough
1304			' until the entry solenoid is fired.
1305			Controller.Switch(mSwcopy) = True
1306	    	End If
1307            NeedUpdate = True
1308	    End If
1309
1310		PlaySound mSounds.Item("add")
1311	End Sub
1312
1313    ' Use solCallback(solNo) on the trough entry kicker solenoid.
1314    Public Sub solIn(aEnabled)
1315        If aEnabled Then
1316            If mBallsInEntry > 0 Then
1317                NeedUpdate = AddBallAtEntrance
1318                PlaySound mSounds.Item("entryBall")
1319            Else
1320                PlaySound mSounds.Item("entry")
1321            End If
1322        End If
1323    End Sub
1324    Public Sub EntrySol_On : solIn(true) : End Sub
1325
1326    ' Use solCallback(solNo) on the trough exit kicker solenoid.
1327	Public Sub solOut(aEnabled)
1328        Dim iiBall, kDir, kForce, kBaseDir, ballsEjected
1329        ballsEjected = 0
1330
1331		If aEnabled Then
1332			For iiBall = 0 to (mMaxBallsPerKick - 1)
1333				kDir = (mExitDir + (Rnd - 0.5) * mDirVar)
1334				kForce = vpMax(1, mExitForce + (Rnd - 0.5) * mForceVar * (0.8 * iiBall))   ' Dampen force a bit on subsequent balls.
1335
1336				If mSlot(0) > 0 Then
1337					' Remove ball from this slot.
1338					mSlot(0) = mSlot(0) - 1
1339					If isObject(mExitKicker) Then
1340						vpmTimer.AddTimer ballsEjected*200, "vpmCreateBall(" & mExitKicker.Name & ").Kick " &_
1341							CInt(kDir) & "," & Replace(kForce,",",".") & ", 0 '"
1342					End If
1343
1344					ballsEjected = ballsEjected + 1
1345				End If
1346			Next
1347
1348			If ballsEjected > 0 Then
1349				PlaySound mSounds.Item("exitBall")
1350				UpdateTroughSwitches
1351				NeedUpdate = True
1352			Else
1353				PlaySound mSounds.Item("exit")
1354			End If
1355		End If
1356 	End Sub
1357 	Public Sub ExitSol_On : solOut(true) : End Sub
1358End Class
1359
1360'--------------------
1361'     Saucer
1362'--------------------
1363Class cvpmSaucer
1364    ' Takes over for older cvpmBallStack in "saucer mode".
1365
1366    Private mSw, mKicker, mExternalKicker
1367    Private mDir(1), mForce(1), mZForce(1), mDirVar, mForceVar
1368    Private mSounds
1369
1370    Private Sub Class_Initialize
1371        mSw = 0
1372
1373        mKicker = 0
1374        mExternalKicker = 0
1375        mDir(0) = 0 : mForce(0) = 1 : mZForce(0) = 0
1376        mDir(1) = 0 : mForce(1) = 1 : mZForce(1) = 0
1377        mDirVar = 0 : mForceVar = 0
1378
1379        Set mSounds = New cvpmDictionary
1380    End Sub
1381
1382    ' Initialization
1383
1384    Public Sub InitKicker(aKicker, aSw, aDir, aForce, aZForce)
1385        If TypeName(aKicker) <> "Kicker" Then
1386            Err.Raise 17, "cvpmSaucer.InitKicker: Cannot use object of type '" & TypeName(aKicker) & "'."
1387        End If
1388
1389        Set mKicker = aKicker
1390        mSw = aSw
1391        mDir(0) = aDir
1392        mForce(0) = vpMax(1, aForce)
1393        mZForce(0) = vpMax(0, aZForce)
1394    End Sub
1395
1396    Public Sub InitExitVariance(aDirVar, aForceVar)
1397        mDirVar = aDirVar
1398        mForceVar = aForceVar
1399    End Sub
1400
1401    ' Alternate kick params (simulates a saucer with two kickers)
1402    Public Sub InitAltKick(aDir, aForce, aZForce)
1403        mDir(1) = aDir
1404        mForce(1) = vpMax(1, aForce)
1405        mZForce(1) = vpMax(0, aZForce)
1406    End Sub
1407
1408    ' Setup sounds
1409    Public Sub InitSounds(addSound, exitSoundEmpty, exitSoundBall)
1410        mSounds.Item("add") = addSound
1411        mSounds.Item("exit") = exitSoundEmpty
1412        mSounds.Item("exitBall") = exitSoundBall
1413    End Sub
1414
1415    ' Generate hit event for the kicker(s) associated with this saucer.
1416    ' Accepts a single kicker, an Array, or a Collection.
1417	Public Sub CreateEvents(aName, aKicker)
1418		Dim obj, tmp
1419		If Not vpmCheckEvent(aName, Me) Then Exit Sub
1420		vpmSetArray tmp, aKicker
1421		For Each obj In tmp
1422			If isObject(obj) Then
1423				vpmBuildEvent obj, "Hit", aName & ".AddBall Me"
1424			Else
1425				vpmBuildEvent mKicker, "Hit", aName & ".AddBall Me"
1426			End If
1427		Next
1428	End Sub
1429
1430    ' Ball management
1431
1432    Public Sub AddBall(aKicker)
1433		Dim mSwcopy
1434		If isObject(aKicker) Then
1435			If aKicker Is mKicker Then
1436				mKicker.Enabled = False
1437				mExternalKicker = 0
1438			Else
1439				aKicker.Enabled = False
1440				Set mExternalKicker = aKicker
1441			End If
1442		Else
1443			mKicker.Enabled = False
1444			mExternalKicker = 0
1445		End If
1446
1447		If mSw Then
1448			mSwcopy = mSw
1449			Controller.Switch(mSwcopy) = True
1450		End If
1451		PlaySound mSounds.Item("add")
1452    End Sub
1453
1454    Public Property Get HasBall
1455        HasBall = False
1456        If IsObject(mExternalKicker) Then
1457            HasBall = True
1458        Else
1459            HasBall = Not mKicker.Enabled
1460        End If
1461    End Property
1462
1463    ' SolCallback solNo, "mySaucer.solOut"
1464    Public Sub solOut(aEnabled) : If aEnabled Then KickOut 0 : End If : End Sub
1465    Public Sub ExitSol_On : KickOut 0 : End Sub
1466
1467    ' SolCallback solNo, "mySaucer.solOutAlt"
1468    Public Sub solOutAlt(aEnabled) : If aEnabled Then KickOut 1 : End If : End Sub
1469    Public Sub ExitAltSol_On : KickOut 1 : End Sub
1470
1471    Private Sub KickOut(kickIndex)
1472        Dim mSwcopy
1473        If HasBall Then
1474            Dim kDir, kForce, kZForce
1475
1476            kDir = mDir(kickIndex) + (Rnd - 0.5)*mDirVar
1477            kForce = vpMax(1, mForce(kickIndex) + (Rnd - 0.5)*mForceVar)
1478            kZForce = mZForce(kickIndex)
1479
1480            If IsObject(mExternalKicker) Then
1481                ' Transfer ball to internal kicker and remove relationship
1482                vpmCreateBall mKicker
1483                mExternalKicker.DestroyBall
1484                mExternalKicker.Enabled = True
1485            Else
1486                mKicker.Enabled = True
1487            End If
1488
1489            mKicker.Kick kDir, kForce, kZForce
1490            If mSw Then
1491                mSwcopy = mSw
1492                Controller.Switch(mSwcopy) = False
1493            End If
1494            PlaySound mSounds.Item("exitBall")
1495        Else
1496            PlaySound mSounds.Item("exit")
1497        End If
1498    End Sub
1499End Class
1500
1501'--------------------
1502'     BallStack (DEPRECATED/LEGACY)
1503'     Known issues:
1504'     - Adding more balls than conMaxBalls will crash the script.
1505'     - If there are more balls in trough than are ever used in a game (eg. Bride of Pinbot),
1506'       one or more trough switches will be permanently stuck down and may result in a ROM test report.
1507'     - Trough does not handle stacking balls at exit.
1508'     - Saucer mode is essentially a hack on top of the trough logic.
1509'--------------------
1510Class cvpmBallStack
1511	Private mSw(), mEntrySw, mBalls, mBallIn, mBallPos(), mSaucer, mBallsMoving
1512	Private mInitKicker, mExitKicker, mExitDir, mExitForce
1513	Private mExitDir2, mExitForce2
1514	Private mEntrySnd, mEntrySndBall, mExitSnd, mExitSndBall, mAddSnd
1515	Public KickZ, KickBalls, KickForceVar, KickAngleVar
1516
1517	Private Sub Class_Initialize
1518		ReDim mSw(conStackSw), mBallPos(conMaxBalls)
1519		mBallIn = 0 : mBalls = 0 : mExitKicker = 0 : mInitKicker = 0 : mBallsMoving = False
1520		KickBalls = 1 : mSaucer = False : mExitDir = 0 : mExitForce = 0
1521		mExitDir2 = 0 : mExitForce2 = 0 : KickZ = 0 : KickForceVar = 0 : KickAngleVar = 0
1522		mAddSnd = 0 : mEntrySnd = 0 : mEntrySndBall = 0 : mExitSnd = 0 : mExitSndBall = 0
1523		vpmTimer.AddResetObj Me
1524	End Sub
1525
1526	Private Property Let NeedUpdate(aEnabled) : vpmTimer.EnableUpdate Me, False, aEnabled : End Property
1527
1528	Private Function SetSw(aNo, aStatus)
1529                Dim mSwcopy
1530                SetSw = False
1531                If HasSw(aNo) Then
1532                    mSwcopy = mSw(aNo)
1533                    Controller.Switch(mSwcopy) = aStatus
1534                    SetSw = True
1535                End If
1536	End Function
1537
1538	Private Function HasSw(aNo)
1539		HasSw = False : If aNo <= conStackSw Then If mSw(aNo) Then HasSw = True
1540	End Function
1541
1542	Public Sub Reset
1543		Dim mSwcopy
1544		Dim ii : If mBalls Then For ii = 1 to mBalls : SetSw mBallPos(ii), True : Next
1545		If mEntrySw And mBallIn > 0 Then
1546			mSwcopy = mEntrySw
1547			Controller.Switch(mSwcopy) = True
1548		End If
1549	End Sub
1550
1551	Public Sub Update
1552		Dim BallQue, ii, mSwcopy
1553		NeedUpdate = False : BallQue = 1
1554		For ii = 1 To mBalls
1555			If mBallpos(ii) > BallQue Then ' next slot available
1556				NeedUpdate = True
1557				If HasSw(mBallPos(ii)) Then ' has switch
1558					mSwcopy = mSw(mBallPos(ii))
1559					If Controller.Switch(mSwcopy) Then
1560						SetSw mBallPos(ii), False
1561					Else
1562						mBallPos(ii) = mBallPos(ii) - 1
1563						SetSw mBallPos(ii), True
1564					End If
1565				Else ' no switch. Move ball to first switch or occupied slot
1566					Do
1567						mBallPos(ii) = mBallPos(ii) - 1
1568					Loop Until SetSw(mBallPos(ii), True) Or mBallPos(ii) = BallQue
1569				End If
1570			End If
1571			BallQue = mBallPos(ii) + 1
1572		Next
1573	End Sub
1574
1575	Public Sub AddBall(aKicker)
1576		Dim mSwcopy
1577		If isObject(aKicker) Then
1578			If mSaucer Then
1579				If aKicker Is mExitKicker Then
1580					mExitKicker.Enabled = False : mInitKicker = 0
1581				Else
1582					aKicker.Enabled = False : Set mInitKicker = aKicker
1583				End If
1584			Else
1585				aKicker.DestroyBall
1586			End If
1587		ElseIf mSaucer Then
1588			mExitKicker.Enabled = False : mInitKicker = 0
1589		End If
1590		If mEntrySw Then
1591			mSwcopy = mEntrySw
1592			Controller.Switch(mSwcopy) = True : mBallIn = mBallIn + 1
1593		Else
1594			mBalls = mBalls + 1 : mBallPos(mBalls) = conStackSw + 1 : NeedUpdate = True
1595		End If
1596		PlaySound mAddSnd
1597	End Sub
1598
1599	' A bug in the script engine forces the "End If" at the end
1600	Public Sub SolIn(aEnabled)     : If aEnabled Then KickIn        : End If : End Sub
1601	Public Sub SolOut(aEnabled)    : If aEnabled Then KickOut False : End If : End Sub
1602	Public Sub SolOutAlt(aEnabled) : If aEnabled Then KickOut True  : End If : End Sub
1603	Public Sub EntrySol_On   : KickIn        : End Sub
1604	Public Sub ExitSol_On    : KickOut False : End Sub
1605	Public Sub ExitAltSol_On : KickOut True  : End Sub
1606
1607	Private Sub KickIn
1608		Dim mSwcopy
1609		If mBallIn Then PlaySound mEntrySndBall Else PlaySound mEntrySnd : Exit Sub
1610		mBalls = mBalls + 1 : mBallIn = mBallIn - 1 : mBallPos(mBalls) = conStackSw + 1 : NeedUpdate = True
1611		If mEntrySw And mBallIn = 0 Then
1612			mSwcopy = mEntrySw
1613			Controller.Switch(mSwcopy) = False
1614		End If
1615	End Sub
1616
1617	Private Sub KickOut(aAltSol)
1618		Dim ii,jj, kForce, kDir, kBaseDir
1619		If mBalls Then PlaySound mExitSndBall Else PlaySound mExitSnd : Exit Sub
1620		If aAltSol Then kForce = mExitForce2 : kBaseDir = mExitDir2 Else kForce = mExitForce : kBaseDir = mExitDir
1621		kForce = kForce + (Rnd - 0.5)*KickForceVar
1622		If mSaucer Then
1623			SetSw 1, False : mBalls = 0 : kDir = kBaseDir + (Rnd - 0.5)*KickAngleVar
1624			If isObject(mInitKicker) Then
1625				vpmCreateBall mExitKicker : mInitKicker.Destroyball : mInitKicker.Enabled = True
1626			Else
1627				mExitKicker.Enabled = True
1628			End If
1629			mExitKicker.Kick kDir, kForce, KickZ
1630		Else
1631			For ii = 1 To kickballs
1632				If mBalls = 0 Or mBallPos(1) <> ii Then Exit For ' No more balls
1633				For jj = 2 To mBalls ' Move balls in array
1634					mBallPos(jj-1) = mBallPos(jj)
1635				Next
1636				mBallPos(mBalls) = 0 : mBalls = mBalls - 1 : NeedUpdate = True
1637				SetSw ii, False
1638				If isObject(mExitKicker) Then
1639					If kForce < 1 Then kForce = 1
1640					kDir = kBaseDir + (Rnd - 0.5)*KickAngleVar
1641					vpmTimer.AddTimer (ii-1)*200, "vpmCreateBall(" & mExitKicker.Name & ").Kick " &_
1642					  CInt(kDir) & "," & Replace(kForce,",",".") & "," & Replace(KickZ,",",".") & " '"
1643				End If
1644				kForce = kForce * 0.8
1645			Next
1646		End If
1647	End Sub
1648
1649	Public Sub InitSaucer(aKicker, aSw, aDir, aPower)
1650		InitKick aKicker, aDir, aPower : mSaucer = True
1651		If aSw Then mSw(1) = aSw Else mSw(1) = aKicker.TimerInterval
1652	End Sub
1653
1654	Public Sub InitNoTrough(aKicker, aSw, aDir, aPower)
1655		InitKick aKicker, aDir, aPower : Balls = 1
1656		If aSw Then mSw(1) = aSw Else mSw(1) = aKicker.TimerInterval
1657		If Not IsObject(vpmTrough) Then Set vpmTrough = Me
1658	End Sub
1659
1660	Public Sub InitSw(aEntry, aSw1, aSw2, aSw3, aSw4, aSw5, aSw6, aSw7)
1661		mEntrySw = aEntry : mSw(1) = aSw1 : mSw(2) = aSw2 : mSw(3) = aSw3 : mSw(4) = aSw4
1662		mSw(5) = aSw5 : mSw(6) = aSw6 : mSw(7) = aSw7 : mSw(8) = 0
1663		If Not IsObject(vpmTrough) Then Set vpmTrough = Me
1664	End Sub
1665
1666	Public Sub InitSw8(aEntry, aSw1, aSw2, aSw3, aSw4, aSw5, aSw6, aSw7, aSw8)
1667		mEntrySw = aEntry : mSw(1) = aSw1 : mSw(2) = aSw2 : mSw(3) = aSw3 : mSw(4) = aSw4
1668		mSw(5) = aSw5 : mSw(6) = aSw6 : mSw(7) = aSw7 : mSw(8) = aSw8
1669		If Not IsObject(vpmTrough) Then Set vpmTrough = Me
1670	End Sub
1671
1672	Public Sub InitKick(aKicker, aDir, aForce)
1673		Set mExitKicker = aKicker : mExitDir = aDir : mExitForce = aForce
1674	End Sub
1675
1676	Public Sub CreateEvents(aName, aKicker)
1677		Dim obj, tmp
1678		If Not vpmCheckEvent(aName, Me) Then Exit Sub
1679		vpmSetArray tmp, aKicker
1680		For Each obj In tmp
1681			If isObject(obj) Then
1682				vpmBuildEvent obj, "Hit", aName & ".AddBall Me"
1683			Else
1684				vpmBuildEvent mExitKicker, "Hit", aName & ".AddBall Me"
1685			End If
1686		Next
1687	End Sub
1688
1689	Public Property Let IsTrough(aIsTrough)
1690		If aIsTrough Then
1691			Set vpmTrough = Me
1692		ElseIf IsObject(vpmTrough) Then
1693			If vpmTrough Is Me Then vpmTrough = 0
1694		End If
1695	End Property
1696
1697	Public Property Get IsTrough : IsTrough = vpmTrough Is Me : End Property
1698
1699	Public Sub InitAltKick(aDir, aForce)
1700		mExitDir2 = aDir : mExitForce2 = aForce
1701	End Sub
1702
1703	Public Sub InitEntrySnd(aBall, aNoBall) : mEntrySndBall = aBall : mEntrySnd = aNoBall : End Sub
1704	Public Sub InitExitSnd(aBall, aNoBall)  : mExitSndBall = aBall  : mExitSnd = aNoBall  : End Sub
1705	Public Sub InitAddSnd(aSnd) : mAddSnd = aSnd : End Sub
1706
1707	Public Property Let Balls(aBalls)
1708		Dim ii
1709		For ii = 1 To conStackSw
1710			SetSw ii, False : mBallPos(ii) = conStackSw + 1
1711		Next
1712		If mSaucer And aBalls > 0 And mBalls = 0 Then vpmCreateBall mExitKicker
1713		mBalls = aBalls : NeedUpdate = True
1714	End Property
1715
1716	Public Default Property Get Balls : Balls = mBalls         : End Property
1717	Public Property Get BallsPending  : BallsPending = mBallIn : End Property
1718
1719	' Obsolete stuff
1720	Public Sub SolEntry(aSnd1, aSnd2, aEnabled)
1721		If aEnabled Then mEntrySndBall = aSnd1 : mEntrySnd = aSnd2 : KickIn
1722	End Sub
1723	Public Sub SolExit(aSnd1, aSnd2, aEnabled)
1724		If aEnabled Then mExitSndBall = aSnd1 : mExitSnd = aSnd2 : KickOut False
1725	End Sub
1726	Public Sub InitProxy(aProxyPos, aSwNo) : End Sub
1727	Public TempBallColour, TempBallImage, BallColour
1728	Public Property Let BallImage(aImage) : vpmBallImage = aImage : End Property
1729End Class
1730
1731'--------------------
1732'       Nudge
1733'--------------------
1734class cvpmNudge
1735	Private mCount, mSensitivity, mNudgeTimer, mSlingBump, mForce
1736	Public TiltSwitch
1737
1738	Private Sub Class_Initialize
1739		mCount = 0 : TiltSwitch = 0 : mSensitivity = 5 : vpmTimer.AddResetObj Me
1740	End sub
1741
1742	Private Property Let NeedUpdate(aEnabled) : vpmTimer.EnableUpdate Me, False, aEnabled : End Property
1743
1744	Public Property Let TiltObj(aSlingBump)
1745		Dim ii
1746		ReDim mForce(vpmSetArray(mSlingBump, aSlingBump))
1747		For ii = 0 To UBound(mForce)
1748			If TypeName(mSlingBump(ii)) = "Bumper" Then mForce(ii) = mSlingBump(ii).Threshold
1749			If vpmVPVer >= 90 and TypeName(mSlingBump(ii)) = "Wall" Then mForce(ii) = mSlingBump(ii).SlingshotThreshold
1750		Next
1751	End Property
1752
1753	Public Property Let Sensitivity(aSens) : mSensitivity = (10-aSens)+1 : End property
1754
1755	Public Sub DoNudge(ByVal aDir, ByVal aForce)
1756		aDir = aDir + (Rnd-0.5)*15*aForce : aForce = (0.6+Rnd*0.8)*aForce
1757		Nudge aDir, aForce
1758		If TiltSwitch = 0 Then Exit Sub ' If no switch why care
1759		mCount = mCount + aForce * 1.2
1760		If mCount > mSensitivity + 10 Then mCount = mSensitivity + 10
1761		If mCount >= mSensitivity Then vpmTimer.PulseSw TiltSwitch
1762		NeedUpdate = True
1763	End sub
1764
1765	Public Sub Update
1766		If mCount > 0 Then
1767			mNudgeTimer = mNudgeTimer + 1
1768			If mNudgeTimer > 1000\conTimerPulse Then
1769				If mCount > mSensitivity+1 Then mCount = mCount - 1 : vpmTimer.PulseSw TiltSwitch
1770				mCount = mCount - 1 : mNudgeTimer = 0
1771			End If
1772		Else
1773			mCount = 0 : NeedUpdate = False
1774		End If
1775	End Sub
1776
1777	Public Sub Reset : mCount = 0 : End Sub
1778
1779	Public Sub SolGameOn(aEnabled)
1780		if IsEmpty(mForce) then exit sub 'prevent errors if vpmNudge.TiltObj isn't set
1781		Dim obj, ii
1782		If aEnabled Then
1783			ii = 0
1784			For Each obj In mSlingBump
1785				If TypeName(obj) = "Bumper" Then obj.Threshold = mForce(ii) 
1786				If vpmVPVer >= 90 and TypeName(obj) = "Wall" Then obj.SlingshotThreshold = mForce(ii)
1787				ii = ii + 1
1788			Next
1789		Else
1790			For Each obj In mSlingBump
1791				If TypeName(obj) = "Bumper" Then obj.Threshold = 100
1792				If vpmVPVer >= 90 and TypeName(obj) = "Wall" Then obj.SlingshotThreshold = 100
1793			Next
1794		End If
1795	End Sub
1796End Class
1797
1798'--------------------
1799'    DropTarget
1800'--------------------
1801Class cvpmDropTarget
1802	Private mDropObj, mDropSw(), mDropSnd, mRaiseSnd, mSwAnyUp, mSwAllDn, mAllDn, mLink
1803
1804	Private Sub Class_Initialize
1805		mDropSnd = 0 : mRaiseSnd = 0 : mSwAnyUp = 0 : mSwAllDn = 0 : mAllDn = False : mLink = Empty
1806	End sub
1807
1808	Private Sub CheckAllDn(ByVal aStatus)
1809		Dim obj
1810		If Not IsEmpty(mLink) Then
1811			If aStatus Then
1812				For Each obj In mLink : aStatus = aStatus And obj.AllDown : Next
1813			End If
1814			For Each obj In mLink: obj.SetAllDn aStatus : Next
1815		End If
1816		SetAllDn aStatus
1817	End Sub
1818
1819	Public Sub SetAllDn(aStatus)
1820		Dim mSwcopy
1821		If mSwAllDn Then
1822			mSwcopy = mSwAllDn
1823			Controller.Switch(mSwcopy) = aStatus
1824		End If
1825		If mSwAnyUp Then
1826			mSwcopy = mSwAnyUp
1827			Controller.Switch(mSwcopy) = Not aStatus
1828		End If
1829	End Sub
1830
1831	Public Sub InitDrop(aWalls, aSw)
1832		Dim obj, obj2, ii
1833		' Fill in switch number
1834		On Error Resume Next : ReDim mDropSw(0)
1835		If IsArray(aSw) Then
1836			ReDim mDropSw(UBound(aSw))
1837			For ii = 0 To UBound(aSw) : mDropSw(ii) = aSw(ii) : Next
1838		ElseIf aSw = 0 Or Err Then
1839			On Error Goto 0
1840			If vpmIsArray(aWalls) Then
1841				ii = 0 : If IsArray(aWalls) Then ReDim mDropSw(UBound(aWalls)) Else ReDim mDropSw(aWalls.Count-1)
1842				For Each obj In aWalls
1843					If vpmIsArray(obj) Then
1844						For Each obj2 In obj
1845							If obj2.HasHitEvent Then mDropSw(ii) = obj2.TimerInterval : Exit For
1846						Next
1847					Else
1848						mDropSw(ii) = obj.TimerInterval
1849					End If
1850					ii = ii + 1
1851				Next
1852			Else
1853				mDropSw(0) = aWalls.TimerInterval
1854			End If
1855		Else
1856			mDropSw(0) = aSw
1857		End If
1858		' Copy walls
1859		vpmSetArray mDropObj, aWalls
1860	End Sub
1861
1862	Public Sub CreateEvents(aName)
1863		Dim ii, obj1, obj2
1864		If Not vpmCheckEvent(aName, Me) Then Exit Sub
1865		ii = 1
1866		For Each obj1 In mDropObj
1867			If vpmIsArray(obj1) Then
1868				For Each obj2 In obj1
1869					if TypeName(obj2) = "HitTarget" Then 	'if object in array is a Target, use .Dropped
1870						vpmBuildEvent obj2, "Dropped", aName & ".Hit " & ii	'Droptarget_Dropped : DTbank.Hit 1 : End Sub
1871					else
1872						If obj2.HasHitEvent Then vpmBuildEvent obj2, "Hit", aName & ".Hit " & ii
1873					End If
1874				Next
1875			Else
1876				if TypeName(obj1) = "HitTarget" Then 	'if object in array is a Target, use .Dropped
1877					vpmBuildEvent obj1, "Dropped", aName & ".Hit " & ii
1878				else
1879					vpmBuildEvent obj1, "Hit", aName & ".Hit " & ii
1880				End If
1881			End If
1882			ii = ii + 1
1883		Next
1884	End Sub
1885
1886	Public Property Let AnyUpSw(aSwAnyUp)
1887		Dim mSwcopy
1888		mSwAnyUp = aSwAnyUp
1889		mSwcopy = mSwAnyUp
1890		Controller.Switch(mSwcopy) = True
1891	End Property
1892	Public Property Let AllDownSw(aSwAllDn) : mSwAllDn = aSwAllDn : End Property
1893	Public Property Get AllDown : AllDown = mAllDn : End Property
1894	Public Sub InitSnd(aDrop, aRaise) : mDropSnd = aDrop : mRaiseSnd = aRaise : End Sub
1895	Public Property Let LinkedTo(aLink)
1896		If IsArray(aLink) Then mLink = aLink Else mLink = Array(aLink)
1897	End Property
1898
1899	Public Sub Hit(aNo)
1900		Dim ii, mSwcopy
1901		vpmSolWall mDropObj(aNo-1), mDropSnd, True
1902		mSwcopy = mDropSw(aNo-1)
1903		Controller.Switch(mSwcopy) = True
1904		For Each ii In mDropSw
1905			mSwcopy = ii
1906			If Not Controller.Switch(mSwcopy) Then Exit Sub
1907		Next
1908		mAllDn = True : CheckAllDn True
1909	End Sub
1910
1911	Public Sub SolHit(aNo, aEnabled) : If aEnabled Then Hit aNo : End If : End Sub
1912
1913	Public Sub SolUnhit(aNo, aEnabled)
1914		Dim mSwcopy
1915		Dim ii : If Not aEnabled Then Exit Sub
1916		PlaySound mRaiseSnd : vpmSolWall mDropObj(aNo-1), False, False
1917		mSwcopy = mDropSw(aNo-1)
1918		Controller.Switch(mSwcopy) = False
1919		mAllDn = False : CheckAllDn False
1920	End Sub
1921
1922	Public Sub SolDropDown(aEnabled)
1923		Dim mSwcopy
1924		Dim ii : If Not aEnabled Then Exit Sub
1925		PlaySound mDropSnd
1926		For Each ii In mDropObj : vpmSolWall ii, False, True : Next
1927		For Each ii In mDropSw  : mSwcopy = ii : Controller.Switch(mSwcopy) = True : Next
1928		mAllDn = True : CheckAllDn True
1929	End Sub
1930
1931	Public Sub SolDropUp(aEnabled)
1932		Dim mSwcopy
1933		Dim ii : If Not aEnabled Then Exit Sub
1934		PlaySound mRaiseSnd
1935		For Each ii In mDropObj : vpmSolWall ii, False, False : Next
1936		For Each ii In mDropSw  : mSwcopy = ii : Controller.Switch(mSwcopy) = False : Next
1937		mAllDn = False : CheckAllDn False
1938	End Sub
1939
1940	Public Sub DropSol_On : SolDropUp True : End Sub
1941End Class
1942
1943'--------------------
1944'       Magnet
1945'--------------------
1946Class cvpmMagnet
1947	Private mEnabled, mBalls, mTrigger
1948	Public X, Y, Strength, Size, GrabCenter, Solenoid
1949
1950	Private Sub Class_Initialize
1951		Size = 1 : Strength = 0 : Solenoid = 0 : mEnabled = False
1952		Set mBalls = New cvpmDictionary
1953	End Sub
1954
1955	Private Property Let NeedUpdate(aEnabled) : vpmTimer.EnableUpdate Me, True, aEnabled : End Property
1956
1957	Public Sub InitMagnet(aTrigger, aStrength)
1958		Dim tmp
1959		If vpmIsArray(aTrigger) Then Set tmp = aTrigger(0) Else Set tmp = aTrigger
1960		X = tmp.X : Y = tmp.Y : Size = tmp.Radius : vpmTimer.InitTimer tmp, True
1961		If IsArray(aTrigger) Then mTrigger = aTrigger Else Set mTrigger = aTrigger
1962		Strength = aStrength : GrabCenter = aStrength > 14
1963	End Sub
1964
1965	Public Sub CreateEvents(aName)
1966		If vpmCheckEvent(aName, Me) Then
1967			vpmBuildEvent mTrigger, "Hit", aName & ".AddBall ActiveBall"
1968			vpmBuildEvent mTrigger, "UnHit", aName & ".RemoveBall ActiveBall"
1969		End If
1970	End Sub
1971
1972	Public Property Let MagnetOn(aEnabled) : mEnabled = aEnabled : End Property
1973	Public Property Get MagnetOn
1974		If Solenoid > 0 Then MagnetOn = Controller.Solenoid(Solenoid) Else MagnetOn = mEnabled
1975	End Property
1976
1977	Public Sub AddBall(aBall)
1978		With mBalls
1979			If .Exists(aBall) Then .Item(aBall) = .Item(aBall) + 1 Else .Add aBall, 1 : NeedUpdate = True
1980		End With
1981	End Sub
1982
1983	Public Sub RemoveBall(aBall)
1984		With mBalls
1985			If .Exists(aBall) Then .Item(aBall) = .Item(aBall) - 1 : If .Item(aBall) <= 0 Then .Remove aBall
1986			NeedUpdate = (.Count > 0)
1987		End With
1988	End Sub
1989
1990	Public Property Get Balls : Balls = mBalls.Keys : End Property
1991
1992	Public Sub Update
1993		Dim obj
1994		If MagnetOn Then
1995			On Error Resume Next
1996			For Each obj In mBalls.Keys
1997				If obj.X < 0 Or Err Then mBalls.Remove obj Else AttractBall obj
1998			Next
1999			On Error Goto 0
2000		End If
2001	End Sub
2002
2003	Public Sub AttractBall(aBall)
2004		Dim dX, dY, dist, force, ratio
2005		dX = aBall.X - X : dY = aBall.Y - Y : dist = Sqr(dX*dX + dY*dY)
2006		If dist > Size Or dist < 1 Then Exit Sub 'Just to be safe
2007		If GrabCenter And dist < 20 Then
2008			aBall.VelX = 0 : aBall.VelY = 0 : aBall.X = X : aBall.Y = Y
2009		Else
2010			ratio = dist / (1.5*Size)
2011			force = Strength * exp(-0.2/ratio)/(ratio*ratio*56) * 1.5
2012			aBall.VelX = (aBall.VelX - dX * force / dist) * 0.985
2013			aBall.VelY = (aBall.VelY - dY * force / dist) * 0.985
2014		End if
2015	End Sub
2016	' obsolete
2017	Public Property Let Range(aSize) : Size = aSize : End Property
2018	Public Property Get Range        : Range = Size : End Property
2019End Class
2020
2021'--------------------
2022'     Turntable
2023'--------------------
2024Class cvpmTurntable
2025	Private mX, mY, mSize, mTrigger, mBalls, mSpinUp, mSpinDown
2026	Private mMotorOn, mSpinCW
2027	Private mMaxSpeed, mTargetSpeed, mCurrentAccel
2028	Public Speed
2029
2030	Private Sub Class_Initialize
2031		Set mBalls = New cvpmDictionary
2032		mMotorOn = False : mSpinCW = True : Speed = 0 : mSpinUp = 10 : mSpinDown = 4
2033		AdjustTargets
2034	End Sub
2035
2036	Private Property Let NeedUpdate(aEnabled) : vpmTimer.EnableUpdate Me, True, aEnabled : End Property
2037
2038	Public Sub InitTurntable(aTrigger, aMaxSpeed)
2039		mX = aTrigger.X : mY = aTrigger.Y : mSize = aTrigger.Radius : vpmTimer.InitTimer aTrigger, True
2040		mMaxSpeed = aMaxSpeed : Set mTrigger = aTrigger
2041		AdjustTargets
2042	End Sub
2043
2044	Public Sub CreateEvents(aName)
2045		If vpmCheckEvent(aName, Me) Then
2046			vpmBuildEvent mTrigger, "Hit", aName & ".AddBall ActiveBall"
2047			vpmBuildEvent mTrigger, "UnHit", aName & ".RemoveBall ActiveBall"
2048		End If
2049	End Sub
2050
2051	Public Sub SolMotorState(aCW, aMotorOn)
2052	    mSpinCW = aCW
2053	    mMotorOn = aMotorOn
2054	    AdjustTargets
2055	End Sub
2056
2057    Private Sub AdjustTargets
2058	    If mMotorOn Then
2059	        mTargetSpeed = MaxSpeed
2060	        mCurrentAccel = SpinUp
2061	        If Not mSpinCW Then mTargetSpeed = -MaxSpeed
2062	    Else
2063	        mTargetSpeed = 0
2064	        mCurrentAccel = SpinDown
2065	    End If
2066
2067        NeedUpdate = mBalls.Count Or SpinUp Or SpinDown
2068    End Sub
2069
2070    Public Property Let MaxSpeed(newSpeed) : mMaxSpeed = newSpeed : AdjustTargets : End Property
2071    Public Property Let SpinUp(newRate) : mSpinUp = newRate : AdjustTargets : End Property
2072    Public Property Let SpinDown(newRate) : mSpinDown = newRate : AdjustTargets : End Property
2073
2074    Public Property Get MaxSpeed : MaxSpeed = mMaxSpeed : End Property
2075    Public Property Get SpinUp : SpinUp = mSpinup : End Property
2076    Public Property Get SpinDown : SpinDown = mSpinDown : End Property
2077
2078	Public Property Let MotorOn(aEnabled) : SolMotorState mSpinCW, aEnabled : End Property
2079	Public Property Let SpinCW(aCW) : SolMotorState aCW, mMotorOn : End Property
2080
2081	Public Property Get MotorOn : MotorOn = mMotorOn : End Property
2082	Public Property Get SpinCW : SpinCW = mSpinCW : End Property
2083
2084	Public Sub AddBall(aBall)
2085		On Error Resume Next : mBalls.Add aBall,0 : NeedUpdate = True
2086	End Sub
2087	Public Sub RemoveBall(aBall)
2088		On Error Resume Next
2089		mBalls.Remove aBall : NeedUpdate = mBalls.Count Or SpinUp Or SpinDown
2090	End Sub
2091	Public Property Get Balls : Balls = mBalls.Keys : End Property
2092
2093	Public Sub Update
2094	    If Speed > mTargetSpeed Then
2095	        Speed = Speed - mCurrentAccel/100
2096	        If Speed < mTargetSpeed Then Speed = mTargetSpeed : NeedUpdate = mBalls.Count
2097	    ElseIf Speed < mTargetSpeed Then
2098	        Speed = Speed + mCurrentAccel/100
2099	        If Speed > mTargetSpeed Then Speed = mTargetSpeed : NeedUpdate = mBalls.Count
2100	    End If
2101
2102		If Speed Then
2103			Dim obj
2104			On Error Resume Next
2105			For Each obj In mBalls.Keys
2106				If obj.X < 0 Or Err Then mBalls.Remove obj Else AffectBall obj
2107			Next
2108			On Error Goto 0
2109		End If
2110	End Sub
2111
2112	Public Sub AffectBall(aBall)
2113		Dim dX, dY, dist
2114		dX = aBall.X - mX : dY = aBall.Y - mY : dist = Sqr(dX*dX + dY*dY)
2115		If dist > mSize Or dist < 1 Or Speed = 0 Then Exit Sub
2116		aBall.VelX = aBall.VelX - (dY * Speed / 8000)
2117		aBall.VelY = aBall.VelY + (dX * Speed / 8000)
2118	End Sub
2119End Class
2120
2121'--------------------
2122'     Mech
2123'--------------------
2124Const vpmMechLinear    = &H00
2125Const vpmMechNonLinear = &H01
2126Const vpmMechCircle    = &H00
2127Const vpmMechStopEnd   = &H02
2128Const vpmMechReverse   = &H04
2129Const vpmMechOneSol    = &H00
2130Const vpmMechOneDirSol = &H10
2131Const vpmMechTwoDirSol = &H20
2132Const vpmMechStepSol   = &H40
2133Const vpmMechSlow      = &H00
2134Const vpmMechFast      = &H80
2135Const vpmMechStepSw    = &H00
2136Const vpmMechLengthSw  = &H100
2137
2138Class cvpmMech
2139	Public Sol1, Sol2, MType, Length, Steps, Acc, Ret
2140	Private mMechNo, mNextSw, mSw(), mLastPos, mLastSpeed, mCallback
2141
2142	Private Sub Class_Initialize
2143		ReDim mSw(10)
2144		gNextMechNo = gNextMechNo + 1 : mMechNo = gNextMechNo : mNextSw = 0 : mLastPos = 0 : mLastSpeed = 0
2145		MType = 0 : Length = 0 : Steps = 0 : Acc = 0 : Ret = 0 : vpmTimer.addResetObj Me
2146	End Sub
2147
2148	Public Sub AddSw(aSwNo, aStart, aEnd)
2149		mSw(mNextSw) = Array(aSwNo, aStart, aEnd, 0)
2150		mNextSw = mNextSw + 1
2151	End Sub
2152
2153	Public Sub AddPulseSwNew(aSwNo, aInterval, aStart, aEnd)
2154		If Controller.Version >= "01200000" Then
2155			mSw(mNextSw) = Array(aSwNo, aStart, aEnd, aInterval)
2156		Else
2157			mSw(mNextSw) = Array(aSwNo, -aInterval, aEnd - aStart + 1, 0)
2158		End If
2159		mNextSw = mNextSw + 1
2160	End Sub
2161
2162	Public Sub Start
2163		Dim sw, ii
2164		With Controller
2165			.Mech(1) = Sol1 : .Mech(2) = Sol2 : .Mech(3) = Length
2166			.Mech(4) = Steps : .Mech(5) = MType : .Mech(6) = Acc : .Mech(7) = Ret
2167			ii = 10
2168			For Each sw In mSw
2169				If IsArray(sw) Then
2170					.Mech(ii) = sw(0) : .Mech(ii+1) = sw(1)
2171					.Mech(ii+2) = sw(2) : .Mech(ii+3) = sw(3)
2172					ii = ii + 10
2173				End If
2174			Next
2175			.Mech(0) = mMechNo
2176		End With
2177		If IsObject(mCallback) Then mCallBack 0, 0, 0 : mLastPos = 0 : vpmTimer.EnableUpdate Me, False, True
2178	End Sub
2179
2180	Public Property Get Position : Position = Controller.GetMech(mMechNo) : End Property
2181	Public Property Get Speed    : Speed = Controller.GetMech(-mMechNo)   : End Property
2182	Public Property Let Callback(aCallBack) : Set mCallback = aCallBack : End Property
2183
2184	Public Sub Update
2185		Dim currPos, speed
2186		currPos = Controller.GetMech(mMechNo)
2187		speed = Controller.GetMech(-mMechNo)
2188		If currPos < 0 Or (mLastPos = currPos And mLastSpeed = speed) Then Exit Sub
2189		mCallBack currPos, speed, mLastPos : mLastPos = currPos : mLastSpeed = speed
2190	End Sub
2191
2192	Public Sub Reset : Start : End Sub
2193	' Obsolete
2194	Public Sub AddPulseSw(aSwNo, aInterval, aLength) : AddSw aSwNo, -aInterval, aLength : End Sub
2195End Class
2196
2197'--------------------
2198'   Captive Ball
2199'--------------------
2200Class cvpmCaptiveBall
2201	Private mBallKicked, mBallDir, mBallCos, mBallSin, mTrigHit
2202	Private mTrig, mWall, mKickers, mVelX, mVelY, mKickNo
2203	Public ForceTrans, MinForce, RestSwitch, NailedBalls
2204
2205	Private Sub Class_Initialize
2206		mBallKicked = False : ForceTrans = 0.5 : mTrigHit = False : MinForce = 3 : NailedBalls = 0
2207		vpmTimer.addResetObj Me
2208	End Sub
2209
2210	Public Sub InitCaptive(aTrig, aWall, aKickers, aBallDir)
2211		Set mTrig = aTrig : Set mWall = aWall
2212		mKickNo = vpmSetArray(mKickers, aKickers)
2213		mBallDir = aBallDir : mBallCos = Cos(aBallDir * 3.1415927/180) : mBallSin = Sin(aBallDir * 3.1415927/180)
2214	End Sub
2215
2216	Public Sub Start
2217		Dim mSwcopy
2218		vpmCreateBall mKickers(mKickNo + (mKickNo <> NailedBalls))
2219		If RestSwitch Then
2220			mSwcopy = RestSwitch
2221			Controller.Switch(mSwcopy) = True
2222		End If
2223	End Sub
2224
2225	Public Sub TrigHit(aBall)
2226		mTrigHit = IsObject(aBall) : If mTrigHit Then mVelX = aBall.VelX : mVelY = aBall.VelY
2227	End Sub
2228
2229	Public Sub Reset
2230		Dim mSwcopy
2231		If RestSwitch Then
2232			mSwcopy = RestSwitch
2233			Controller.Switch(mSwcopy) = True
2234		End If
2235	End Sub
2236
2237	Public Sub BallHit(aBall)
2238		Dim dX, dY, force, mSwcopy
2239		If mBallKicked Then Exit Sub ' Ball is not here
2240		If mTrigHit Then mTrigHit = False Else mVelX = aBall.VelX : mVelY = aBall.VelY
2241		dX = aBall.X - mKickers(0).X : dY = aBall.Y - mKickers(0).Y
2242		force = -ForceTrans * (dY * mVelY + dX * mVelX) * (dY * mBallCos + dX * mBallSin) / (dX*dX + dY*dY)
2243		If force < 1 Then Exit Sub
2244		If force < MinForce Then force = MinForce
2245		If mKickNo <> NailedBalls Then
2246			vpmCreateBall mKickers(mKickNo)
2247			mKickers(mKickNo-1).DestroyBall
2248		End If
2249		mKickers(mKickNo).Kick mBallDir, force : mBallKicked = True
2250		If RestSwitch Then
2251			mSwcopy = RestSwitch
2252			Controller.Switch(mSwcopy) = False
2253		End If
2254	End Sub
2255
2256	Public Sub BallReturn(aKicker)
2257		Dim mSwcopy
2258		If mKickNo <> NailedBalls Then vpmCreateBall mKickers(mKickNo-1) : aKicker.DestroyBall
2259		mBallKicked = False
2260		If RestSwitch Then
2261			mSwcopy = RestSwitch
2262			Controller.Switch(mSwcopy) = True
2263		End If
2264	End Sub
2265
2266	Public Sub CreateEvents(aName)
2267		If vpmCheckEvent(aName, Me) Then
2268			If Not mTrig Is Nothing Then
2269				vpmBuildEvent mTrig, "Hit", aName & ".TrigHit ActiveBall"
2270				vpmBuildEvent mTrig, "UnHit", aName & ".TrigHit 0"
2271			End If
2272			vpmBuildEvent mWall, "Hit", aName & ".BallHit ActiveBall"
2273			vpmBuildEvent mKickers(mKickNo), "Hit", aName & ".BallReturn Me"
2274		End If
2275	End Sub
2276	' Obsolete
2277	Public BallImage, BallColour
2278End Class
2279
2280'--------------------
2281'   Visible Locks
2282'--------------------
2283Class cvpmVLock
2284	Private mTrig, mKick, mSw(), mSize, mBalls, mGateOpen, mRealForce, mBallSnd, mNoBallSnd
2285	Public ExitDir, ExitForce, KickForceVar
2286
2287	Private Sub Class_Initialize
2288		mBalls = 0 : ExitDir = 0 : ExitForce = 0 : KickForceVar = 0 : mGateOpen = False
2289		vpmTimer.addResetObj Me
2290	End Sub
2291
2292	Public Sub InitVLock(aTrig, aKick, aSw)
2293		Dim ii
2294		mSize = vpmSetArray(mTrig, aTrig)
2295		If vpmSetArray(mKick, aKick) <> mSize Then MsgBox "cvpmVLock: Unmatched kick+trig" : Exit Sub
2296		On Error Resume Next
2297		ReDim mSw(mSize)
2298		If IsArray(aSw) Then
2299			For ii = 0 To UBound(aSw) : mSw(ii) = aSw(ii) : Next
2300		ElseIf aSw = 0 Or Err Then
2301			For ii = 0 To mSize: mSw(ii) = mTrig(ii).TimerInterval : Next
2302		Else
2303			mSw(0) = aSw
2304		End If
2305	End Sub
2306
2307	Public Sub InitSnd(aBall, aNoBall) : mBallSnd = aBall : mNoBallSnd = aNoBall : End Sub
2308	Public Sub CreateEvents(aName)
2309		Dim ii
2310		If Not vpmCheckEvent(aName, Me) Then Exit Sub
2311		For ii = 0 To mSize
2312			vpmBuildEvent mTrig(ii), "Hit", aName & ".TrigHit ActiveBall," & ii+1
2313			vpmBuildEvent mTrig(ii), "Unhit", aName & ".TrigUnhit ActiveBall," & ii+1
2314			vpmBuildEvent mKick(ii), "Hit", aName & ".KickHit " & ii+1
2315		Next
2316	End Sub
2317
2318	Public Sub SolExit(aEnabled)
2319		Dim ii, mSwcopy
2320		mGateOpen = aEnabled
2321		If Not aEnabled Then Exit Sub
2322		If mBalls > 0 Then PlaySound mBallSnd : Else PlaySound mNoBallSnd : Exit Sub
2323		For ii = 0 To mBalls-1
2324			mKick(ii).Enabled = False
2325			If mSw(ii) Then
2326				mSwcopy = mSw(ii)
2327				Controller.Switch(mSwcopy) = False
2328			End If
2329		Next
2330		If ExitForce > 0 Then ' Up
2331			mRealForce = ExitForce + (Rnd - 0.5)*KickForceVar : mKick(mBalls-1).Kick ExitDir, mRealForce
2332		Else ' Down
2333			mKick(0).Kick 0, 0
2334		End If
2335	End Sub
2336
2337	Public Sub Reset
2338		Dim mSwcopy
2339		Dim ii : If mBalls = 0 Then Exit Sub
2340		For ii = 0 To mBalls-1
2341			If mSw(ii) Then
2342				mSwcopy = mSw(ii)
2343				Controller.Switch(mSwcopy) = True
2344			End If
2345		Next
2346	End Sub
2347
2348	Public Property Get Balls : Balls = mBalls : End Property
2349
2350	Public Property Let Balls(aBalls)
2351		Dim mSwcopy
2352		Dim ii : mBalls = aBalls
2353		For ii = 0 To mSize
2354			mSwcopy = mSw(ii)
2355			If ii >= aBalls Then
2356				mKick(ii).DestroyBall : If mSwcopy Then Controller.Switch(mSwcopy) = False
2357			Else
2358				vpmCreateBall mKick(ii) : If mSwcopy Then Controller.Switch(mSwcopy) = True
2359			End If
2360		Next
2361	End Property
2362
2363	Public Sub TrigHit(aBall, aNo)
2364		Dim mSwcopy
2365		aNo = aNo - 1
2366		If mSw(aNo) Then
2367			mSwcopy = mSw(aNo)
2368			Controller.Switch(mSwcopy) = True
2369		End If
2370		If aBall.VelY < -1 Then Exit Sub ' Allow small upwards speed
2371		If aNo = mSize Then mBalls = mBalls + 1
2372		If mBalls > aNo Then mKick(aNo).Enabled = Not mGateOpen
2373	End Sub
2374
2375	Public Sub TrigUnhit(aBall, aNo)
2376		Dim mSwcopy
2377		aNo = aNo - 1
2378		If mSw(aNo) Then
2379			mSwcopy = mSw(aNo)
2380			Controller.Switch(mSwcopy) = False
2381		End If
2382		If aBall.VelY > -1 Then
2383			If aNo = 0 Then mBalls = mBalls - 1
2384			If aNo < mSize Then mKick(aNo+1).Kick 0, 0
2385		Else
2386			If aNo = mSize Then mBalls = mBalls - 1
2387			If aNo > 0 Then mKick(aNo-1).Kick ExitDir, mRealForce
2388		End If
2389	End Sub
2390
2391	Public Sub KickHit(aNo) : mKick(aNo-1).Enabled = False : End Sub
2392End Class
2393
2394'--------------------
2395'   View Dips
2396'--------------------
2397Class cvpmDips
2398	Private mLWF, mChkCount, mOptCount, mItems()
2399
2400	Private Sub Class_Initialize
2401		ReDim mItems(100)
2402	End Sub
2403
2404	Private Sub addChkBox(aType, aLeft, aTop, aWidth, aNames)
2405		Dim ii, obj
2406		If Not isObject(mLWF) Then Exit Sub
2407		For ii = 0 To UBound(aNames) Step 2
2408			Set obj = mLWF.AddCtrl("chkBox", 10+aLeft, 5+aTop+ii*7, aWidth, 14, aNames(ii))
2409			mChkCount = mChkCount + 1 : mItems(mChkCount+mOptCount) = Array(aType, obj, mChkCount, aNames(ii+1), aNames(ii+1))
2410		Next
2411	End Sub
2412
2413	Private Sub addOptBox(aType, aLeft, aTop, aWidth, aHeading, aMask, aNames)
2414		Dim ii, obj
2415		If Not isObject(mLWF) Then Exit Sub
2416		mLWF.AddCtrl "Frame", 10+aLeft, 5+aTop, 10+aWidth, 7*UBound(aNames)+25, aHeading
2417		If aMask Then
2418			For ii = 0 To UBound(aNames) Step 2
2419				Set obj = mLWF.AddCtrl("OptBtn", 10+aLeft+5, 5+aTop+ii*7+14, aWidth, 14, aNames(ii))
2420				mOptCount = mOptCount + 1 : mItems(mChkCount+mOptCount) = Array(aType+2,obj,mOptCount,aNames(ii+1),aMask)
2421			Next
2422		Else
2423			addChkBox aType, 5+aLeft, 15+aTop, aWidth, aNames
2424		End If
2425	End Sub
2426
2427	Public Sub addForm(ByVal aWidth, aHeight, aName)
2428		If aWidth < 80 Then aWidth = 80
2429		On Error Resume Next
2430		Set mLWF = CreateObject("VPinMAME.WSHDlg") : If Err Then Exit Sub
2431		With mLWF
2432			.x = -1 : .y = -1 ' : .w = aWidth : .h = aHeight+60
2433			.Title = aName : .AddCtrl "OKBtn", -1, -1, 70, 25, "&Ok"
2434		End With
2435		mChkCount = 0 : mOptCount = 0
2436	End Sub
2437
2438	Public Sub addChk(aLeft, aTop, aWidth, aNames)
2439		addChkBox 0, aLeft, aTop, aWidth, aNames
2440	End Sub
2441	Public Sub addChkExtra(aLeft, aTop, aWidth, aNames)
2442		addChkBox 1, aLeft, aTop, aWidth, aNames
2443	End Sub
2444	Public Sub addFrame(aLeft, aTop, aWidth, aHeading, aMask, aNames)
2445		addOptBox 0, aLeft, aTop, aWidth, aHeading, aMask, aNames
2446	End Sub
2447	Public Sub addFrameExtra(aLeft, aTop, aWidth, aHeading, aMask, aNames)
2448		addOptBox 1, aLeft, aTop, aWidth, aHeading, aMask, aNames
2449	End Sub
2450
2451	Public Sub addLabel(aLeft, aTop, aWidth, aHeight, aCaption)
2452		If Not isObject(mLWF) Then Exit Sub
2453		mLWF.AddCtrl "Label", 10+aLeft, 5+aTop, aWidth, aHeight, aCaption
2454	End Sub
2455
2456	Public Sub viewDips : viewDipsExtra 0 : End Sub
2457	Public Function viewDipsExtra(aExtra)
2458		Dim dips(1), ii, useDip
2459		If Not isObject(mLWF) Then Exit Function
2460		With Controller
2461			dips(0) = .Dip(0) + .Dip(1)*256 + .Dip(2)*65536 + (.Dip(3) And &H7f)*&H1000000
2462			If .Dip(3) And &H80 Then dips(0) = dips(0) Or &H80000000 'workaround for overflow error
2463		End With
2464		useDip = False : dips(1) = aExtra
2465		For ii = 1 To mChkCount + mOptCount
2466			mItems(ii)(1).Value = -((dips(mItems(ii)(0) And &H01) And mItems(ii)(4)) = mItems(ii)(3))
2467			If (mItems(ii)(0) And &H01) = 0 Then useDip = True
2468		Next
2469		mLWF.Show GetPlayerHWnd
2470		dips(0) = 0 : dips(1) = 0
2471		For ii = 1 To mChkCount + mOptCount
2472			If mItems(ii)(1).Value Then dips(mItems(ii)(0) And &H01) = dips(mItems(ii)(0) And &H01) Or mItems(ii)(3)
2473		Next
2474		If useDip Then
2475			With Controller
2476				.Dip(0) =  (dips(0) And 255)
2477				.Dip(1) = ((dips(0) And 65280)\256) And 255
2478				.Dip(2) = ((dips(0) And &H00ff0000)\65536) And 255
2479				.Dip(3) = ((dips(0) And &Hff000000)\&H01000000) And 255
2480			End With
2481		End If
2482		viewDipsExtra = dips(1)
2483	End Function
2484End Class
2485
2486'--------------------
2487'   Impulse Plunger
2488'--------------------
2489Class cvpmImpulseP
2490	Private mEnabled, mBalls, mTrigger, mEntrySnd, mExitSnd, MExitSndBall
2491	Public X, Y, Strength, Res, Size, Solenoid, IMPowerOut, Time, mCount, Pull, IMPowerTrans, cFactor, Auto, RandomOut, SwitchNum, SwitchOn, BallOn
2492
2493	Private Sub Class_Initialize
2494		Size = 1 : Strength = 0 : Solenoid = 0 : Res = 1 : IMPowerOut = 0 : Time = 0 : mCount = 0 : mEnabled = False
2495		Pull = 0 : IMPowerTrans = 0 : Auto = False : RandomOut = 0 : SwitchOn = 0 : SwitchNum = 0 : BallOn = 0
2496		Set mBalls = New cvpmDictionary
2497	End Sub
2498
2499	Private Property Let NeedUpdate(aEnabled) : vpmTimer.EnableUpdate Me, True, aEnabled : End Property
2500
2501	Public Sub InitImpulseP(aTrigger, aStrength, aTime)
2502		Dim tmp
2503		If vpmIsArray(aTrigger) Then Set tmp = aTrigger(0) Else Set tmp = aTrigger
2504		X = tmp.X : Y = tmp.Y : Size = tmp.Radius : vpmTimer.InitTimer tmp, True
2505		If IsArray(aTrigger) Then mTrigger = aTrigger Else Set mTrigger = aTrigger
2506		Strength = aStrength
2507		Res = 500
2508		Time = aTime
2509		If aTime = 0 Then 
2510			Auto = True
2511		Else
2512			cFactor = (Res / Time) / 100
2513			Auto = False
2514		End If
2515	End Sub
2516
2517	Public Sub CreateEvents(aName)
2518		If vpmCheckEvent(aName, Me) Then
2519			vpmBuildEvent mTrigger, "Hit", aName & ".AddBall ActiveBall"
2520			vpmBuildEvent mTrigger, "UnHit", aName & ".RemoveBall ActiveBall"
2521		End If
2522	End Sub
2523
2524 
2525	Public Property Let PlungeOn(aEnabled) : mEnabled = aEnabled : End Property
2526	Public Property Get PlungeOn
2527		If Solenoid > 0 Then PlungeOn = Controller.Solenoid(Solenoid) Else PlungeOn = mEnabled
2528	End Property
2529
2530	Public Sub AddBall(aBall)
2531		Dim mSwcopy
2532		With mBalls
2533			If .Exists(aBall) Then .Item(aBall) = .Item(aBall) + 1 Else .Add aBall, 1 : NeedUpdate = True
2534		End With
2535		If SwitchOn = True Then
2536			mSwcopy = SwitchNum
2537			Controller.Switch(mSwcopy) = 1
2538		End If
2539		BallOn = 1
2540	End Sub
2541
2542	Public Sub RemoveBall(aBall)
2543		Dim mSwcopy
2544		With mBalls
2545			If .Exists(aBall) Then .Item(aBall) = .Item(aBall) - 1 : If .Item(aBall) <= 0 Then .Remove aBall
2546			NeedUpdate = (.Count > 0)
2547		End With
2548		If SwitchOn = True Then
2549			mSwcopy = SwitchNum
2550			Controller.Switch(mSwcopy) = 0
2551		End If
2552		BallOn = 0
2553	End Sub
2554
2555	Public Property Get Balls : Balls = mBalls.Keys : End Property
2556
2557	Public Sub Update
2558		Dim obj
2559		If pull = 1 and mCount < Res Then
2560			mCount = mCount + cFactor
2561			IMPowerTrans = mCount
2562			NeedUpdate = True
2563		Else
2564			IMPowerTrans = mCount
2565			NeedUpdate = False
2566		End If
2567		If PlungeOn Then
2568			On Error Resume Next
2569			For Each obj In mBalls.Keys
2570				If obj.X < 0 Or Err Then : mBalls.Remove obj : Else : PlungeBall obj : End If
2571			Next
2572			On Error Goto 0
2573		End If
2574	End Sub
2575
2576	Public Sub PlungeBall(aBall)
2577			aBall.VelY = IMPowerOut
2578	End Sub
2579
2580	Public Sub Random(aInput) ' Random Output Varience
2581		RandomOut = aInput
2582	End Sub
2583
2584	Public Sub Fire	    	  ' Resets System and Transfer Power Value
2585		If Auto = True Then
2586		IMPowerOut = -Strength + ((Rnd) * RandomOut)
2587		Else
2588		IMPowerOut = -Strength * (IMPowerTrans + ((Rnd-0.5) * cFactor * RandomOut)) / Res
2589		End If
2590		PlungeOn = True
2591		Update
2592		PlungeOn = False
2593		Pull = 0 : IMPowerOut = 0 : IMPowerTrans = 0 : mCount = 0
2594		If BallOn = 1 Then : PlaySound mExitSndBall : Else : PlaySound mExitSnd : End If
2595	End Sub
2596
2597	Public Sub AutoFire	  ' Auto-Fire Specific Call (so you don't have to change timing)
2598		IMPowerOut = -Strength + ((Rnd) * RandomOut)
2599		PlungeOn = True
2600		Update
2601		PlungeOn = False
2602		Pull = 0 : IMPowerOut = 0 : IMPowerTrans = 0 : mCount = 0
2603		If BallOn = 1 Then : PlaySound mExitSndBall : Else : PlaySound mExitSnd : End If
2604	End Sub
2605	
2606	Public Sub Pullback     ' Pull Plunger
2607		Pull = 0 : IMPowerOut = 0 : IMPowerTrans = 0 : mCount = 0 ' reinitialize to be sure
2608		Pull = 1 : NeedUpdate = True
2609    		PlaySound mEntrySnd
2610	End Sub
2611	
2612	Public Sub Switch(aSw)
2613		SwitchOn = True
2614		SwitchNum = aSw
2615	End Sub
2616	
2617    Public Sub InitEntrySnd(aNoBall) : mEntrySnd = aNoBall : End Sub
2618    Public Sub InitExitSnd(aBall, aNoBall)  : mExitSndBall = aBall  : mExitSnd = aNoBall  : End Sub
2619End Class
2620
2621Set vpmTimer = New cvpmTimer
2622If LoadScript("NudgePlugIn.vbs") Then Set vpmNudge = New cvpmNudge2 Else Set vpmNudge = New cvpmNudge
2623
2624'-------------
2625'cvpmFlips (FastFlips)
2626'-------------
2627dim vpmFlips : set vpmFlips = New cvpmFlips : vpmFlips.Name = "vpmFlips"
2628
2629'*************************************************
2630Sub InitVpmFlips() 'Called from vpmInit
2631	if not UseSolenoids > 1 then exit sub 
2632	On Error Resume Next
2633		if UseSolenoids > 2 then vpmFlips.Solenoid = UseSolenoids else vpmFlips.Solenoid = GameOnSolenoid End If
2634	On Error Goto 0
2635	vpmFlips.DebugTestInit = True
2636
2637	if not IsEmpty(SolCallback(sLLFlipper)) then vpmFlips.CallBackL = SolCallback(sLLFlipper) 	'Lower Flippers
2638	if not IsEmpty(SolCallback(sLRFlipper)) then vpmFlips.CallBackR = SolCallback(sLRFlipper)
2639	if not IsEmpty(SolCallback(sULFlipper)) then vpmFlips.CallBackUL = SolCallback(sULFlipper) 	'Upper Flippers
2640	if not IsEmpty(SolCallback(sURFlipper)) then vpmFlips.CallBackUR = SolCallback(sURFlipper)
2641End Sub
2642Function NullFunction(aEnabled):End Function	'1 argument null function
2643
2644Class cvpmFlips
2645	Public TiltObjects, DebugOn, Name, Delay
2646	private SubL, SubUL, SubR, SubUR, FlippersEnabled,  LagCompensation, FlipState(3), Sol	'set private
2647	
2648	Private Sub Class_Initialize()
2649		dim x : for x = 0 to 3 : flipstate(x) = False : Next
2650		Delay = 0 : FlippersEnabled = False : DebugOn = False : LagCompensation = False : Sol = 0 : TiltObjects = True
2651		SubL = "NullFunction": SubR = "NullFunction" : SubUL = "NullFunction": SubUR = "NullFunction"
2652	End Sub
2653
2654	public DebugTestKeys, DebugTestInit
2655	Public Sub DebugTest
2656		dim e
2657		if UseSolenoids = 1 then debug.print "debugtest: " & "UseSolenoids = 1, change to 2 or greater and restart to enable!" : Exit Sub
2658		dim a : if usesolenoids = 2 and usesolenoids <> solenoid then a = "(Auto)"
2659		if solenoid = 0 then a = " (undefined solenoid, automatic tilt is disabled)" : e = True
2660		debug.print "--DebugTest--" & vbnewline & "Game:(" & cGameName & ") Flipper Sol=" & Solenoid & a & " Flippers on?: " & FlippersEnabled
2661		if not DebugTestInit then debug.print "Init error! Please add 'vpmInit me' to the table1_init section of the table script!" : exit sub
2662		if not FlippersEnabled and Controller.Solenoid(solenoid) and not DebugOn then debug.print "Tiltsol problem, flippers should be on right now!" : e = True 
2663
2664		if IsEmpty(keyStagedFlipperL) then debug.print "keyStagedFlipperL is empty or undefined (check vpmkeys.vbs)" : e = True
2665		if IsEmpty(keyStagedFlipperR) then debug.print "keyStagedFlipperR is empty or undefined (check vpmkeys.vbs)" : e = True
2666		if IsEmpty(DebugTestKeys) then debug.print "no flipper key inputs detected (press some buttons, or check system vbs!)"
2667		if e then debug.print "--errors detected!--"
2668	End Sub
2669	'debug for finding sols	'vpmFlips.PrintSols
2670	Public Sub PrintSols() : Dim x, sols: sols=controller.solenoids: for x= 0 to uBound(sols) : if sols(x) then debug.print x & ":" & sols(x) end if : Next : End Sub	'debug for finding sols	
2671
2672	'set callbacks
2673	Public Property Let CallBackL(aInput)  : SubL  = aInput : SolCallback(sLLFlipper) = Empty: End Property	'execute
2674	Public Property Let CallBackUL(aInput) : SubUL = aInput : SolCallback(sULFlipper) = Empty: End Property
2675	Public Property Let CallBackR(aInput)  : SubR  = aInput : SolCallback(sLRFlipper) = Empty: End Property
2676	Public Property Let CallBackUR(aInput) : SubUR = aInput : SolCallback(sURFlipper) = Empty: End Property
2677	
2678	'Automatically decouple flipper solcallback script lines (only if both are pointing to the same sub) thanks gtxjoe
2679	Private Sub Decouple(aSolType, aInput)  : If StrComp(SolCallback(aSolType),aInput,1) = 0 then SolCallback(aSolType) = Empty End If : End Sub
2680	Public Property Let Solenoid(aInput) : if not IsEmpty(aInput) then Sol = aInput : end if : End Property	'set solenoid
2681	Public Property Get Solenoid : Solenoid = sol : End Property
2682	
2683	'call callbacks
2684	Public Sub FlipL(aEnabled)
2685		DebugTestKeys = True
2686		FlipState(0) = aEnabled	'track flipper button states: the game-on sol flips immediately if the button is held down (1.1)
2687		If not FlippersEnabled and not DebugOn then Exit Sub
2688		execute subL & " " & aEnabled
2689	End Sub
2690
2691	Public Sub FlipR(aEnabled)
2692		DebugTestKeys = True
2693		FlipState(1) = aEnabled
2694		If not FlippersEnabled and not DebugOn then Exit Sub
2695		execute subR & " " & aEnabled
2696	End Sub
2697
2698	Public Sub FlipUL(aEnabled)
2699		FlipState(2) = aEnabled
2700		If not FlippersEnabled and not DebugOn then Exit Sub
2701		execute subUL & " " & aEnabled
2702	End Sub	
2703
2704	Public Sub FlipUR(aEnabled)
2705		FlipState(3) = aEnabled
2706		If not FlippersEnabled and not DebugOn then Exit Sub
2707		execute subUR & " " & aEnabled
2708	End Sub	
2709	
2710	Public Sub TiltSol(aEnabled)	'Handle solenoid / Delay (if delayinit)
2711		If delay > 0 and not aEnabled then 	'handle delay
2712			vpmtimer.addtimer Delay, Name & ".FireDelay" & "'"
2713			LagCompensation = True
2714		else
2715			If Delay > 0 then LagCompensation = False
2716			EnableFlippers(aEnabled)
2717		end If
2718	End Sub
2719	
2720	Sub FireDelay() : If LagCompensation then EnableFlippers False End If : End Sub
2721	
2722	Public Sub EnableFlippers(aEnabled)	'private
2723		If aEnabled then execute SubL & " " & FlipState(0) : execute SubR & " " & FlipState(1) : execute subUL & " " & FlipState(2) : execute subUR & " " & FlipState(3)
2724		FlippersEnabled = aEnabled
2725		If TiltObjects then vpmnudge.solgameon aEnabled
2726		If Not aEnabled then
2727			execute subL & " " & False
2728			execute subR & " " & False
2729			execute subUL & " " & False
2730			execute subUR & " " & False
2731		End If
2732	End Sub
2733End Class
2734
2735
2736'---------------------------
2737' Check VP version running
2738'---------------------------
2739Private Function vpmCheckVPVer
2740	On Error Resume Next
2741	' a bug in VBS?: Err object is not cleared on Exit Function
2742	If VPBuildVersion < 0 Or Err Then vpmCheckVPVer = 50 : Err.Clear : Exit Function
2743	If VPBuildVersion > 2806 and VPBuildVersion < 9999 Then
2744		vpmCheckVPVer = 63
2745	ElseIf VPBuildVersion > 2721 and VPBuildVersion < 9999 Then
2746		vpmCheckVPVer = 61
2747	ElseIf VPBuildVersion >= 900 and VPBuildVersion <= 999 Then
2748		vpmCheckVPVer = 90
2749	ElseIf VPBuildVersion >= 10000 Then
2750		vpmCheckVPVer = 100
2751	Else
2752		vpmCheckVPVer = 60
2753	End If
2754End Function
2755Private vpmVPVer : vpmVPVer = vpmCheckVPVer()
2756'--------------------
2757' Initialise timers
2758'--------------------
2759Sub PulseTimer_Init   : vpmTimer.InitTimer Me, False : End Sub
2760Sub PinMAMETimer_Init : Me.Interval = PinMAMEInterval : Me.Enabled = True : End Sub
2761
2762'---------------------------------------------
2763' Init function called from Table_Init event
2764'---------------------------------------------
2765Public Sub vpmInit(aTable)
2766	Set vpmTable = aTable
2767	If vpmVPVer >= 60 Then
2768	  On Error Resume Next
2769		If Not IsObject(GetRef(aTable.name & "_Paused")) Or Err Then Err.Clear : vpmBuildEvent aTable, "Paused", "Controller.Pause = True"
2770		If Not IsObject(GetRef(aTable.name & "_UnPaused")) Or Err Then Err.Clear : vpmBuildEvent aTable, "UnPaused", "Controller.Pause = False"
2771		If Not IsObject(GetRef(aTable.name & "_Exit")) Or Err Then Err.Clear : vpmBuildEvent aTable, "Exit", "Controller.Pause = False:Controller.Stop"
2772	End If
2773	if UseModSol Then
2774		If Controller.Version >= 02080000 Then
2775		  Controller.SolMask(2)=1
2776		Else
2777		  MsgBox "Modulated Flashers/Solenoids not supported with this Visual PinMAME version (2.8 or newer is required)"
2778		End If
2779	End If
2780	InitVpmFlips
2781End Sub
2782
2783' Exit function called in Table_Exit event
2784Public Sub vpmExit : End Sub
2785'------------------------------------------------------
2786' All classes call this function to create a ball
2787' Assign vpmCreateBall if you want a custom function
2788'------------------------------------------------------
2789Private Function vpmDefCreateBall(aKicker)
2790	If Not IsEmpty(vpmBallImage) Then aKicker.Createball.Image = vpmBallImage Else aKicker.Createball : End If
2791	Set vpmDefCreateBall = aKicker
2792End Function
2793
2794Private Function vpmDefCreateBall2(aKicker)
2795	If Not IsEmpty(vpmBallImage) Then aKicker.Createsizedball(BSize).Image = vpmBallImage Else aKicker.Createsizedball(BSize) : End If
2796	Set vpmDefCreateBall2 = aKicker
2797End Function
2798
2799Private Function vpmDefCreateBall3(aKicker)
2800	If Not IsEmpty(vpmBallImage) Then
2801		aKicker.CreateSizedBallWithMass(BSize,BMass).Image = vpmBallImage
2802	Else
2803		aKicker.CreateSizedBallWithMass BSize,BMass ' for whatever reason it doesn't work if using ()
2804	End If
2805	Set vpmDefCreateBall3 = aKicker
2806End Function
2807
2808If VPBuildVersion >= 10000 Then
2809	Set vpmCreateBall = GetRef("vpmDefCreateBall3")
2810ElseIf VPBuildVersion > 909 And vpmVPVer >= 90 Then
2811        Set vpmCreateBall = GetRef("vpmDefCreateBall2")
2812Else
2813	Set vpmCreateBall = GetRef("vpmDefCreateBall")
2814End If
2815
2816Private vpmTrough ' Default Trough. Used to clear up missing balls
2817Private vpmTable  ' Table object
2818
2819'-------------------
2820' Main Loop
2821'------------------
2822Private Const CHGNO = 0
2823Private Const CHGSTATE = 1
2824Private vpmTrueFalse : vpmTrueFalse = Array(" True", " False"," True")
2825
2826Sub vpmDoSolCallback(aNo, aEnabled)
2827	If SolCallback(aNo) <> "" Then Execute SolCallback(aNo) & vpmTrueFalse(aEnabled+1)
2828End Sub
2829
2830Sub vpmDoLampUpdate(aNo, aEnabled)
2831	On Error Resume Next : Lights(aNo).State = Abs(aEnabled)
2832End Sub
2833
2834Sub PinMAMETimer_Timer
2835	Dim ChgLamp,ChgSol,ChgGI, ii, tmp, idx, nsol, solon
2836	Dim DMDp
2837	Dim ChgNVRAM
2838
2839	'Me.Enabled = False 'this was supposed to be some kind of weird mutex, disable it
2840
2841	On Error Resume Next
2842		If UseDMD Then
2843			DMDp = Controller.RawDmdPixels
2844			If Not IsEmpty(DMDp) Then
2845				DMDWidth = Controller.RawDmdWidth
2846				DMDHeight = Controller.RawDmdHeight
2847				DMDPixels = DMDp
2848			End If
2849		ElseIf UseColoredDMD Then
2850			DMDp = Controller.RawDmdColoredPixels
2851			If Not IsEmpty(DMDp) Then
2852				DMDWidth = Controller.RawDmdWidth
2853				DMDHeight = Controller.RawDmdHeight
2854				DMDColoredPixels = DMDp
2855			End If
2856		End If
2857		If UseNVRAM Then
2858			If isObject(NVRAMCallback) Then
2859				ChgNVRAM = Controller.ChangedNVRAM 'Controller.NVRAM would deliver everything of the NVRAM all the time as 1D array
2860				If(Not IsEmpty(ChgNVRAM)) Then NVRAMCallback ChgNVRAM
2861			End If
2862		End If
2863		If UseLamps Then ChgLamp = Controller.ChangedLamps Else LampCallback
2864		If UseSolenoids Then ChgSol = Controller.ChangedSolenoids
2865		If isObject(GICallback) or isObject(GICallback2) Then ChgGI = Controller.ChangedGIStrings
2866		MotorCallback
2867	On Error Goto 0
2868	If Not IsEmpty(ChgLamp) Then
2869		On Error Resume Next
2870			For ii = 0 To UBound(ChgLamp)
2871				idx = chgLamp(ii, 0)
2872				If IsArray(Lights(idx)) Then
2873					For Each tmp In Lights(idx) : tmp.State = ChgLamp(ii, 1) : Next
2874				Else
2875					Lights(idx).State = ChgLamp(ii, 1)
2876				End If
2877			Next
2878			For Each tmp In vpmMultiLights
2879				For ii = 1 To UBound(tmp) : tmp(ii).State = tmp(0).State : Next
2880			Next
2881			LampCallback
2882		On Error Goto 0
2883	End If
2884	If Not IsEmpty(ChgSol) Then
2885		For ii = 0 To UBound(ChgSol)
2886			nsol = ChgSol(ii, 0)
2887			tmp = SolCallback(nsol)
2888			solon = ChgSol(ii, 1)
2889			If solon > 1 Then solon = 1
2890			If UseModSol Then
2891				If solon <> SolPrevState(nsol) Then
2892					SolPrevState(nsol) = solon
2893					If tmp <> "" Then Execute tmp & vpmTrueFalse(solon+1)
2894				End If
2895				tmp = SolModCallback(nsol)
2896				If tmp <> "" Then Execute tmp & " " & ChgSol(ii, 1)
2897			Else
2898				If tmp <> "" Then Execute tmp & vpmTrueFalse(solon+1)
2899			End If
2900		if UseSolenoids > 1 then if nsol = vpmFlips.Solenoid then vpmFlips.TiltSol cbool(solon) 
2901		Next
2902	End If
2903	If Not IsEmpty(ChgGI) Then
2904		For ii = 0 To UBound(ChgGI)
2905			GICallback ChgGI(ii, 0), CBool(ChgGI(ii, 1))
2906			GICallback2 ChgGI(ii, 0), ChgGI(ii, 1)
2907		Next
2908	End If
2909
2910	'Me.Enabled = True 'this was supposed to be some kind of weird mutex, disable it
2911End Sub
2912
2913'
2914' Private helper functions
2915'
2916Private Sub vpmPlaySound(aEnabled, aSound)
2917	If VarType(aSound) = vbString Then
2918		If aEnabled Then StopSound aSound : PlaySound aSound
2919	ElseIf aSound Then
2920		If aEnabled Then PlaySound SSolenoidOn Else PlaySound SSolenoidOff
2921	End If
2922End Sub
2923
2924Private Sub vpmToggleObj(aObj, aEnabled)
2925	Dim mSwcopy
2926	Select Case TypeName(aObj)
2927		Case "Wall"                        aObj.IsDropped = aEnabled
2928		Case "Bumper", "Light"             aObj.State     = Abs(aEnabled)
2929		Case "Kicker", "Trigger", "Timer"  aObj.Enabled   = aEnabled
2930		Case "Gate"                        aObj.Open      = aEnabled
2931		Case "Integer"                     mSwcopy = aObj : Controller.Switch(mSwcopy) = aEnabled
2932		Case Else MsgBox "vpmToggleObj: Unhandled Object " & TypeName(aObj)
2933	End Select
2934End Sub
2935
2936Private Function vpmCheckEvent(aName, aObj)
2937	vpmCheckEvent = True
2938	On Error Resume Next
2939	If Not Eval(aName) Is aObj Or Err Then MsgBox "CreateEvents: Wrong name " & aName : vpmCheckEvent = False
2940End Function
2941
2942Private Sub vpmBuildEvent(aObj, aEvent, aTask)
2943	Dim obj, str
2944	str = "_" & aEvent & " : " & aTask & " : End Sub"
2945	If vpmIsArray(aObj) Then
2946		For Each obj In aObj : ExecuteGlobal "Sub " & obj.Name & str : Next
2947	Else
2948		ExecuteGlobal "Sub " & aObj.Name & str
2949	End If
2950End Sub
2951
2952Private Function vpmIsCollection(aObj)
2953	vpmIsCollection =  TypeName(aObj) = "Collection" Or TypeName(aObj) = "ICollection"
2954End Function
2955Private Function vpmIsArray(aObj)
2956	vpmIsArray = IsArray(aObj) Or vpmIsCollection(aObj)
2957End Function
2958
2959Private Function vpmSetArray(aTo, aFrom)
2960	If IsArray(aFrom) Then
2961		aTo = aFrom : vpmSetArray = UBound(aFrom)
2962	ElseIf vpmIsCollection(aFrom) Then
2963		Set aTo = aFrom : vpmSetArray = aFrom.Count - 1
2964	Else
2965		aTo = Array(aFrom) : vpmSetArray = 0
2966	End If
2967End Function
2968
2969Sub vpmCreateEvents(aHitObjs)
2970	Dim obj
2971	For Each obj In aHitObjs
2972		Select Case TypeName(obj)
2973			Case "Trigger"
2974				vpmBuildEvent obj, "Hit", "Controller.Switch(" & Obj.TimerInterval & ") = True"
2975				vpmBuildEvent obj, "UnHit", "Controller.Switch(" & Obj.TimerInterval & ") = False"
2976			Case "Wall"
2977				If obj.HasHitEvent Then
2978					vpmBuildEvent obj, "Hit", "vpmTimer.PulseSw " & Obj.TimerInterval
2979				Else
2980					vpmBuildEvent obj, "SlingShot", "vpmTimer.PulseSw " & Obj.TimerInterval
2981				End If
2982			Case "Bumper", "Gate"
2983				vpmBuildEvent obj, "Hit","vpmTimer.PulseSw " & Obj.TimerInterval
2984			Case "Spinner"
2985				vpmBuildEvent obj, "Spin","vpmTimer.PulseSw " & Obj.TimerInterval
2986		End Select
2987	Next
2988End Sub
2989
2990Sub vpmMapLights(aLights)
2991	Dim obj, str, ii, idx
2992	For Each obj In aLights
2993		idx = obj.TimerInterval
2994		If IsArray(Lights(idx)) Then
2995			str = "Lights(" & idx & ") = Array("
2996			For Each ii In Lights(idx) : str = str & ii.Name & "," : Next
2997			ExecuteGlobal str & obj.Name & ")"
2998		ElseIf IsObject(Lights(idx)) Then
2999            Lights(idx) = Array(Lights(idx),obj)
3000		Else
3001			Set Lights(idx) = obj
3002		End If
3003	Next
3004End Sub
3005
3006Function vpmMoveBall(aBall, aFromKick, aToKick)
3007	With aToKick.CreateBall
3008		If TypeName(aBall) = "IBall" Then
3009			.Color = aBall.Color   : .Image = aBall.Image
3010			If vpmVPVer >= 60 Then
3011				.FrontDecal = aBall.FrontDecal : .BackDecal = aBall.BackDecal
3012'				.UserValue = aBall.UserValue
3013			End If
3014		End If
3015	End With
3016	aFromKick.DestroyBall : Set vpmMoveBall = aToKick
3017End Function
3018
3019Sub vpmAddBall
3020Dim Answer
3021	If IsObject(vpmTrough) Then
3022			Answer=MsgBox("Click YES to Add a ball to the Trough, NO Removes a ball from the Trough",vbYesNoCancel + vbQuestion)
3023		If Answer = vbYes Then vpmTrough.AddBall 0
3024		If Answer = vbNo Then vpmTrough.Balls=vpmTrough.Balls-1
3025	End If
3026End Sub
3027
3028'----------------------------
3029' Generic solenoid handlers
3030'----------------------------
3031' ----- Flippers ------
3032Sub vpmSolFlipper(aFlip1, aFlip2, aEnabled)
3033	Dim oldStrength, oldSpeed ' only for pre-VP10
3034	If aEnabled Then
3035		PlaySound SFlipperOn : aFlip1.RotateToEnd : If Not aFlip2 Is Nothing Then aFlip2.RotateToEnd
3036	Else
3037		PlaySound SFlipperOff
3038        If VPBuildVersion < 10000 Then
3039			oldStrength = aFlip1.Strength : aFlip1.Strength = conFlipRetStrength
3040            oldSpeed = aFlip1.Speed : aFlip1.Speed = conFlipRetSpeed
3041        End If
3042		aFlip1.RotateToStart
3043        If VPBuildVersion < 10000 Then
3044		    aFlip1.Strength = oldStrength
3045            aFlip1.Speed = oldSpeed
3046        End If
3047		If Not aFlip2 Is Nothing Then
3048            If VPBuildVersion < 10000 Then
3049				oldStrength = aFlip2.Strength : aFlip2.Strength = conFlipRetStrength
3050                oldSpeed = aFlip2.Speed : aFlip2.Speed = conFlipRetSpeed
3051            End If
3052			aFlip2.RotateToStart
3053            If VPBuildVersion < 10000 Then
3054			    aFlip2.Strength = oldStrength
3055                aFlip2.Speed = oldSpeed
3056            End If
3057		End If
3058	End If
3059End Sub
3060
3061' ----- Flippers With Speed Control ------
3062Sub vpmSolFlip2(aFlip1, aFlip2, aFlipSpeedUp, aFlipSpeedDn, aSnd, aEnabled) ' DEPRECATED, as VP10 does not feature speed on flippers anymore
3063	Dim oldStrength, oldSpeed
3064	If aEnabled Then
3065		If aSnd = true then : PlaySound SFlipperOn : End If
3066		If Not aFlipSpeedUp = 0 Then
3067			aFlip1.Speed = aFlipSpeedUp
3068			aFlip1.RotateToEnd
3069		Else
3070			aFlip1.RotateToEnd
3071		End If
3072		If Not aFlip2 Is Nothing Then 
3073			If Not aFlipSpeedUp = 0 Then
3074				aFlip2.Speed = aFlipSpeedUp
3075				aFlip2.RotateToEnd
3076			Else
3077				aFlip2.RotateToEnd
3078			End If
3079		End If
3080	Else
3081		If aSnd = true then : PlaySound SFlipperOff : End If
3082		oldStrength = aFlip1.Strength
3083		aFlip1.Strength = conFlipRetStrength
3084		oldSpeed = aFlip1.Speed
3085		If Not aFlipSpeedDn = 0 Then
3086			aFlip1.Speed = aFlipSpeedDn 
3087		Else 
3088			aFlip1.Speed = conFlipRetSpeed
3089		End If
3090		aFlip1.RotateToStart : aFlip1.Strength = oldStrength : aFlip1.Speed = oldSpeed
3091		If Not aFlip2 Is Nothing Then
3092			oldStrength = aFlip2.Strength
3093			oldSpeed = aFlip2.Speed 
3094			If Not aFlipSpeedDn = 0 Then
3095				aFlip2.Speed = aFlipSpeedDn 
3096			Else 
3097				aFlip2.Speed = conFlipRetSpeed
3098			End If
3099			aFlip2.Strength = conFlipRetStrength
3100			aFlip2.RotateToStart : aFlip2.Strength = oldStrength : aFlip2.Speed = oldSpeed
3101		End If
3102	End If
3103End Sub
3104
3105' ------ Diverters ------
3106Sub vpmSolDiverter(aDiv, aSound, aEnabled)
3107	If aEnabled Then aDiv.RotateToEnd : Else aDiv.RotateToStart
3108	vpmPlaySound aEnabled, aSound
3109End sub
3110
3111' ------ Walls ------
3112Sub vpmSolWall(aWall, aSound, aEnabled)
3113	Dim obj
3114	If vpmIsArray(aWall) Then
3115		For Each obj In aWall : obj.IsDropped = aEnabled : Next
3116	Else
3117		aWall.IsDropped = aEnabled
3118	End If
3119	vpmPlaySound aEnabled, aSound
3120End Sub
3121
3122Sub vpmSolToggleWall(aWall1, aWall2, aSound, aEnabled)
3123	Dim obj
3124	If vpmIsArray(aWall1) Then
3125		For Each obj In aWall1 : obj.IsDropped = aEnabled : Next
3126	Else
3127		aWall1.IsDropped = aEnabled
3128	End If
3129	If vpmIsArray(aWall2) Then
3130		For Each obj In aWall2 : obj.IsDropped = Not aEnabled : Next
3131	Else
3132		aWall2.IsDropped = Not aEnabled
3133	End If
3134	vpmPlaySound aEnabled, aSound
3135End Sub
3136
3137' ------- Autoplunger ------
3138Sub vpmSolAutoPlunger(aPlung, aVar, aEnabled)
3139	Dim oldFire
3140	If aEnabled Then
3141		oldFire = aPlung.FireSpeed : aPlung.FireSpeed = oldFire * (100-aVar*(2*Rnd-1))/100
3142		PlaySound SSolenoidOn : aPlung.Fire : aPlung.FireSpeed = oldFire
3143	Else
3144		aPlung.Pullback
3145	End If
3146End Sub
3147
3148' --------Autoplunger with Specified Sound To Play ---------
3149Sub vpmSolAutoPlungeS(aPlung, aSound, aVar, aEnabled)
3150	Dim oldFire
3151	If aEnabled Then
3152		oldFire = aPlung.FireSpeed : aPlung.FireSpeed = oldFire * (100-aVar*(2*Rnd-1))/100
3153		PlaySound aSound : aPlung.Fire : aPlung.FireSpeed = oldFire
3154	Else
3155		aPlung.Pullback
3156	End If
3157End Sub
3158
3159' --------- Gate -----------
3160Sub vpmSolGate(aGate, aSound, aEnabled)
3161	Dim obj
3162	If vpmIsArray(aGate) Then
3163		For Each obj In aGate : obj.Open = aEnabled : Next
3164	Else
3165		aGate.Open = aEnabled
3166	End If
3167	vpmPlaySound aEnabled, aSound
3168End Sub
3169
3170' ------ Sound Only -------
3171Sub vpmSolSound(aSound, aEnabled)
3172	If aEnabled Then StopSound aSound : PlaySound aSound
3173End Sub
3174
3175' ------- Flashers --------
3176Sub vpmFlasher(aFlash, aEnabled)
3177	Dim obj
3178	If vpmIsArray(aFlash) Then
3179		For Each obj In aFlash : obj.State = Abs(aEnabled) : Next
3180	Else
3181		aFlash.State = Abs(aEnabled)
3182	End If
3183End Sub
3184
3185'---- Generic object toggle ----
3186Sub vpmSolToggleObj(aObj1, aObj2, aSound, aEnabled)
3187	Dim obj
3188	If vpmIsArray(aObj1) Then
3189		If IsArray(aObj1(0)) Then
3190			For Each obj In aObj1(0) : vpmToggleObj obj, aEnabled     : Next
3191			For Each obj In aObj1(1) : vpmToggleObj obj, Not aEnabled : Next
3192		Else
3193			For Each obj In aObj1    : vpmToggleObj obj, aEnabled     : Next
3194		End If
3195	ElseIf Not aObj1 Is Nothing Then
3196		vpmToggleObj aObj1, aEnabled
3197	End If
3198	If vpmIsArray(aObj2) Then
3199		If IsArray(aObj2(0)) Then
3200			For Each obj In aObj2(0) : vpmToggleObj obj, Not aEnabled : Next
3201			For Each obj In aObj2(1) : vpmToggleObj obj, aEnabled     : Next
3202		Else
3203			For Each obj In aObj2    : vpmToggleObj obj, Not aEnabled : Next
3204		End If
3205	ElseIf Not aObj2 Is Nothing Then
3206		vpmToggleObj aObj2, Not aEnabled
3207	End If
3208	vpmPlaySound aEnabled, aSound
3209End Sub
3210
3211'
3212' Stubs to allow older games to still work
3213' These will be removed one day
3214'
3215Sub SolFlipper(f1,f2,e) : vpmSolFlipper f1,f2,e : End Sub
3216Sub SolDiverter(d,s,e) : vpmSolDiverter d,s,e : End Sub
3217Sub SolSound(s,e) : vpmSolSound s,e : End Sub
3218Sub Flasher(f,e) : vpmFlasher f,e : End Sub
3219Sub SolMagnet(m,e) : vpmSolMagnet m,e : End Sub
3220Sub SolAutoPlunger(p,e) : vpmSolAutoPlunger p,0,e : End Sub
3221Function KeyDownHandler(ByVal k) : KeyDownHandler = vpmKeyDown(k) : End Function
3222Function KeyUpHandler(ByVal k) : KeyUpHandler = vpmKeyUp(k) : End Function
3223Function KeyName(ByVal k) : KeyName = vpmKeyName(k) : End Function
3224Sub vpmSolMagnet(m,e) : m.Enabled = e : If Not e Then m.Kick 180,1 : End If : End Sub
3225Dim vpmBallImage : vpmBallImage = Empty ' Default ball properties
3226Dim vpmBallColour
3227
3228'-- Flipper solenoids (all games)
3229Const sLRFlipper = 46
3230Const sLLFlipper = 48
3231Const sURFlipper = 34
3232Const sULFlipper = 36
3233
3234' Convert keycode to readable string
3235Private keyNames1, keyNames2
3236keyNames1 = Array("Escape","1","2","3","4","5","6","7","8","9","0","Minus '-'",_
3237"Equals '='","Backspace","Tab","Q","W","E","R","T","Y","U","I","O","P","[","]",_
3238"Enter","Left Ctrl","A","S","D","F","G","H","J","K","L",";","'","`","Left Shift",_
3239"\","Z","X","C","V","B","N","M",",",".","/","Right Shift","*","Left Menu","Space",_
3240"Caps Lock","F1","F2","F3","F4","F5","F6","F7","F8","F9","F10","NumLock","ScrlLock",_
3241"Numpad 7","Numpad 8","Numpad 9","Numpad -","Numpad 4","Numpad 5","Numpad 6",_
3242"Numpad +","Numpad 1","Numpad 2","Numpad 3","Numpad 0","Numpad .","?","?","?",_
3243"F11","F12","F13","F14","F15")
3244keyNames2 = Array("Pause","?","Home","Up","PageUp","?","Left","?","Right","?",_
3245"End","Down","PageDown","Insert","Delete")
3246
3247Function vpmKeyName(ByVal aKeycode)
3248	If aKeyCode-1 <= UBound(keyNames1) Then
3249		vpmKeyName = keyNames1(aKeyCode-1)
3250	ElseIf aKeyCode >= 197 And aKeyCode <= 211 Then
3251		vpmKeyName = keyNames2(aKeyCode-197)
3252	ElseIf aKeyCode = 184 Then
3253		vpmKeyName = "R.Alt"
3254	Else
3255		vpmKeyName = "?"
3256	End If
3257End Function
3258
3259Private vpmSystemHelp
3260Private Sub vpmShowHelp
3261	Dim szKeyMsg
3262	szKeyMsg = "The following keys are defined: "                  & vbNewLine &_
3263	           "(American keyboard layout)"                        & vbNewLine &_
3264		vbNewLine & "Visual PinMAME keys:"                         & vbNewLine &_
3265		vpmKeyName(keyShowOpts)   & vbTab & "Game options..."      & vbNewLine &_
3266		vpmKeyName(keyShowKeys)   & vbTab & "Keyboard settings..." & vbNewLine &_
3267		vpmKeyName(keyReset)      & vbTab & "Reset emulation"      & vbNewLine &_
3268		vpmKeyName(keyFrame)      & vbTab & "Toggle Display lock"  & vbNewLine &_
3269		vpmKeyName(keyDoubleSize) & vbTab & "Toggle Display size"  & vbNewLine
3270	If IsObject(vpmShowDips) Then
3271			szKeyMsg = szKeyMsg & vpmKeyName(keyShowDips)   & vbTab & "Show DIP Switch / Option Menu" & vbNewLine
3272		End If
3273	If IsObject(vpmTrough) Then
3274		szKeyMsg = szKeyMsg & vpmKeyName(keyAddBall) & vbTab & "Add / Remove Ball From Table" & vbNewLine
3275	End If
3276	szKeyMsg = szKeyMsg & vpmKeyName(keyBangBack) & vbTab & "Bang Back" & vbNewLine &_
3277		vbNewLine & vpmSystemHelp & vbNewLine
3278	If ExtraKeyHelp <> "" Then
3279		szKeyMsg = szKeyMsg & vbNewLine & "Game Specific keys:" &_
3280			vbNewLine & ExtraKeyHelp & vbNewLine
3281	End If
3282	szKeyMsg = szKeyMsg & vbNewLine & "Visual Pinball keys:"     & vbNewLine &_
3283		vpmKeyName(LeftFlipperKey)  & vbTab & "Left Flipper"     & vbNewLine &_
3284		vpmKeyName(RightFlipperKey) & vbTab & "Right Flipper"    & vbNewLine &_
3285		vpmKeyName(LeftMagnaSave)   & vbTab & "Left Magna Save"  & vbNewLine &_
3286		vpmKeyName(RightMagnaSave)  & vbTab & "Right Magna Save" & vbNewLine &_
3287		vpmKeyName(PlungerKey)      & vbTab & "Launch Ball"      & vbNewLine &_
3288		vpmKeyName(StartGameKey)    & vbTab & "Start Button"     & vbNewLine &_
3289		vpmKeyName(AddCreditKey)    & vbTab & "Insert Coin 1"    & vbNewLine &_
3290		vpmKeyName(AddCreditKey2)   & vbTab & "Insert Coin 2"    & vbNewLine &_
3291		vpmKeyName(ExitGame)        & vbTab & "Exit Game"        & vbNewLine &_
3292		vpmKeyName(MechanicalTilt)  & vbTab & "Mechanical Tilt"  & vbNewLine &_
3293		vpmKeyName(LeftTiltKey)     & vbTab & "Nudge from Left"  & vbNewLine &_
3294		vpmKeyName(RightTiltKey)    & vbTab & "Nudge from Right" & vbNewLine &_
3295		vpmKeyName(CenterTiltKey)   & vbTab & "Nudge forward"    & vbNewLine
3296	MsgBox szKeyMsg,vbOkOnly,"Keyboard Settings..."
3297End Sub
3298
3299Private Sub NullSub(no,enabled) 
3300'Place Holder Sub
3301End Sub
3302
3303'added thanks to Koadic
3304Sub NVOffset(version) ' version 2 for dB2S compatibility
3305	Dim check,nvcheck,v,vv,nvpath,rom
3306	Set check = CreateObject("Scripting.FileSystemObject")
3307	Set nvcheck = CreateObject("WScript.Shell")
3308	nvpath = nvcheck.RegRead("HKCU\Software\Freeware\Visual PinMame\globals\nvram_directory") & "\"
3309	rom = controller.gamename
3310	For v=1 to 32 'check up to 32 possible versions using same rom, it's overkill, but could be changed to a lower number (requested for 32 NFL variations)
3311		If check.FileExists(nvpath & rom & " v" & v & ".txt") Then vv=v : exit For : End If
3312		vv=0
3313	Next
3314	If vv=version or version = 0 Then
3315		Exit Sub
3316	ElseIf vv=0 Then
3317		check.CreateTextFile nvpath & rom & " v" & version & ".txt", True
3318		Exit Sub
3319	Else
3320		check.moveFile nvpath & rom & " v" & vv & ".txt", nvpath & rom & " v" & version & ".txt"
3321		If check.FileExists(nvpath & rom & ".nv") Then
3322			check.copyFile nvpath & rom & ".nv", nvpath & rom & " v" & vv & ".nv", True
3323		End If
3324		If check.FileExists(nvpath & rom & " v" & version & ".nv") Then
3325			check.copyFile nvpath & rom & " v" & version & ".nv", nvpath & rom & ".nv", True
3326		End If
3327	End If
3328End Sub
3329
3330Sub VPMVol
3331	dim VolPM,VolPMNew
3332	VolPM = Controller.Games(controller.GameName).Settings.Value("volume")
3333	VolPMNew = InputBox ("Enter desired VPinMame Volume Level (-32 to 0)","VPinMame Volume",VolPM)
3334	If VolPMNew = "" Then Exit Sub
3335	If VolPMNew <=0 and VolPMNew >= -32 Then
3336		Controller.Games(controller.GameName).Settings.Value("volume")= round(VolPMNew)
3337		msgbox "The Visual PinMAME Global Volume is now set to " & round(VolPMNew) & "db." & VbNewLine & VbNewLine & "Please reset Visual PinMAME (F3) to apply."
3338	Else
3339		msgbox "Entered value is out of range. Entry must be in the range of negative 32 to 0." & VbNewLine & VbNewLine & "Visual PinMAME Global Volume will remain set at " & VolPM & "."
3340	End If
3341End Sub
3342
3343' Simple min/max functions
3344Function vpMin(a, b) : If a < b Then vpMin = a Else vpMin = b : End If : End Function
3345Function vpMax(a, b) : If a > b Then vpMax = a Else vpMax = b : End If : End Function
3346
3347LoadScript("ledcontrol.vbs"):Err.Clear	' Checks for existance of ledcontrol.vbs and loads it if found, if found but no ledwiz installed, clear error to allow loading of table
3348
3349LoadScript("GlobalPlugIn.vbs") 			' Checks for existance of GlobalPlugIn.vbs and loads it if found, useful for adding
3350										' custom scripting that can be used for all tables instead of altering the core.vbs
3351
3352
3353'-------------------------
3354' S11 Data
3355'-------------------------
3356' Flipper Solenoid
3357Const GameOnSolenoid = 23
3358' Cabinet switches
3359Const swAdvance        = -7
3360Const swUpDown         = -6
3361Const swCPUDiag        = -5
3362Const swSoundDiag      = -4
3363Const swTilt           =  1
3364Const swBallRollTilt   =  2
3365Const swStartButton    =  3
3366Const swCoin3          =  4
3367Const swCoin2          =  5
3368Const swCoin1          =  6
3369Const swSlamTilt       =  7
3370Const swHiScoreReset   =  8
3371
3372Const swLRFlip         = 82
3373Const swLLFlip         = 84
3374
3375' Help Window
3376vpmSystemHelp = "Williams System 9/11 keys:" & vbNewLine &_
3377  vpmKeyName(keyInsertCoin1)  & vbTab & "Insert Coin #1"   & vbNewLine &_
3378  vpmKeyName(keyInsertCoin2)  & vbTab & "Insert Coin #2"   & vbNewLine &_
3379  vpmKeyName(keyInsertCoin3)  & vbTab & "Insert Coin #3"   & vbNewLine &_
3380  vpmKeyName(keyHiscoreReset) & vbTab & "Hiscore Reset"    & vbNewLine &_
3381  vpmKeyName(keyAdvance)      & vbTab & "Advance"          & vbNewLine &_
3382  vpmKeyName(keyUpDown)       & vbTab & "Up/Down"          & vbNewLine &_
3383  vpmKeyName(keyCPUDiag)      & vbTab & "Cpu Diagnostic"   & vbNewLine &_
3384  vpmKeyName(keySoundDiag)    & vbTab & "Sound Diagnostic" & vbNewLine &_
3385  vpmKeyName(keySlamDoorHit)  & vbTab & "Slam Tilt"
3386
3387' Dip Switch / Options Menu
3388Private Sub s11ShowDips
3389	If Not IsObject(vpmDips) Then ' First time
3390		Set vpmDips = New cvpmDips
3391		With vpmDips
3392			.AddForm 150, 45, "DIP Switches"
3393			.AddChk  0,0,100, Array("Germany", &H0001)
3394		End With
3395	End If
3396	vpmDips.ViewDips
3397End Sub
3398Set vpmShowDips = GetRef("s11ShowDips")
3399Private vpmDips
3400
3401' Keyboard handlers
3402Function vpmKeyDown(ByVal keycode)
3403	On Error Resume Next
3404	vpmKeyDown = True ' Assume we handle the key
3405	With Controller
3406		Select Case keycode
3407			Case LeftFlipperKey  .Switch(swLLFlip) = True : vpmKeyDown = False :  vpmFlips.FlipL True : if keycode = keyStagedFlipperL then vpmFlips.FlipUL True
3408			Case RightFlipperKey .Switch(swLRFlip) = True : vpmKeyDown = False :  vpmFlips.FlipR True : if keycode = keyStagedFlipperR then vpmFlips.FlipUR True
3409			Case keyStagedFlipperL vpmFlips.FlipUL True
3410			Case keyStagedFlipperR vpmFlips.FlipUR True
3411			Case keyInsertCoin1  vpmTimer.AddTimer 750,"vpmTimer.PulseSw swCoin1'" : Playsound SCoin
3412			Case keyInsertCoin2  vpmTimer.AddTimer 750,"vpmTimer.PulseSw swCoin2'" : Playsound SCoin
3413			Case keyInsertCoin3  vpmTimer.AddTimer 750,"vpmTimer.PulseSw swCoin3'" : Playsound SCoin
3414			Case StartGameKey    .Switch(swStartButton)  = True
3415			Case keyUpDown       .Switch(swUpDown)       = Not .Switch(swUpDown)
3416			Case keyAdvance      .Switch(swAdvance)      = True
3417			Case keyCPUDiag      .Switch(swCPUDiag)      = True
3418			Case keySoundDiag    .Switch(swSoundDiag)    = True
3419			Case keyHiscoreReset .Switch(swHiscoreReset) = True
3420			Case keySlamDoorHit  .Switch(swSlamTilt)     = True
3421			Case keyBangBack     vpmNudge.DoNudge 0, 6
3422			Case LeftTiltKey     vpmNudge.DoNudge 75, 2
3423			Case RightTiltKey    vpmNudge.DoNudge 285, 2
3424			Case CenterTiltKey   vpmNudge.DoNudge 0, 2
3425			Case keyVPMVolume    vpmVol
3426			Case Else            vpmKeyDown = False
3427		End Select
3428	End With
3429	On Error Goto 0
3430End Function
3431
3432Function vpmKeyUp(ByVal keycode)
3433	On Error Resume Next
3434	vpmKeyUp = True ' Assume we handle the key
3435	With Controller
3436		Select Case keycode
3437			Case LeftFlipperKey  .Switch(swLLFlip) = False : vpmKeyUp = False :  vpmFlips.FlipL False : if keycode = keyStagedFlipperL then vpmFlips.FlipUL False
3438			Case RightFlipperKey .Switch(swLRFlip) = False : vpmKeyUp = False :  vpmFlips.FlipR False : if keycode = keyStagedFlipperR then vpmFlips.FlipUR False
3439			Case keyStagedFlipperL vpmFlips.FlipUL False
3440			Case keyStagedFlipperR vpmFlips.FlipUR False
3441			Case StartGameKey    .Switch(swStartButton)  = False
3442			Case keyAdvance      .Switch(swAdvance)      = False
3443			Case keyCPUDiag      .Switch(swCPUDiag)      = False
3444			Case keySoundDiag    .Switch(swSoundDiag)    = False
3445			Case keyHiscoreReset .Switch(swHiscoreReset) = False
3446			Case keySlamDoorHit  .Switch(swSlamTilt)     = False
3447			Case keyShowOpts     .Pause = True : .ShowOptsDialog GetPlayerHWnd : .Pause = False
3448			Case keyShowKeys     .Pause = True : vpmShowHelp : .Pause = False
3449			Case keyShowDips     If IsObject(vpmShowDips) Then .Pause = True : vpmShowDips : .Pause = False
3450			Case keyAddBall      .Pause = True : vpmAddBall  : .Pause = False
3451			Case keyReset        .Stop : BeginModal : .Run : vpmTimer.Reset : EndModal
3452			Case keyFrame        .LockDisplay = Not .LockDisplay
3453			Case keyDoubleSize   .DoubleSize  = Not .DoubleSize
3454			Case Else            vpmKeyUp = False
3455		End Select
3456	End With
3457	On Error Goto 0
3458End Function
3459
3460
3461
3462Dim bsTrough, bsDog, bsTrash, dtBird, dtMilk
3463Const cGameName = "bcats_l5"
3464
3465Const UseSolenoids = 2
3466Const UseLamps = 0
3467Const UseGI = 0
3468Const UseSync = 1
3469Const HandleMech = 0
3470
3471'Standard Sounds
3472Const SSolenoidOn = "fx_Solenoid"
3473Const SSolenoidOff = ""
3474Const SCoin = "fx_Coin"
3475
3476'************
3477' Table init.
3478'************
3479dim HiddenVar
3480If Table1.ShowDT = False then 
3481	HiddenVar = 1
3482Else
3483	HiddenVar = 0
3484end If
3485
3486Sub Table1_Init
3487    vpmInit me
3488
3489    With Controller
3490        .GameName = cGameName
3491        If Err Then MsgBox "Can't start Game" & cGameName & vbNewLine & Err.Description:Exit Sub
3492        .SplashInfoLine = "BadCats, Williams 1989" & vbNewLine & "VPX table by unclewilly v.1.0"
3493        .Games(cGameName).Settings.Value("rol") = 0 '1= rotated display, 0= normal
3494        .HandleMechanics = 0
3495        .HandleKeyboard = 0
3496        .ShowDMDOnly = 1
3497        .ShowFrame = 0
3498        .ShowTitle = 0
3499        .Hidden = HiddenVar
3500        If Err Then MsgBox Err.Description
3501    End With
3502    On Error Goto 0
3503    Controller.Run
3504
3505    'Nudging
3506    vpmNudge.TiltSwitch = swTilt
3507    vpmNudge.Sensitivity = 2
3508    'vpmNudge.TiltObj = Array(sw60, sw61, sw62, LeftSlingshot, RightSlingShot)
3509
3510    'Trough
3511    Set bsTrough = New cvpmBallStack
3512    With bsTrough
3513        .InitSw 0, 10, 0, 0, 0, 0, 0, 0
3514        .InitKick ballrelease, 90, 4
3515        .InitEntrySnd "fx_Solenoid", "fx_Solenoid"
3516        .InitExitSnd SoundFX("fx_ballrel", DOFContactors), SoundFX("fx_Solenoid", DOFContactors)
3517        .IsTrough = True
3518        .Balls = 1
3519    End With
3520
3521    'Dog House hole
3522    Set bsDog = New cvpmBallStack
3523    With bsDog
3524        .InitSw 0, 22, 0, 0, 0, 0, 0, 0
3525        .InitKick Ralfie, 180, 22
3526        .InitEntrySnd "fx_kicker_enter", "fx_Solenoid"
3527        .InitExitSnd SoundFX("fx_kicker", DOFContactors), SoundFX("fx_Solenoid", DOFContactors)
3528        .IsTrough = False
3529    End With
3530
3531    'Trash hole
3532    Set bsTrash = New cvpmBallStack
3533    With bsTrash
3534        .InitSaucer Bin, 24, 79, 22
3535        .KickForceVar = 2
3536        .KickAngleVar = 2
3537        .InitExitSnd SoundFX("fx_kicker", DOFContactors), SoundFX("fx_kicker", DOFContactors)
3538        .InitAddSnd SoundFX("fx_kicker_enter", DOFContactors)
3539        .CreateEvents "bsTrash", Bin
3540    End With
3541
3542    'Droptargets
3543    set dtBird = new cvpmdroptarget
3544    With dtBird
3545        .InitDrop Array(sw25,sw26,sw27,sw28,sw29), Array(25, 26, 27, 28, 29)
3546        .Initsnd SoundFX("fx_droptarget", DOFContactors), SoundFX("fx_resetdrop", DOFContactors)
3547    End With
3548
3549    set dtMilk = new cvpmdroptarget
3550    With dtMilk
3551        .InitDrop Array(sw37,sw38,sw39), Array(37, 38, 39)
3552        .Initsnd SoundFX("fx_droptarget", DOFContactors), SoundFX("fx_resetdrop", DOFContactors)
3553    End With
3554
3555    ' Seafood Wheel
3556    Dim mSFWheelMech
3557    Set mSFWheelMech = New cvpmMech
3558    With mSFWheelMech
3559        .MType = vpmMechStepSol + vpmMechCircle + vpmMechLinear + vpmMechFast
3560        .Sol1 = 16
3561        .Sol2 = 15
3562        .Length = 200
3563        .Steps = 200
3564        .AddSw 44, 0, 99
3565        .Callback = GetRef("UpdateWheel")
3566        .Start
3567    End With
3568
3569'Init VariTarget
3570    sw19w21.IsDropped = 1
3571    sw19w31.IsDropped = 1
3572    sw19w41.IsDropped = 1
3573
3574    'Main Timer init
3575    PinMAMETimer.Interval = PinMAMEInterval
3576    PinMAMETimer.Enabled = 1
3577
3578
3579If Table1.ShowDT = False then
3580	For each xx in SideRails:xx.Visible = False:Next
3581End If
3582End Sub
3583
3584Sub table1_Paused:Controller.Pause = 1:End Sub
3585Sub table1_unPaused:Controller.Pause = 0:End Sub
3586Sub table1_exit:Controller.Stop:End Sub
3587'**********
3588' Keys
3589'**********
3590
3591Sub table1_KeyDown(ByVal Keycode)
3592        If keycode = LeftFlipperKey Then
3593			If FlipLag = 1 then flipnf 0, 1
3594        end if
3595        If keycode = RightFlipperKey Then
3596            If FlipLag = 1 then flipnf 1, 1
3597        end if
3598    If keycode = LeftTiltKey Then Nudge 90, 5:PlaySound SoundFX("fx_nudge", 0), 0, 1, -0.1, 0.25
3599    If keycode = RightTiltKey Then Nudge 270, 5:PlaySound SoundFX("fx_nudge", 0), 0, 1, 0.1, 0.25
3600    If keycode = CenterTiltKey Then Nudge 0, 6:PlaySound SoundFX("fx_nudge", 0), 0, 1, 0, 0.25
3601    If keycode = PlungerKey Then PlaySound "fx_PlungerPull", 0, 1, 0.1, 0.05:Plunger.Pullback
3602    If vpmKeyDown(keycode) Then Exit Sub
3603End Sub
3604
3605Sub table1_KeyUp(ByVal Keycode)
3606        If keycode = LeftFlipperKey Then
3607            If FlipLag = 1 then flipnf 0, 0
3608        end if
3609        If keycode = RightFlipperKey Then
3610            If FlipLag = 1 then flipnf 1, 0
3611        end if
3612    If keycode = PlungerKey Then PlaySound "fx_plunger", 0, 1, 0.1, 0.05:Plunger.Fire
3613    If vpmKeyUp(keycode) Then Exit Sub
3614End Sub
3615
3616'*********
3617' Switches
3618'*********
3619
3620'Slings & Rubbers
3621Dim LStep, RStep
3622
3623Sub LeftSlingShot_Slingshot
3624    PlaySound SoundFX("fx_slingshot", DOFContactors), 0, 1, -0.05, 0.05
3625    LeftSling4.Visible = 1
3626    Lemk.RotX = 26
3627    LStep = 0
3628    vpmTimer.PulseSw 63
3629    LeftSlingShot.TimerEnabled = 1
3630End Sub
3631
3632Sub LeftSlingShot_Timer
3633    Select Case LStep
3634        Case 1:LeftSLing4.Visible = 0:LeftSLing3.Visible = 1:Lemk.RotX = 14
3635        Case 2:LeftSLing3.Visible = 0:LeftSLing2.Visible = 1:Lemk.RotX = 2
3636        Case 3:LeftSLing2.Visible = 0:Lemk.RotX = -10:LeftSlingShot.TimerEnabled = 0
3637    End Select
3638    LStep = LStep + 1
3639End Sub
3640
3641Sub RightSlingShot_Slingshot
3642    PlaySound SoundFX("fx_slingshot", DOFContactors), 0, 1, 0.05, 0.05
3643    RightSling4.Visible = 1
3644    Remk.RotX = 26
3645    RStep = 0
3646    vpmTimer.PulseSw 64
3647    RightSlingShot.TimerEnabled = 1
3648End Sub
3649
3650Sub RightSlingShot_Timer
3651    Select Case RStep
3652        Case 1:RightSLing4.Visible = 0:RightSLing3.Visible = 1:Remk.RotX = 14
3653        Case 2:RightSLing3.Visible = 0:RightSLing2.Visible = 1:Remk.RotX = 2
3654        Case 3:RightSLing2.Visible = 0:Remk.RotX = -10:RightSlingShot.TimerEnabled = 0
3655    End Select
3656    RStep = RStep + 1
3657End Sub
3658
3659'Rubbers
3660
3661Sub sw40_Hit():PlaySound "fx_Rubber", 0, 1, -0.1, 0.15::vpmTimer.PulseSw 40:End Sub
3662Sub sw33_Hit():PlaySound "fx_Rubber", 0, 1, 0.1, 0.15::vpmTimer.PulseSw 33:End Sub
3663Sub sw34_Hit():PlaySound "fx_Rubber", 0, 1, 0.1, 0.15::vpmTimer.PulseSw 34:End Sub
3664
3665
3666' Bumpers
3667Sub sw60_Hit:vpmTimer.PulseSw 60:PlaySound SoundFX("fx_bumper", DOFContactors), 0, 1, -0.1, 0.15:End Sub
3668Sub sw61_Hit:vpmTimer.PulseSw 61:PlaySound SoundFX("fx_bumper", DOFContactors), 0, 1, 0.1, 0.15:End Sub
3669Sub sw62_Hit:vpmTimer.PulseSw 62:PlaySound SoundFX("fx_bumper", DOFContactors), 0, 1, 0, 0.15:End Sub
3670
3671
3672'Rollover & Ramp Switches
3673Sub sw11_Hit:Controller.Switch(11) = 1:PlaySound "fx_sensor", 0, 1, -0.1, 0.15:End Sub
3674Sub sw11_UnHit:Controller.Switch(11) = 0:End Sub
3675
3676Sub sw12_Hit:Controller.Switch(12) = 1:PlaySound "fx_sensor", 0, 1, 0, 0.15:End Sub
3677Sub sw12_UnHit:Controller.Switch(12) = 0:End Sub
3678
3679Sub sw13_Hit:Controller.Switch(13) = 1:PlaySound "fx_sensor", 0, 1, 0, 0.15:End Sub
3680Sub sw13_UnHit:Controller.Switch(13) = 0:End Sub
3681
3682Sub sw14_Hit:Controller.Switch(14) = 1:PlaySound "fx_sensor", 0, 1, 0, 0.15:End Sub
3683Sub sw14_UnHit:Controller.Switch(14) = 0:End Sub
3684
3685Sub sw36_Hit:Controller.Switch(36) = 1:PlaySound "fx_sensor", 0, 1, -0.1, 0.15:End Sub
3686Sub sw36_UnHit:Controller.Switch(36) = 0:End Sub
3687
3688Sub sw30_Hit:Controller.Switch(30) = 1:PlaySound "fx_sensor", 0, 1, -0.1, 0.15:End Sub
3689Sub sw30_UnHit:Controller.Switch(30) = 0:End Sub
3690
3691Sub sw31_Hit:Controller.Switch(31) = 1:PlaySound "fx_sensor", 0, 1, 0.1, 0.15:End Sub
3692Sub sw31_UnHit:Controller.Switch(31) = 0:End Sub
3693
3694Sub sw35_Hit:Controller.Switch(35) = 1:PlaySound "fx_sensor", 0, 1, -0.1, 0.15:End Sub
3695Sub sw35_UnHit:Controller.Switch(35) = 0:End Sub
3696
3697Sub sw41_Hit:Controller.Switch(41) = 1:sw41.Timerenabled = 1:PlaySound "fx_sensor", 0, 1, 0.1, 0.15:End Sub
3698Sub sw41_UnHit:Controller.Switch(41) = 0:End Sub
3699dim sw41Dir
3700sw41Dir = -1
3701Sub sw41_Timer()
3702	If sw41P.ObjRotZ = 60 then sw41Dir = 5
3703	If sw41P.ObjRotZ = 90 then sw41Dir = -5
3704	sw41P.ObjRotZ = sw41P.ObjRotZ + sw41Dir
3705	If sw41P.ObjRotZ = 90 then sw41.timerenabled = 0
3706End Sub
3707
3708Sub sw43_Hit:Controller.Switch(43) = 1:sw43.Timerenabled = 1:PlaySound "fx_sensor", 0, 1, 0.1, 0.15:End Sub
3709Sub sw43_UnHit:Controller.Switch(43) = 0:End Sub
3710dim sw43Dir
3711sw43Dir = -1
3712Sub sw43_Timer()
3713	If sw43P.ObjRotZ = 60 then sw43Dir = 5
3714	If sw43P.ObjRotZ = 90 then sw43Dir = -5
3715	sw43P.ObjRotZ = sw43P.ObjRotZ + sw43Dir
3716	If sw43P.ObjRotZ = 90 then sw43.timerenabled = 0
3717End Sub
3718
3719'Ramp Gates
3720Sub sw16_Hit:vpmTimer.PulseSw 16:End Sub
3721
3722Sub sw23_Hit:vpmTimer.PulseSw 23:End Sub
3723
3724' Linear Fish Target
3725
3726Sub sw19_1_Hit:vpmTimer.PulseSw 19:PlaySound SoundFX("fx_target", DOFContactors), 0, 1, -0.1, 0.15:Fisht.transY = -50:sw19w11.IsDropped = 1:sw19w21.IsDropped = 0:End Sub
3727
3728Sub sw19_2_Hit:vpmTimer.PulseSw 19:PlaySound SoundFX("fx_target", DOFContactors), 0, 1, -0.1, 0.15:Fisht.transY = -95:sw19w21.IsDropped = 1:sw19w31.IsDropped = 0:End Sub
3729
3730Sub sw19_3_Hit:vpmTimer.PulseSw 19:PlaySound SoundFX("fx_target", DOFContactors), 0, 1, -0.1, 0.15:Fisht.transY = -135:sw19w31.IsDropped = 1:sw19w41.IsDropped = 0:End Sub
3731
3732Sub sw19_4_Hit:vpmTimer.PulseSw 19:PlaySound SoundFX("fx_target", DOFContactors), 0, 1, -0.1, 0.15:End Sub
3733
3734Sub sw19_1_UnHit
3735    If ActiveBall.VelY > 0 Then
3736		
3737        sw19w11.IsDropped = 0
3738        sw19w21.IsDropped = 1
3739    End If
3740End Sub
3741
3742Sub sw19_2_UnHit
3743    If ActiveBall.VelY > 0 Then
3744
3745        sw19w21.IsDropped = 0
3746        sw19w31.IsDropped = 1
3747    End If
3748End Sub
3749
3750Sub sw19_3_UnHit
3751    If ActiveBall.VelY > 0 Then
3752
3753        sw19w31.IsDropped = 0
3754        sw19w41.IsDropped = 1
3755    End If
3756End Sub
3757
3758Sub sw19_4_UnHit
3759End Sub
3760
3761Sub Fanimation_UnHit():FTTimer.Enabled = 1:End Sub
3762
3763Sub FTTimer_Timer()
3764	If FishT.TransY < 0 Then
3765		FishT.TransY =FishT.TransY + 5
3766	Else
3767		FTTimer.enabled = 0
3768	end If
3769End Sub
3770
3771'Droptargets VPX
3772Sub sw25_Hit:PlaySound SoundFX("fx_droptarget", DOFContactors), 0, 1, -0.1, 0.15:End Sub 'hit event only for the sound
3773Sub sw25_Dropped:dtBird.hit 1:If GIState=1 then:sw25l.State = 1:end if: sw25.Image = "BirdTD": End Sub
3774
3775Sub sw26_Hit:PlaySound SoundFX("fx_droptarget", DOFContactors), 0, 1, -0.1, 0.15:End Sub 'hit event only for the sound
3776Sub sw26_Dropped:dtBird.hit 2:If GIState=1 then:sw26l.State = 1:end if:sw26.Image = "BirdTD": End Sub
3777
3778Sub sw27_Hit:PlaySound SoundFX("fx_droptarget", DOFContactors), 0, 1, -0.1, 0.15:End Sub 'hit event only for the sound
3779Sub sw27_Dropped:dtBird.hit 3:If GIState=1 then:sw27l.State = 1:end if:sw27.Image = "BirdTD": End Sub
3780
3781Sub sw28_Hit:PlaySound SoundFX("fx_droptarget", DOFContactors), 0, 1, -0.1, 0.15:End Sub 'hit event only for the sound
3782Sub sw28_Dropped:dtBird.hit 4:If GIState=1 then:sw28l.State = 1:end if:sw28.Image = "BirdTD": End Sub
3783
3784Sub sw29_Hit:PlaySound SoundFX("fx_droptarget", DOFContactors), 0, 1, -0.1, 0.15:End Sub 'hit event only for the sound
3785Sub sw29_Dropped:dtBird.hit 5:sw29.Image = "BirdTD": End Sub
3786
3787Sub sw37_Hit:PlaySound SoundFX("fx_droptarget", DOFContactors), 0, 1, 0.1, 0.15:End Sub 'hit event only for the sound
3788Sub sw37_Dropped:dtMilk.hit 1:If GIState=1 then:sw37l.State = 1:end if:sw37.Image = "MilkD": End Sub
3789
3790Sub sw38_Hit:PlaySound SoundFX("fx_droptarget", DOFContactors), 0, 1, 0.1, 0.15:End Sub 'hit event only for the sound
3791Sub sw38_Dropped:dtMilk.hit 2:If GIState=1 then:sw38l.State = 1:end if:sw38.Image = "MilkD": End Sub
3792
3793Sub sw39_Hit:PlaySound SoundFX("fx_droptarget", DOFContactors), 0, 1, 0.1, 0.15:End Sub 'hit event only for the sound
3794Sub sw39_Dropped:dtMilk.hit 3:If GIState=1 then:sw39l.State = 1:end if:sw39.Image = "MilkD": End Sub
3795
3796' Drain & holes
3797Sub Bin_Hit():BsTrash.AddBall 0:End Sub
3798Sub Drain_Hit:Playsound "fx_drain":bsTrough.AddBall Me:End Sub
3799Sub Ralfie_Hit:Playsound "fx_kicker_enter", 0, 1, 0.05, 0.05:bsDog.AddBall Me:End Sub
3800
3801'  Ramp Helpers
3802Sub LHelp_Hit():Playsound "fx_balldrop", 0, 1, -0.05, 0.05:end Sub
3803
3804Sub RHelp_Hit():Playsound "fx_balldrop", 0, 1, 0.05, 0.05:end Sub
3805
3806Sub WireRampSound_Hit():Playsound "WireRamp", 0, 1, 0, 0.35:end Sub
3807'***********
3808' Solenoids
3809'***********
3810' from pacdudes script
3811SolCallback(1) = "bsTrough.SolIn"
3812SolCallback(1) = "bsTrough.SolOut"
3813SolCallback(2) = "vpmsolsound SoundFX(""fx_knocker"",DOFKnocker),"
3814SolCallback(3) = "SolDogOut"
3815SolCallback(4) = "solMT"  'dtMilk.SolDropUp
3816SolCallback(5) = "bsTrash.SolOut"
3817SolCallback(6) = "SolBT"    'dtBird.SolDropUp
3818SolCallback(10)= "SolGIBlink"
3819SolCallBack(23)= "SolGION"  'check to see if 10 works
3820
3821SolCallback(15) = "SolSFW1"
3822SolCallback(16) = "SolSFW"
3823'Flashers
3824SolCallback(25) = "flash125" 
3825SolCallback(26) = "flash126"
3826SolCallback(27) = "flash127"
3827SolCallback(28) = "flash128"
3828SolCallback(29) = "flash129"
3829SolCallback(30) = "flash130"
3830SolCallback(31) = "flash131"
3831SolCallback(32) = "flash132"
3832'Solenoid Subs
3833
3834Sub SolDogOut(enabled)
3835	If Enabled Then
3836		bsDog.ExitSol_On
3837		SetLamp 190, 0
3838	End If
3839End Sub
3840
3841Sub SolSFW(enabled)
3842  If enabled Then
3843	SetLamp 190, 1
3844  Else
3845	SetLamp 190, 0
3846  end If
3847
3848
3849
3850end Sub
3851
3852Sub SolSFW1(enabled)
3853
3854  If enabled Then
3855	SetLamp 190, 1
3856  Else
3857	SetLamp 190, 0
3858  end If
3859
3860end Sub
3861
3862Sub solMT(enabled)
3863  If enabled Then
3864	dtMilk.DropSol_On
3865	For each xx in MTGi:xx.State = 0:next
3866	For each xx in MT:xx.Image = "Milk":next
3867  Else
3868  end If
3869end Sub
3870
3871Sub solBT(enabled)
3872  If enabled Then
3873	dtBird.DropSol_On
3874	For each xx in BTGi:xx.State = 0:next
3875	For each xx in BT:xx.Image = "BirdT":next
3876  Else
3877  end If
3878end Sub
3879
3880Sub Flash127(enabled)
3881  If enabled Then
3882	Setlamp 127, 1
3883  Else
3884	SetLamp 127, 0
3885  end If
3886end Sub
3887
3888Sub Flash125(enabled)
3889  If enabled Then
3890	Setlamp 125, 1
3891  Else
3892	SetLamp 125, 0
3893  end If
3894end Sub
3895
3896Sub Flash126(enabled)
3897  If enabled Then
3898	Setlamp 126, 1
3899  Else
3900	SetLamp 126, 0
3901  end If
3902end Sub
3903
3904Sub Flash128(enabled)
3905  If enabled Then
3906	Setlamp 128, 1
3907  Else
3908	SetLamp 128, 0
3909  end If
3910end Sub
3911
3912Sub Flash129(enabled)
3913  If enabled Then
3914	Setlamp 129, 1
3915  Else
3916	SetLamp 129, 0
3917  end If
3918end Sub
3919
3920Sub Flash130(enabled)
3921  If enabled Then
3922	Setlamp 130, 1
3923  Else
3924	SetLamp 130, 0
3925  end If
3926end Sub
3927
3928Sub Flash131(enabled)
3929  If enabled Then
3930	Setlamp 131, 1
3931  Else
3932	SetLamp 131, 0
3933  end If
3934end Sub
3935
3936Sub Flash132(enabled)
3937  If enabled Then
3938	Setlamp 132, 1
3939  Else
3940	SetLamp 132, 0
3941  end If
3942end Sub
3943
3944Sub ACRelay(enabled)
3945    vpmNudge.SolGameOn enabled
3946End Sub
3947
3948'**************
3949' Flipper Subs
3950'**************
3951
3952SolCallback(sLRFlipper) = "SolRFlipper"
3953SolCallback(sLLFlipper) = "SolLFlipper"
3954
3955Sub SolLFlipper(Enabled)
3956    If Enabled Then
3957	If FlipLag = 0 then 
3958        PlaySound SoundFX("fx_flipperup", DOFContactors), 0, 1, -0.1, 0.25
3959        LeftFlipper.RotateToEnd
3960	end If
3961    Else
3962	If FlipLag = 0 then 
3963        PlaySound SoundFX("fx_flipperdown", DOFContactors), 0, 1, -0.1, 0.25
3964        LeftFlipper.RotateToStart
3965	end if
3966    End If
3967End Sub
3968
3969Sub SolRFlipper(Enabled)
3970    If Enabled Then
3971	If FlipLag = 0 then 
3972        PlaySound SoundFX("fx_flipperup", DOFContactors), 0, 1, 0.1, 0.25
3973        RightFlipper.RotateToEnd
3974	end if
3975    Else
3976	If FlipLag = 0 then 
3977        PlaySound SoundFX("fx_flipperdown", DOFContactors), 0, 1, 0.1, 0.25
3978        RightFlipper.RotateToStart
3979	end if
3980    End If
3981End Sub
3982
3983Sub LeftFlipper_Collide(parm)
3984    PlaySound "fx_rubber_flipper", 0, parm / 10, -0.1, 0.15
3985End Sub
3986
3987Sub RightFlipper_Collide(parm)
3988    PlaySound "fx_rubber_flipper", 0, parm / 10, 0.1, 0.15
3989End Sub
3990
3991'SeaFoodWheel Based on jp's script based on cyclone script
3992Dim SFWSpin
3993SFWSpin = 0
3994Sub UpdateWheel(aNewPos, aSpeed, aLastPos)
3995    ' 360/200= 1.8
3996    If aNewPos <> aLastPos then
3997        SFWheel.ObjRotZ = aNewPos * 1.8
3998    End If
3999End Sub
4000
4001'*********
4002' Special Flippers
4003'*********
4004dim FlippersEnabled
4005
4006
4007
4008sub flipnf(LR, DU)
4009    if LR = 0 Then        'left flipper
4010        if DU = 1 then
4011            If FlippersEnabled = True then
4012                leftflipper.rotatetoend
4013                LeftFlipperSound 1
4014            end if
4015            controller.Switch(swLLFlip) = True
4016        Elseif DU = 0 then
4017            If FlippersEnabled = True then
4018                leftflipper.rotatetoStart
4019                LeftFlipperSound 0
4020            end if
4021            controller.Switch(swLLFlip) = False                            
4022        end if
4023    elseif LR = 1 then        ''right flipper
4024        if DU = 1 then
4025            If FlippersEnabled = True then
4026                RightFlipper.rotatetoend
4027                RightFlipperSound 1
4028            end if
4029            controller.Switch(swLRFlip) = True
4030        Elseif DU = 0 then
4031            If FlippersEnabled = True then
4032                RightFlipper.rotatetoStart
4033                RightFlipperSound 0
4034            end if
4035            controller.Switch(swLRFlip) = False                        
4036        end if
4037    end if
4038end sub
4039
4040sub LeftFlipperSound(updown)'called along with the flipper, so feel free to add stuff, EOStorque tweaks, animation updates, upper flippers, whatever.
4041    if updown = 1 Then
4042        PlaySound SoundFX("fx_flipperup", DOFContactors), 0, 1, -0.1, 0.25    'flip
4043    Else
4044        PlaySound SoundFX("fx_flipperdown", DOFContactors), 0, 1, -0.1, 0.25'return
4045    end if
4046end sub
4047sub RightFlipperSound(updown)
4048    if updown = 1 Then
4049        PlaySound SoundFX("fx_flipperup", DOFContactors), 0, 1, 0.1, 0.25    'flip
4050    Else
4051        PlaySound SoundFX("fx_flipperdown", DOFContactors), 0, 1, 0.1, 0.25'return
4052    end if
4053end sub
4054'************GI Subs
4055
4056 Dim GIActive,GIState
4057 GIActive=0:GIState=0
4058 Sub SolGION(enabled)
4059    FlippersEnabled = Enabled
4060 	If enabled then
4061 		GIActive=1:SolGI 1
4062 	else
4063 		GIActive=0:SolGI 0
4064        if leftflipper.startangle > leftflipper.endangle Then
4065            if leftflipper.currentangle < leftflipper.startangle then leftflipper.rotatetostart : leftflippersound 0 : end if
4066        elseif leftflipper.startangle < leftflipper.endangle Then
4067            if leftflipper.currentangle > leftflipper.startangle then leftflipper.rotatetostart : leftflippersound 0 : end If
4068        end If
4069        if rightflipper.startangle > rightflipper.endangle Then
4070            if rightflipper.currentangle < rightflipper.startangle then rightflipper.rotatetostart : rightflippersound 0 : end if
4071        elseif rightflipper.startangle < rightflipper.endangle Then
4072            if rightflipper.currentangle > rightflipper.startangle then rightflipper.rotatetostart : rightflippersound 0 : end If
4073        end If
4074 	end if
4075 End Sub
4076
4077 Sub SolGIBlink(enabled)
4078 	If GIActive=1 then:SolGI Not enabled:end if
4079 End Sub
4080
4081 'GI Lights
4082
4083  Sub SolGI(Enabled)
4084 	If enabled then
4085	Playsound "fx_relay_on"								'ninuzzu - added relay click sound
4086	Table1.ColorGradeImage = "ColorGrade_8"				'ninuzzu - added LUT color grade---->this will light the whole table when GI is on
4087	For each xx in aGiLights:xx.State = 1:next
4088	If Sw28.IsDropped = 1 then: sw28l.State = 1: End if
4089	If Sw27.IsDropped = 1 then: sw27l.State = 1: End if
4090	If Sw26.IsDropped = 1 then: sw26l.State = 1: End if
4091	If Sw25.IsDropped = 1 then: sw25l.State = 1: End if
4092	If Sw39.IsDropped = 1 then: sw39l.State = 1: End if
4093	If Sw38.IsDropped = 1 then: sw38l.State = 1: End if
4094	If Sw37.IsDropped = 1 then: sw37l.State = 1: End if
4095	GIState=1
4096	SetLamp 190, 0
4097 	else
4098	Playsound "fx_relay_off"							'ninuzzu - added relay click sound
4099		Table1.ColorGradeImage = "ColorGrade_1"			'ninuzzu - added LUT color grade---->this will darken the whole table when GI is off
4100	For each xx in aGiLights:xx.State = 0:next
4101	For each xx in TargetDropGi:xx.State = 0:next
4102	GIState=0
4103 	end if
4104 End Sub
4105
4106'******************************************************
4107'        JP's VP10 Fading Lamps & Flashers
4108'  very reduced, mostly for rom activated flashers
4109' if you need to turn a light on or off then use:
4110'	LightState(lightnumber) = 0 or 1
4111'        Based on PD's Fading Light System
4112'******************************************************
4113
4114Dim LightState(200), FlashSpeedUp(200), FlashSpeedDown(200), FlashMin(200), FlashMax(200), FlashLevel(200)
4115
4116InitFlashers() ' turn off the lights and flashers and reset them to the default parameters
4117
4118LampTimer.Interval = 50 'lamp fading speed
4119LampTimer.Enabled = 1
4120
4121Sub LampTimer_timer()
4122    Dim chgLamp, x
4123    chgLamp = Controller.ChangedLamps
4124    If Not IsEmpty(chgLamp) Then
4125        For x = 0 To UBound(chgLamp)
4126            LightState(chgLamp(x, 0) ) = chgLamp(x, 1) 'light state as set by the rom
4127        Next
4128    End If
4129    ' Lights & Flashers
4130    LightX 1, l1
4131    LightX 2, l2
4132    LightX 3, l3
4133    LightX 4, l4
4134    LightX 5, l5
4135    LightX 6, l6
4136    LightX 7, l7
4137    LightX 8, l8
4138    Flash 9, l9
4139    Flash 10, l10
4140    Flash 11, l11
4141    Flash 12, l12
4142    Flash 13, l13
4143    LightX 14, l14
4144    LightX 15, l15
4145    LightX 16, l16
4146    Flash 17, l17
4147    Flash 18, l18
4148    Flash 19, l19
4149
4150    LightX 21, l21
4151    LightX 22, l22
4152    LightX 23, l23
4153    LightX 24, l24
4154    LightX 25, l25
4155    LightX 26, l26
4156    LightX 27, l27
4157    LightX 28, l28
4158    LightX 29, l29
4159    LightX 30, l30
4160    LightX 31, l31
4161    LightX 33, l33
4162    LightX 34, l34
4163    LightX 35, l35
4164    LightX 36, l36
4165    LightX 37, l37
4166    LightX 38, l38
4167    LightX 39, l39
4168    LightX 40, l40
4169    LightX 41, l41
4170    LightX 42, l42
4171    LightX 43, l43
4172    LightX 44, l44
4173    LightX 45, l45
4174    LightX 46, l46
4175    LightX 47, l47
4176    LightX 48, l48
4177    LightX 49, l49
4178    LightX 50, l50
4179    LightX 51, l51
4180    LightX 52, l52
4181    LightX 53, l53
4182'    LightX 54, l54 'Lamp shed backglass
4183'    LightX 55, l55  'bbq bg
4184'    LightX 56, l56  'candle bg
4185'    LightX 57, l57  '57-64 bg jackpot 1000000 - 8000000
4186'    LightX 58, l58
4187'    LightX 59, l59
4188'    LightX 60, l60
4189'    Flashm 61, Diode3
4190'    Flash 62, Diode4
4191'    LightX 63, l63
4192'    LightXm 64, l69a
4193	LightXm 125, f25a
4194	LightX 125, f25
4195	LightXm 126, f26a
4196	LightXm 126, f26
4197	Flash 126, f26b
4198	LightXm 127, f27
4199	lightXm 127, f27a
4200	Flash 127, f27b
4201	LightXm 128, f28a
4202	LightXm 128, f28
4203	Flash 128, f28b
4204	LightXm 129, f29a
4205	LightXm 129, f29
4206	Flash 129, f29b
4207	LightXm 130, f30
4208	Flash 130, f30a
4209	LightXm 131, f31a
4210	LightXm 131, f31
4211	Flash 131, f31b
4212	LightXm 132, f32
4213	Flash 132, f32a
4214
4215	Flash 190, SFWL
4216End Sub
4217
4218Sub SetLamp(nr, value)
4219    If value <> LightState(nr) Then
4220        LightState(nr) = value
4221    End If
4222End Sub
4223
4224' div lamp subs
4225
4226Sub InitFlashers()
4227    Dim x
4228    For x = 0 to 200
4229        LightState(x) = 0     	 ' light state: 0=off, 1=on, -1=no change (on or off)
4230        FlashSpeedUp(x) = 0.5    ' Fade Speed Up
4231        FlashSpeedDown(x) = 0.25 ' Fade Speed Down
4232        FlashMax(x) = 1          ' the maximum intensity when on, usually 1
4233        FlashMin(x) = 0          ' the minimum intensity when off, usually 0
4234        FlashLevel(x) = 0        ' the intensity/fading of the flashers
4235    Next
4236End Sub
4237
4238' VPX Lights, just turn them on or off
4239
4240Sub LightX(nr, object)
4241    Select Case LightState(nr)
4242        Case 0, 1:object.state = LightState(nr):LightState(nr) = -1
4243    End Select
4244End Sub
4245
4246Sub LightXm(nr, object) 'multiple lights
4247    Select Case LightState(nr)
4248        Case 0, 1:object.state = LightState(nr)
4249    End Select
4250End Sub
4251
4252' VPX Flashers, changes the intensity
4253
4254Sub Flash(nr, object)
4255    Select Case LightState(nr)
4256        Case 0 'off
4257            FlashLevel(nr) = FlashLevel(nr) - FlashSpeedDown(nr)
4258            If FlashLevel(nr) < FlashMin(nr) Then
4259                FlashLevel(nr) = FlashMin(nr)
4260                LightState(nr) = -1 'completely off, so stop the fading loop
4261            End if
4262            Object.IntensityScale = FlashLevel(nr)
4263        Case 1 ' on
4264            FlashLevel(nr) = FlashLevel(nr) + FlashSpeedUp(nr)
4265            If FlashLevel(nr) > FlashMax(nr) Then
4266                FlashLevel(nr) = FlashMax(nr)
4267                LightState(nr) = -1 'completely on, so stop the fading loop
4268            End if
4269            Object.IntensityScale = FlashLevel(nr)
4270    End Select
4271End Sub
4272
4273Sub Flashm(nr, object) 'multiple flashers, it just sets the intensity
4274    Object.IntensityScale = FlashLevel(nr)
4275End Sub
4276
4277' *********************************************************************
4278'                      Supporting Ball & Sound Functions
4279' *********************************************************************
4280
4281Function Vol(ball) ' Calculates the Volume of the sound based on the ball speed
4282    Vol = Csng(BallVel(ball) ^2 / 500)
4283End Function
4284
4285Function Pan(ball) ' Calculates the pan for a ball based on the X position on the table. "table1" is the name of the table
4286    Dim tmp
4287    tmp = ball.x * 2 / table1.width-1
4288    If tmp > 0 Then
4289        Pan = Csng(tmp ^10)
4290    Else
4291        Pan = Csng(-((- tmp) ^10) )
4292    End If
4293End Function
4294
4295Function Pitch(ball) ' Calculates the pitch of the sound based on the ball speed
4296    Pitch = BallVel(ball) * 20
4297End Function
4298
4299Function BallVel(ball) 'Calculates the ball speed
4300    BallVel = INT(SQR((ball.VelX ^2) + (ball.VelY ^2) ) )
4301End Function
4302
4303'*****************************************
4304'      JP's VP10 Rolling Sounds
4305'*****************************************
4306
4307'Const tnob = 5 ' total number of balls in this table is 4, but always use a higher number here because of the timing
4308
4309Const tnob = 1 'ninuzzu - why 5 balls? Bad Cats has only one ball
4310ReDim rolling(tnob)
4311InitRolling
4312
4313Sub InitRolling
4314    Dim i
4315    For i = 0 to tnob
4316        rolling(i) = False
4317    Next
4318End Sub
4319
4320Sub RollingUpdate()
4321    Dim BOT, b, ballpitch
4322    BOT = GetBalls
4323
4324    ' stop the sound of deleted balls
4325    For b = UBound(BOT) + 1 to tnob
4326        rolling(b) = False
4327        StopSound("fx_ballrolling" & b)
4328    Next
4329
4330    ' exit the sub if no balls on the table
4331    If UBound(BOT) = -1 Then Exit Sub
4332
4333    ' play the rolling sound for each ball
4334    For b = 0 to UBound(BOT)
4335        If BallVel(BOT(b) ) > 1 Then
4336            If BOT(b).z < 30 Then
4337                ballpitch = Pitch(BOT(b) )
4338            Else
4339                ballpitch = Pitch(BOT(b) ) * 100
4340            End If
4341            rolling(b) = True
4342            PlaySound("fx_ballrolling" & b), -1, Vol(BOT(b) ), Pan(BOT(b) ), 0, ballpitch, 1, 0
4343        Else
4344            If rolling(b) = True Then
4345                StopSound("fx_ballrolling" & b)
4346                rolling(b) = False
4347            End If
4348        End If
4349    Next
4350End Sub
4351
4352'**********************
4353' Ball Collision Sound
4354'**********************
4355
4356Sub OnBallBallCollision(ball1, ball2, velocity)
4357    PlaySound("fx_collide"), 0, Csng(velocity) ^2 / 500, Pan(ball1), 0, Pitch(ball1), 0, 0
4358End Sub
4359
4360'******************
4361' RealTime Updates
4362'******************
4363
4364Set MotorCallback = GetRef("RealTimeUpdates")
4365
4366Sub RealTimeUpdates
4367    RollingUpdate
4368	BallShadowUpdate								'ninuzzu - added ballshadow routine
4369	FlipperL.RotZ=LeftFlipper.currentangle			'ninuzzu - move flipper primitive in sync with VP flipper object
4370	FlipperR.RotZ=RightFlipper.currentangle			'ninuzzu - move flipper primitive in sync with VP flipper object
4371	FlipperLSh.RotZ=LeftFlipper.currentangle		'ninuzzu - move flipper shadow primitive in sync with VP flipper object
4372	FlipperRSh.RotZ=RightFlipper.currentangle		'ninuzzu - move flipper shadow primitive in sync with VP flipper object
4373
4374End Sub
4375
4376'*****************************************
4377'	Ball Shadow
4378'*****************************************
4379
4380Dim BallShadow
4381BallShadow = Array (BallShadow1)																		'ninuzzu - let's create an array of primitives, the number of primitives is equal to tnob
4382Dim ShadowSFW
4383ShadowSFW = 0	
4384
4385Sub shadowTrig_Hit:	ShadowSFW = 1: End Sub																								'ninuzzu- so in this case only one primitive, for 3 ball it will be BallShadow = Array (BallShadow1,BallShadow2,BallShadow3)
4386Sub shadowTrig_UnHit: ShadowSFW = 0: End Sub
4387
4388Sub BallShadowUpdate()
4389    Dim BOT, b
4390    BOT = GetBalls																						'ninuzzu- this will return an array , the balls array, this is updated in real time
4391
4392	' render the shadow for each ball						
4393    For b = 0 to UBound(BOT)																			'ninuzzu - now let's link the ball array with the array of primitives; so for each ball in the array, do this
4394		If BOT(b).X < Table1.Width/2 Then
4395			BallShadow(b).X = ((BOT(b).X) - (Ballsize/6) + ((BOT(b).X - (Table1.Width/2))/7)) + 10		'ninuzzu - the shadow array will move left or right depending on the ball X position in the table
4396		Else
4397			BallShadow(b).X = ((BOT(b).X) + (Ballsize/6) + ((BOT(b).X - (Table1.Width/2))/7)) - 10
4398		End If
4399		BallShadow(b).Y = BOT(b).Y + 20																	'ninuzzu - the shadow Y is at ball Y + 20 units lower
4400		BallShadow(b).Z = 1																				'ninuzzu - the shadow Z is 1
4401	
4402		If (BOT(b).Z > 20 and ShadowSFW = 0)  Then																			'ninuzzu - if the ball is falling through a hole, e.g. a subway, the shadow is not visible.
4403			BallShadow(b).visible = 1
4404		Else
4405			BallShadow(b).visible = 0
4406		End If
4407	Next
4408End Sub
4409
4410'******************************
4411' Diverse Collection Hit Sounds
4412'******************************
4413
4414Sub aMetal_Wires_Hit(idx):PlaySound "fx_metalhit", 0, Vol(ActiveBall), pan(ActiveBall), 0, Pitch(ActiveBall), 0, 0:End Sub
4415Sub aRubber_Bands_Hit(idx):PlaySound "fx_rubber_band", 0, Vol(ActiveBall), pan(ActiveBall), 0, Pitch(ActiveBall), 0, 0:End Sub
4416Sub aRubber_Posts_Hit(idx):PlaySound "fx_rubber", 0, Vol(ActiveBall), pan(ActiveBall), 0, Pitch(ActiveBall), 0, 0:End Sub
4417Sub aRubber_Pins_Hit(idx):PlaySound "fx_postrubber", 0, Vol(ActiveBall), pan(ActiveBall), 0, Pitch(ActiveBall), 0, 0:End Sub
4418Sub aPlastics_Hit(idx):PlaySound "fx_PlasticHit", 0, Vol(ActiveBall), pan(ActiveBall), 0, Pitch(ActiveBall), 0, 0:End Sub
4419Sub aGates_Hit(idx):PlaySound "fx_Gate", 0, Vol(ActiveBall), pan(ActiveBall), 0, Pitch(ActiveBall), 0, 0:End Sub
4420Sub aWoods_Hit(idx):PlaySound "fx_Woodhit", 0, Vol(ActiveBall), pan(ActiveBall), 0, Pitch(ActiveBall), 0, 0:End Sub