Core VBS

core vbs is an included set of functions compiled by many authors that are included with vpx in the included file are many neat goodies you might not know about here i'll attempt to detail some of these functions that i believe are quite useful to table builders for the latest core vbs visit the vpinball github https //github com/vpinball/vpinball/blob/master/scripts/core vbs option explicit const vpinmamedriverver = 3 57 '======================= ' vpinmame driver core '======================= ' new in 3 57 (update by nfozzy, djrobx, chepas, gaston) ' beta 1 nf fastflips 2 ' add usepdbleds(top of script)/changedpdleds(controller)/pdledcallback(callback) support and pdb vbs especially for vp proc ' added ltd3 vbs (ltd system iii) ' added fpvpx vbs (1 01, helpers for future pinball conversions) ' ' new in 3 56 (update by nfozzy, djrobx, fuzzel) ' add specialized sega2 vbs for apollo 13 and goldeneye ' update gts1 vbs and hankin vbs so that the common coin keys (e g "5") also add coins on gottlieb system 1 and hankin tables ' vpmflips fixes / improvements ' fixed vpmflips execute script error ' added extra error check for detecting outdated system vbs files when usesolenoids = 2 ' change gameonsolenoid from 16 to 19 for hankin ' fixed an execute script issue that was causing dead flippers for some system languages ' s a m fast flips support to activate, add initvpmfflipssam to the table init ' should work for most games (see pinmame whatsnew for supported sets) may need additional configuration for two stage flipper support ' whitestar fast flips support ' capcom fast flips support ' fix wpc tables that use 'csinglelflip' (regression from 3 55) ' fix script errors if using nudgeplugin vbs ' add rubber, ramp, flasher, primitive and hittarget support to vpmtoggleobj ' add rubber, primitive and hittarget support to vpmcreateevents ' ' new in 3 55 (update by nfozzy) ' prevent 'object not a collection' errors if vpmnudge tiltobj isn't set ' support for double leaf flipper switches ' for now, keybinds for these staged flippers are defined in vpmkeys vbs by default they are set to leftflipperkey and rightflipperkey, disabling them ' adapting older tables requires vpmflips create upper flipper subs and point solcallback(sulflipper) and solcallback(surflipper) to them ' 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 ' integrated fastflips, (new object vpmflips) low latency flipper response for games with pre solid state flippers ' ensure 'vpminit me' is called in the table init section ' usesolenoids = 2 enables and auto sets the game on solenoid (based on gameonsolenoid in the system vbs script) ' important info on supported wpc games is documented in wpc vbs ' pre solid state flipper games (except zaccaria and ltd) should work perfectly this includes bally/williams wpcs up to terminator 2 / party zone ' data east / early segas will work perfectly, unless they have rom controlled flipper effects ' 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) ' sega whitestar (apollo 13 / goldeneye / etc), wpc95 (congo / afm / etc), and capcom and everything onward will not work ' 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' ' ' new in 3 54 (update by mfuegemann & nfozzy & ninuzzu/tom tower & toxie) ' added ultradmd options vbs to configure ultra dmd based tables globally (see the file itself for detailed descriptions) ' added sam vbs ' added class1812 vbs ' added inder centaur vbs ' restore basic functionality of cvpmdroptarget createevents for drop targets with an animation time (e g vp10 and newer) ' minor cleanups and code unifications for all machines ' add keyconfigurations to vpmkeys vbs for taito and also remap the hardcoded keycode '13' to keysounddiag ' ' new in 3 53 (update by toxie) ' add more key mappings to help dialog ' ' new in 3 52 (update by djrobx & toxie) ' change default interval of the pinmame timer to 1 (frame sync'ed) if vp10 2 (or newer) is running ' add modulated solenoids to support rom controlled fading flashers ' to use, add "usevpmmodsol=true" to the table script ' also use solmodcallback instead of solcallback to receive level changes as input it will be a level from 0 to 255 ' 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 ' 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) ' ' new in 3 51 (update by mfuegemann & arngrim & toxie) ' gts1 vbs dip fix ' add comments to cvpmdroptarget createevents do not use this anymore in vp10 and above, as drop targets have an animation time nowadays ' change default interval of the pinmame timer to 3 if vp10 (or newer) is running, and leave it at 1 for everything else ' fix missing slingshotthreshold() when using vp8 x ' (controller vbs changes) ' now its allowed to have each toy to be set to 0 (sound effect), 1 (dof) or 2 (both) ' new dof types dofflippers, doftargets, dofdroptargets ' 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 ' initializeoptions call added to the controller init, for tables that want to use this functionality during gameplay (options menu via f6) ' ' new in 3 50 (update by toxie & mfuegemann & arngrim) ' added mac vbs & ironballs vbs & lancelot vbs & antar vbs ' (core changes) ' increased nvoffset limit from 10 to 32 ' use temporary variables for switch() calls to workaround current proc issues ' controller vbs user folder detection fix, and add simple proc usage via loadproc (see controller vbs for details) ' add usevpmnvram = true to the table script (place before loadvpm, or otherwise calling core vbs) ' to make changed content of nvram available (since last update) via the nvramcallback (delivers a three dimensional array with location, new value, old value) ' (requires vpm 2 7 or newer) ' ' new in 3 49 (update by arngrim) ' add new controller vbs to abstract dof, b2s, vpm and em controller loading, usage and sound/effect handling, ' see controller vbs header on how to use it exactly ' ' new in 3 48 (update by jimmyfingers) ' (core changes) ' changed vpmnudge tiltobj handling to use bumper threshold / wall slingshotthreshold temporary value changes rather than force / slingshotstrength changes to disable tiltobj array objects ' 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 ' 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 ' note nudgeplugin option vbs files were also updated as they contain and are reassigned the vpmnudge routines when invoked ' ' new in 3 47 (update by toxie) ' (core changes) ' add usevpmcoloreddmd = true to the table script (place before loadvpm, or otherwise calling core vbs) ' 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) ' ' new in 3 46 (update by kieferskunk) ' (core changes) ' added two new classes cvpmtrough and cvpmsaucer ' cvpmtrough takes over for cvpmballstack in non saucer mode ' can handle any number of balls (no more "out of bounds" errors with lots of balls) ' accurately simulates ball movement and switch interaction in a real trough ' cvpmsaucer takes over for cvpmballstack in saucer mode ' cvpmballstack is now considered "legacy" kept for compatibility with existing tables (no changes) ' updated vbsdoc html with these new classes ' added two helper functions, vpmin(a, b) and vpmax(a, b) ' these each take two numbers (or strings) and return the lower or higher of the two (respectively) ' ' new in 3 45 (update by kieferskunk) ' (core changes) ' rewrote cvpmdictionary as a wrapper around microsoft's scripting dictionary object ' this provides two major benefits ' (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 ' (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 ' note the only restriction is that a key cannot be a scripting dictionary or an array ' cvpmturntable now smoothly changes speeds and directions you can adjust the following properties to change the turntable's behavior ' maxspeed sets new maximum spin speed if motor is on, turntable will smoothly accelerate to new speed ' spinup sets new spin up rate if currently accelerating, turntable will accelerate at the new rate ' spindown sets new spin down rate if currently slowing to a stop, turntable will decelerate at the new rate ' spincw true for clockwise rotation, false for counter clockwise if motor is on, switching this will smoothly reverse the turntable's direction ' ' new in 3 44 (update by toxie) ' (core changes) ' added ability to define default ball mass (in vp units) inside table script ' defaults to 1 unit if undefined example ' const ballmass = 2 '(place before loadvpm, or otherwise calling core vbs) ' note that this should be used if changing the ball size via ballsize, ' as the mass is of course proportional to the radius of the ball m=k r^3 ' one can also use the diameter/size like in vp, so ballmass=k ballsize^3 with k=1/125000 ' example ballsize = 55, so ballmass = (55 55 55)/125000 = 1 331 ' add usevpmdmd = true to the table script (place before loadvpm, or otherwise calling core vbs) ' to automatically pass the raw dmd data (levels from 0 100) from vpm to vp (see vp10+ for details on how to display it) ' 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) ' add inversekeycoindoor in vpmkeys vbs to in addition choose between the behaviour of a real coindoor switch (key pressed = closed, key not pressed = open) ' or the inverted behaviour (key pressed = open, key not pressed = closed) ' increase maximum number of balls/conmaxballs to 13 and constacksw to 8 (for apollo 13), use initsw8() then instead of initsw() ' deprecate vpmsolflip2, as vp10 does not feature speed on flippers anymore ' ' new in 3 43 (update by koadic) ' (core changes) ' minor adjustment to vbs loading via loadscript to account for files in nonstandard locations ' fix minor bugs when loading some tables ' new in 3 42 (update by koadic) ' (core changes) ' minor adjustment to vpminit to unpause controller before stopping controller ' ' new in 3 41 (update by koadic) ' (core changes) ' modified vpminit routine ' added creation of exit routine to vpminit to perform controller stop (will retroactively effect all tables using vpminit call) ' modified vpminit to create paused, unpaused, and exit separately, so if any don't exit, they will be created individually ' modified error handling to fix bug where vmpinit might throw "invalid procedure call or argument" error ' and cause table not to work due to improper table init scripting ' added 2 functions checkscript(file) and loadscript(file) that can return true/false as well as the latter loading the script if true ' these check for existance in either the tables and scripts directory and can return a boolean value as well as the loadscript autoloading ' the file, as opposed to my previous methods only checking the local folder containing the table being run ' checkscript(file) checks for existance, and if found returns a true value ' loadscript(file) checks for existance, and if found, loads specified file (via executeglobal gettextfile(file)) and returns a true value ' examples ' if loadscript("thefile vbs") then dothisotherthing ' if loadscript found 'thefile' and loaded it (returned true) then do this other thing ' loadscript("somefile vbs") ' checks for 'somefile' and loads it if it exists ' reworked checkledwiz routine into generic loadscript(file) routine to allow for better detection of script in the vp tables ' or scripts directory, not just current directory containing the table ' added ability to load nudgeplugin vbs and if found, it will be loaded and replace current default nudging class ' this detection and autoloading can allow for 'on demand' replacement of other core components as well in the future ' added ability to load globalplugin vbs containing any custom scripting the user wants loaded with the core vbs (instead of modifying the core) ' (other additions) ' updated b2bcollision vbs with vpmballcreate method and renamed new file to b2b vbs (to maintain compatiblity with tables using old file) ' ' new in 3 40 (update by koadic) ' (core changes) ' modified nvoffset routine to allow use of alternative controllers (like db2s b2s server) ' new in 3 39 (update by koadic) ' (core changes) ' hopefully fixed bug introduced in 3 37 when using a vp version older than 9 0 10 ' new in 3 38 (update by koadic) ' (core changes) ' added automatic detection of ledcontrol vbs and enabling for ledwiz use, allowing concurrent use by both users and non users of an ledwiz ' new in 3 37 (update by koadic) ' (core changes) ' added ability to define default ballsize (in vp units) inside table script ' defaults to 50 vp units if undefined example ' const ballsize = 47 '(place before loadvpm, or otherwise calling core vbs)&#x9; ' new in 3 36 (update courtesy of koadic) ' (core changes) ' added vpmvol routine for allowing setting of global vpm volume (normally adjustable from ' ' key, but otherwise unsaveable without this) ' (system vbs alterations) ' added keyvpmvolume in vpmkeys vbs, set to use the f12 key ' added call to vpmvol routine in each system's vbs file, allowing end user to access the new routine ' new in 3 35 (update courtesy of koadic) ' (core changes) ' added nvoffset routine for allowing use of multiple nvram files per romset name ' new in 3 34 (update by destruk) ' (system vbs additions) ' added play2 vbs ' new in 3 33 (update by destruk) ' (system vbs additions) ' added ltd vbs ' new in 3 32 (update by destruk) ' (system vbs alterations) ' added playmatic replay setting switches ' new in 3 31 (update by destruk) ' (system vbs additions) ' added play1 vbs ' new in 3 30 (update by destruk) ' (system vbs additions) ' added zacproto vbs ' new in 3 29 (update by noah) ' (system vbs additions) ' added jvh vbs and ali vbs by destruk for jac van ham and allied leisure ' corrected vpbuild number for slingshots/bumpers and ball decals seeker ' new in 3 27 (update by pd) ' (system vbs additions) ' added gts1 vbs by inkochnito for gottlieb system 1 ' new in 3 26 (update by pd) ' (core changes) ' added "gicallback2" function to support steve ellenoff's new support in vpm for dimming gi in wms games ' gicallback returns numeric values 0 8 instead of a boolean 0 or 1 (on/off) like gicallback does ' existing tables will need to be altered to support dimming levels and need to use gicallback2 instead ' the old gicallback is left intact so older tables are not broken by the new code ' ' new in 3 25 (release 2) (update by pd) ' (core changes) ' restored former flipper speed due to complaints about some tables having bttf problem returned and a resolution ' of arguments over the settings ' new optional flipper code added (vpmsolflip2) that let's you specify both up and down swing speeds in the script ' plus the ability to turn flipper sounds on or off for that call ' format vpmsolflip2 (flip1obj, flip2obj, upspeed, downspeed, soundon, enable) ' ' new in 3 24 (update by pd) ' (core changes) ' altered flipper code so the upswing defaults to your downswing (i e vbs no longer adds a different value) ' (this change was done due to arguments over issues now resolved) ' i have decreased the return strength setting to be very low, though so any downswing hits (say from a ball ' heading to the trough) won't get hit with any real power so, assuming you have a reasonably fast upswing, ' you won't get any balls through the flipper and any balls hit by the underside won't get pegged anymore, which ' is a more realistic behavior ' ' new in 3 23 (update by pd) ' (system vbs additions) ' slamttilt definitions added to alving and capcom systems ' high score reset switch added to williams system7 (s7 vbs) ' sleic vbs system added (courtesy of destruk) ' peper vbs system added (courtesy of destruk) ' juegos vbs system added (courtesy of destruk) ' ' new in 3 22 (update by pd) ' (core changes) ' outhole switch handling updated so it resets correctly with an f3 reset ' this affects mostly gottlieb system3 games (thanks racerxme for pointing this out) ' flipper handling modified to have a low return strength setting so any balls under such flippers ' won't get hit hard this allows the higher 'flipper fix' return speed without the associated hard hit issue ' (system vbs additions) ' inder vbs test switches updated (thanks peter) ' bally vbs swsounddiag value changed to 6 (thanks racerxme) ' ' new in 3 21 (update by pd) ' (core changes) ' attemped bug fix in the impulse plunger object that could cause weak plunges sometimes on full pulls ' ' (system vbs additions) ' zac1 vbs has the program enable switch added to it (thanks tomb) ' gameplan vbs has the accounting reset switch added to it (thanks incochnito) ' ' (other additions) ' pd light system vbs file updated to v5 5 (adds fading reel pop bumper handler and checklight function) ' ' new in 3 20 (update by pd) ' (system vbs additions) ' apparently atari2 vbs uses 81/83 for the flipper switches and atar1 vbs uses 82/84 so this repairs ' the atari2 vbs file ' ' new in 3 19 (update by pd) ' (system vbs additions) ' fixed the swllflip and swlrflip switch numbers in the atari1 vbs, atari2 vbs and atari vbs files ' solflipper should now work with atari tables using the updated file ' ' new in 3 18 (update by pd) ' (system vbs additions) ' added atari1 vbs and atari2 vbs files (thanks to inkochnito) ' the old atari vbs file is now obsolete, but included for backwards compatability with any existing tables ' that may have used it new tables should use the appropriate atari1 vbs or atari2 vbs files ' ' new in 3 17 (update by pd) ' (system vbs additions) ' fixed wrong switch definition in sys80 vbs for the self test switch the operator menus should work now ' (thanks to inkochnito for pointing it out) ' added inder vbs, nuova vbs, spinball vbs and mrgame vbs files (thanks to destruk) ' ' new in 3 16 (update by pd) ' (system vbs additions) ' added "beginmodal" and "endmodal" statements to each system (required for latest versions of vp ( >v6 1) to ' avoid problems during the vpm "f3" reset ' (other additions) ' pdlightsystem core updated to version 5 4 ' ' new in 3 15 (update by pd) ' (core additions) ' added a new higher resolution impulse plunger object ' (it uses a trigger to plunge the ball it can be a variable manual plunger or function as an automatic plunger) ' (it also features random variance options and optional pull / plunge sounds) ' ' (system vbs additions) ' fixed wrong switch number for tilt & slam tilt in sega vbs ' added master cpu enter switch to s7 vbs for dip switch control in williams system7 ' ' (other additions) ' added pdlightsystem vbs (v5 3) file to archive ' (open it with a text editor to see how to use it; it's called separately like the core file) ' ' new in 3 14 (update by pd) ' (system vbs additions) ' added latest zac1 vbs and zac2 vbs files to archive ' ' new in 3 13 (update by pd) ' (core additions) ' added destruk's code to "add" or "remove" a ball from the table when "b" is pressed ' added "autoplunges" call which is the same as "autoplunger" except it will play a specified sound when fired ' ' (system vbs additions) ' taito vbs updated to fix service menu keys and default dip switch menu added ' dip switch / option menu "class" code added to all table vbs scripts to ease menu coding for table authors ' fixed some labeling errors and organization and added a "last updated" version comment at the start of each file ' ' new in 3 12 ' made flipper return speed a constant conflipretspeed ' set conflipretspeed to 0 137 to reduce ball thru flipper problem ' ' new in 3 11 ' added a short delay between balls in the ballstacks to ensure ' that the game registers the switches as off when balls are rolling ' in the trough all balls should probably move at the same time but it is ' a bit tricky to implement without changing a lot of code ' removed support for the wshltdlg dll since funtionality is in vpm now ' new in 3 10 ' public release ' put this at the top of the table file 'loadvpm "02000000", "xxx vbs", 3 57 ' adapt 02000000 and 3 57 to the actually required minimum vpinmame and core scripts versions 'const cgamename = "xxxx" ' pinmame short game name 'const usesolenoids = true 'const uselamps = true ''standard sound 'const ssolenoidon = "solon" 'solenoid activates 'const ssolenoidoff = "soloff" 'solenoid deactivates 'const sflipperon = "flipperup" 'flipper activated 'const sflipperoff = "flipperdown" 'flipper deactivated 'const scoin = "quarter" 'coin inserted ''callbacks 'set lampcallback = getref("updatemultiplelamps") 'set gicallback = getref("updategi") ' original gi callback (returns boolean on and off values only) 'set gicallback2 = getref("updategi") ' new gi callback supports newer vpm dimming gi and returns values numeric 0 8) 'set motorcallback = getref("updatemotors") ' 'sub loadvpm(vpmver, vbsfile, vbsver) ' on error resume next ' if scriptenginemajorversion < 5 then msgbox "vb script engine 5 0 or higher required" ' executeglobal gettextfile(vbsfile) ' if err then msgbox "unable to open " & vbsfile & " ensure that it is in the scripts folder of visual pinball " & vbnewline & err description err clear ' set controller = createobject("vpinmame controller") ' if err then msgbox "can't load vpinmame " & vbnewline & err description ' if vpmver>"" then if controller version < vpmver or err then msgbox "vpinmame ver " & vpmver & " required " err clear ' if vpinmamedriverver < vbsver or err then msgbox vbsfile & " ver " & vbsver & " or higher required " 'end sub ' 'sub table keydown(byval keycode) ' if vpmkeydown(keycode) then exit sub ' if keycode = plungerkey then plunger pullback 'end sub 'sub table keyup(byval keycode) ' if vpmkeyup(keycode) then exit sub ' if keycode = plungerkey then plunger fire 'end sub ' 'const ccredits = "" 'sub table init ' vpminit me ' on error resume next ' with controller ' gamename = cgamename ' if err then msgbox "can't start game " & cgamename & vbnewline & err description exit sub ' splashinfoline = ccredits ' handlemechanics = 0 ' showdmdonly = true showframe = false showtitle = false ' run if err then msgbox err description ' end with ' on error goto 0 '' nudging ' vpmnudge tiltswitch = swtilt ' vpmnudge sensitivity = 5 ' vpmnudge tiltobj = array(bumper1,bumper2,leftslingshot,rightslingshot) '' map switches and lamps ' vpmcreateevents colswobjects ' collection of triggers etc ' vpmmaplights collamps ' collection of all lamps '' trough handler ' set bstrough = new cvpmballstack ' bstrough initnotrough ballrelease, swouthole, 90, 2 ' 'or ' bstrough initsw swouthole,swtrough1,swtrough2,0,0,0,0 ' dim controller ' vpinmame controller object dim vpmtimer ' timer object dim vpmnudge ' nudge handler object dim lights(200) ' put all lamps in an array for easier handling ' if more than one lamp is connected, fill this with an array of each light dim vpmmultilights() redim vpmmultilights(0) private gnextmechno gnextmechno = 0 ' keep track of created mech handlers (would be nice with static members) ' callbacks dim solcallback(68) ' solenoids (parsed at runtime) dim solmodcallback(68) ' solenoid modulated callbacks (parsed at runtime) dim solprevstate(68) ' when modulating solenoids are in use, needed to keep positive value levels from changing boolean state dim lampcallback ' called after lamps are updated dim pdledcallback ' called after leds are updated dim gicallback ' called for each changed gi string dim gicallback2 ' called for each changed gi string dim motorcallback ' called after solenoids are updated dim vpmcreateball ' called whenever a vpm class needs to create a ball dim bsize\ if isempty(eval("ballsize"))=true then bsize=25 else bsize = ballsize/2 dim bmass\ if isempty(eval("ballmass"))=true then bmass=1 else bmass = ballmass dim usedmd\ if isempty(eval("usevpmdmd"))=true then usedmd=false else usedmd = usevpmdmd dim usemodsol\ if isempty(eval("usevpmmodsol"))=true then usemodsol=false else usemodsol = usevpmmodsol dim usecoloreddmd\ if isempty(eval("usevpmcoloreddmd"))=true then usecoloreddmd=false else usecoloreddmd = usevpmcoloreddmd dim usenvram\ if isempty(eval("usevpmnvram"))=true then usenvram=false else usenvram = usevpmnvram dim nvramcallback ' assign null default sub so script won't error if only one is defined in a script (should redefine in your script) set gicallback = getref("nullsub") set gicallback2 = getref("nullsub") ' game specific info dim extrakeyhelp ' help string for game specific keys dim vpmshowdips ' show dips function ' ' these helper functions require the following objects on the table ' pinmametimer timer object ' pulsetimer timer object ' available classes ' ' cvpmtimer (object = vpmtimer) ' (public) pulseswitch pulse switch and call callback after delay (default) ' (public) pulsesw pulse switch ' (public) addtimer call callback after delay ' (public) reset re set all ballstacks ' (friend) inittimer initialise fast or slow timer ' (friend) enableupdate add/remove automatic update for an instance ' (private) update called from slow timer ' (private) fastupdate called from fast timer ' (friend) addresetobj add object that needs to catch reset ' ' cvpmtrough (create as many as needed) ' (public) istrough get or set whether this trough is the default trough (first trough sets this by default) ' (public) size get or set total number of balls trough can hold ' (public) entrysw set switch number for trough entry (if any) eg outhole ' (public) addsw assign a switch at a specific slot ' (public) initswitches set trough switches using an array, from exit slot back toward entrance ' (public) initexit setup exit kicker, force and direction ' (public) initexitvariance modify exit kick direction and force (+/ , min force = 1) ' (public) initentrysounds sounds to play when a ball enters the trough ' (public) initexitsounds sounds to play when the exit kicker fires ' (public) createevents auto generate hit events for vp entry kicker(s) associated with this trough ' (public) maxballsperkick set maximum number of balls to kick out (default 1) ' (public) maxslotsperkick set maximum slots from which to get balls when kicking out (default 1) ' (public) balls get current balls in trough, or set initial number of balls in trough ' (public) ballspending get number of balls waiting in trough entry ' (public) reset reset and update all trough switches ' (friend) update called from vpmtimer to update ball positions and switches ' (public) addball add a ball to the trough from a kicker if kicker is the exit kicker, stacks ball at exit ' (public) solin solenoid handler for entry solenoid ' (public) solout solenoid handler for exit solenoid ' ' cvpmsaucer (create as many as needed) ' (public) initkicker setup main kicker, switch, exit direction and force (including z force) ' (public) initexitvariance modify kick direction and force (+/ , min force = 1) ' (public) initaltkick set alternate direction and force (including z force) for saucers with two kickers ' (public) initsounds sounds to play when a ball enters the saucer or the kicker fires ' (public) createevents auto generate hit event for vp kicker(s) associated with this saucer ' (public) addball add a ball to the saucer from a kicker ' (public) hasball true if the saucer is occupied ' (public) solout fire the primary exit kicker ejects ball if one is present ' (public) soloutalt fire the secondary exit kicker ejects ball with alternate forces if present ' ' cvpmballstack (deprecated, but create as many as needed) ' (public) initsw init switches used in stack ' (public) initsaucer init saucer ' (public) initnotrough init a single ball, no trough handler ' (public) initkick init exit kicker ' (public) initaltkick init second kickout direction ' (public) createevents create addball events for kickers ' (public) kickz z axis kickout angle (radians) ' (public) kickballs maximum number of balls kicked out at the same time ' (public) kickforcevar initial exitkicker force value varies by this much (+/ , minimum force = 1) ' (public) kickanglevar exitkicker angle value varies by this much (+/ ) ' (public) ballcolour set ball colour ' (public) tempballimage set ball image for next ball only ' (public) tempballcolour set ball colour for next ball only ' (public) ballimage set ball image ' (public) initaddsnd sounds when ball enters stack ' (public) initentrysnd sounds for entry kicker ' (public) initexitsnd sounds for exit kicker ' (public) addball add ball in "kicker" to stack ' (public) solin solenoid handler for entry solenoid ' (public) entrysol on entry solenoid fired ' (public) solout solenoid handler for exit solenoid ' (public) soloutalt solenoid handler for exit solenoid 2nd direction ' (public) exitsol on exit solenoid fired ' (public) exitaltsol on 2nd exit solenoid fired ' (public) balls get/set number of balls in stack (default) ' (public) ballspending get number of balls waiting to come in to stack ' (public) istrough specify that this is the main ball trough ' (public) reset reset and update all ballstack switches ' (friend) update update ball positions (from vpmtimer class) ' obsolete ' (public) solexit exit solenoid handler ' (public) solentry entry solenoid handler ' (public) initproxy init proxy switch ' cvpmnudge (object = vpmnudge) ' hopefully we can add a real pendulum simulator in the future ' (public) tiltswitch set tilt switch ' (public) senitivity set tiltsensitivity (0 10) ' (public) tiltobj set objects affected by tilt ' (public) donudge dir,power nudge table ' (public) solgameon game on solenoid handler ' (private) update handle tilting ' ' cvpmdroptarget (create as many as needed) ' (public) initdrop initialise droptarget bank ' (public) createevents create hit events ' (public) initsnd sound to use for targets ' (public) anyupsw set anyup switch ' (public) alldownsw set all down switch ' (public) alldown all targets down? ' (public) hit a target had been hit ' (public) solhit solenoid handler for dropping a target ' (public) solunhit solenoid handler for raising a target ' (public) soldropdown solenoid handler for bank down ' (public) soldropup solenoid handler for bank reset ' (public) dropsol on reset target bank ' (friend) setalldn check alldown & anyup switches ' ' cvpmmagnet (create as many as needed) ' (public) initmagnet initialise magnet ' (public) createevents create hit/unhit events ' (public) solenoid set solenoid that controls magnet ' (public) grabcenter magnet grabs ball at center ' (public) magneton turn magnet on and off ' (public) x move magnet ' (public) y move magnet ' (public) strength change strength ' (public) size change magnet reach ' (public) addball a ball has come within range ' (public) removeball a ball is out of reach for the magnet ' (public) balls balls currently within magnets reach ' (public) attractball attract ball to magnet ' (private) update update all balls (called from timer) ' (private) reset handle emulation reset ' obsolete ' (public) range change magnet reach ' cvpmturntable (create as many as needed) ' (public) initturntable initialise turntable ' (public) createevents create hit/unhit events ' (public) maxspeed maximum speed ' (public) spinup speedup acceleration ' (public) spindown retardation ' (public) speed current speed ' (public) motoron motor on/off ' (public) spincw control direction ' (public) solmotorstate motor on/off solenoid handler ' (public) addball a ball has come withing range ' (public) removeball a ball is out of reach for the magnet ' (public) balls balls currently within magnets reach ' (public) affectball affect a ball ' (private) update update all balls (called from timer) ' (private) reset handle emulation reset ' cvpmmech (create as many as needed) ' (public) sol1, sol2 controlling solenoids ' (public) mtype type of mechanics ' (public) length, steps ' (public) acc, ret acceleration, retardation ' (public) addsw automatically controlled switches ' (public) addpulsesw automatically pulsed switches ' (public) callback update graphics function ' (public) start start mechanics handler ' (public) position current position ' (public) speed current speed ' (private) update ' (private) reset ' ' cvpmcaptiveball (create as many as needed) ' (public) initcaptive initialise captive balls ' (public) createevents create events for captive ball ' (public) forcetrans amount of force tranferred to captive ball (0 1) ' (public) minforce minimum force applied to the ball ' (public) nailedballs number of "nailed" balls infront of captive ball ' (public) restswitch switch activated when ball is in rest position ' (public) start create moving ball etc ' (public) trighit trigger in front of ball hit (or unhit) ' (public) ballhit wall in front of ball hit ' (public) ballreturn captive ball has returned to kicker ' (private) reset ' ' cvpmvlock (create as many as needed) ' (public) initvlock initialise the visible ball stack ' (public) exitdir balls exit angle (like kickers) ' (public) exitforce force of balls kicked out ' (public) kickforcevar vary kickout force ' (public) initsnd sounds to make on kickout ' (public) balls number of balls in lock ' (public) solexit solenoid event ' (public) createevents create events needed ' (public) trighit called from trigger hit event ' (public) trigunhit called from trigger unhit event ' (public) kickhit called from kicier hit event ' ' cvpmdips (create as many as needed) => (dip switch and/or table options menu) ' (public) addform create a form (aka dialogue) ' (public) addchk add a chckbox ' (public) addchkextra "" for non dip settings ' (public) addframe add a frame with checkboxes or option buttons ' (public) addframeextra "" for non dip settings ' (public) addlabel add a label (text string) ' (public) viewdips show form ' (public) viewdipsextra "" with non dip settings ' ' cvpmimpulsep (create as many as needed) => (impulse plunger object using a trigger to plunge manual/auto) ' (public) initimpulsep initialise impulse plunger object (trigger, plunger power, time to full plunge \[0 = auto]) ' (public) createevents create hit/unhit events ' (public) strength change plunger strength ' (public) time change plunger time (in seconds) to full plunger strength (0 = auto plunger) ' (public) pullback pull the plunger back ' (public) fire fires / releases the plunger (manual or auto depending on timing value given) ' (public) autofire fires / releases the plunger at maximum strength +/ random variation (i e instant auto) ' (public) switch switch number to activate when ball is sitting on plunger trigger (if any) ' (public) random sets the multiplier level of random variance to add (0 = no variance / default) ' (public) initentrysnd plays sound as plunger is pulled back ' (public) initexitsnd plays sound as plunger is fired (withball,withoutball) ' ' generic solenoid handlers ' ' vpmsolflipper flipobj1, flipobj2 "flips flippers" set unused to nothing ' vpmsolflip2 flipobj1, flipobj2, flipspeedup, flipspeeddn, sndon) set unused to nothing ' vpmsoldiverter divobj, sound open/close diverter (flipper) with/without sound ' vpmsolwall wallobj, sound raise/drop wall with/without sound ' vpmsoltogglewall wall1, wall2, sound toggle between two walls ' vpmsoltoggleobj obj1,obj2,sound toggle any objects ' vpmsolautoplunger plungerobj, var, enabled autoplunger/kickback ' vpmsolautoplunges plungerobj, sound, var, enabled autoplunger/kickback with specified sound to play ' vpmsolgate obj, sound open/close gate ' vpmsolsound sound play sound only ' vpmflasher flashobj flashes flasher ' ' generating events ' ' vpmcreateevents ' cpmcreatelights ' ' variables declared (to be filled in) ' ' solcallback() handler for each solenoid ' lights() lamps ' ' constants used (must be defined) ' ' usesolenoids update solenoids ' motorcallback called once every update for mechanics or custom sol handler ' uselamps update lamps ' lampcallback sub to call after lamps are updated ' (or every update if uselamps is false) ' gicallback sub to call to update gi strings ' gicallback2 sub to call to update gi strings ' sflipperon flipper activate sound ' sflipperoff flipper deactivate sound ' ssolenoidon solenoid activate sound ' ssolenoidoff solenoid deactivate sound ' scoin coin sound ' extrakeyhelp game specific keys in help window ' ' exported variables ' ' vpmtimer timer class for pulseswitch etc ' vpmnudge class for table nudge handling ' private function pinmameinterval if vpbuildversion >= 10200 then pinmameinterval = 1 ' vp10 2 introduced special frame sync'ed timers else if vpbuildversion >= 10000 then 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 else pinmameinterval = 1 end if end if end function private const constacksw = 8 ' stack switches private const conmaxballs = 13 ' because of apollo 13 private const conmaxtimers = 20 ' spinners can generate a lot of timers private const contimerpulse = 40 ' timer runs at 25hz private const confastticks = 4 ' fast is 4 times per timer pulse private const conmaxswhit = 5 ' don't stack up more than 5 events for each switch ' deprecated flipper constants private const conflipretstrength = 0 01 ' flipper return strength private const conflipretspeed = 0 137 ' flipper return speed function checkscript(file) 'checks tables and scripts directories for specified vbs file, and if it exitst, will load it &#x9;checkscript = false on error resume next &#x9;dim tablesdirectory\ tablesdirectory = left(userdirectory,instrrev(userdirectory,"\\",instrrev(userdirectory,"\\") 1))&"tables\\" &#x9;dim scriptsdirectory\ scriptsdirectory = left(userdirectory,instrrev(userdirectory,"\\",instrrev(userdirectory,"\\") 1))&"scripts\\" &#x9;dim check\ set check = createobject("scripting filesystemobject") &#x9;if check fileexists(tablesdirectory & file) or check fileexists(scriptsdirectory & file) or check fileexists(file) then checkscript = true on error goto 0 end function function loadscript(file) 'checks tables and scripts directories for specified vbs file, and if it exitst, will load it &#x9;loadscript = false on error resume next &#x9;if checkscript(file) then executeglobal gettextfile(file)\ loadscript = true on error goto 0 end function ' dictionary ' at one point, microsoft had made scripting dictionary "unsafe for scripting", but it's ' been a long time since that was true so now, to maintain compatibility with all tables ' and scripts that use cvpmdictionary, this class is now a simple wrapper around microsoft's ' more efficient implementation class cvpmdictionary private mdict &#x9;private sub class initialize set mdict = createobject("scripting dictionary") end sub ' deprecated ms dictionaries are not index based use "exists" method instead &#x9;private function findkey(akey) &#x9; dim ii, key findkey = 1 &#x9; if mdict count > 0 then &#x9; ii = 0 &#x9; for each key in mdict keys &#x9; if key = akey then findkey = ii exit function &#x9; next &#x9; end if &#x9;end function &#x9;public property get count count = mdict count end property &#x9;public property get item(akey) &#x9; item = empty &#x9; if mdict exists(akey) then &#x9; if isobject(mdict(akey)) then &#x9; set item = mdict(akey) &#x9; else &#x9; item = mdict(akey) &#x9; end if &#x9; end if &#x9;end property &#x9;public property let item(akey, adata) &#x9; if isobject(adata) then &#x9; set mdict(akey) = adata &#x9; else &#x9; mdict(akey) = adata &#x9; end if &#x9;end property &#x9;public property set key(akey) &#x9; ' this function is (and always has been) a no op previous definition &#x9; ' just looked up akey in the keys list, and if found, set the key to itself &#x9;end property &#x9;public sub add(akey, aitem) &#x9; if isobject(aitem) then &#x9; set mdict(akey) = aitem &#x9; else &#x9; mdict(akey) = aitem &#x9; end if &#x9;end sub &#x9;public sub remove(akey) mdict remove(akey) end sub &#x9;public sub removeall mdict removeall end sub &#x9;public function exists(akey) exists = mdict exists(akey) end function &#x9;public function items items = mdict items end function &#x9;public function keys keys = mdict keys end function end class ' ' timer ' class cvpmtimer &#x9;private mque, mnow, mtimers &#x9;private mslowupdates, mfastupdates, mresets, mfasttimer &#x9;private sub class initialize &#x9; redim mque(conmaxtimers) mnow = 0 mtimers = 0 &#x9; set mslowupdates = new cvpmdictionary &#x9; set mfastupdates = new cvpmdictionary &#x9; set mresets = new cvpmdictionary &#x9;end sub &#x9;public sub inittimer(atimerobj, afast) &#x9; if afast then &#x9; set mfasttimer = atimerobj &#x9; atimerobj timerinterval = contimerpulse \ confastticks &#x9; atimerobj timerenabled = false &#x9; vpmbuildevent atimerobj, "timer", "vpmtimer fastupdate" &#x9; else &#x9; atimerobj interval = contimerpulse atimerobj enabled = true &#x9; vpmbuildevent atimerobj, "timer", "vpmtimer update" &#x9; end if &#x9;end sub &#x9;sub enableupdate(aclass, afast, aenabled) &#x9; on error resume next &#x9; if afast then &#x9; if aenabled then mfastupdates add aclass, 0 else mfastupdates remove aclass &#x9; mfasttimer timerenabled = mfastupdates count > 0 &#x9; else &#x9; if aenabled then mslowupdates add aclass, 0 else mslowupdates remove aclass &#x9; end if &#x9;end sub &#x9;public sub reset &#x9; dim obj for each obj in mresets keys obj reset next &#x9;end sub &#x9;public sub fastupdate &#x9; dim obj for each obj in mfastupdates keys obj update next &#x9;end sub &#x9;public sub update &#x9; dim ii, jj, sw, obj, mquecopy &#x9; for each obj in mslowupdates keys obj update next &#x9; if mtimers = 0 then exit sub &#x9; mnow = mnow + 1 ii = 1 &#x9; do while ii <= mtimers &#x9; if mque(ii)(0) <= mnow then &#x9; if mque(ii)(1) = 0 then &#x9; if isobject(mque(ii)(3)) then &#x9; call mque(ii)(3)(mque(ii)(2)) &#x9; elseif vartype(mque(ii)(3)) = vbstring then &#x9; if mque(ii)(3) > "" then execute mque(ii)(3) & " " & mque(ii)(2) & " " &#x9; end if &#x9; mtimers = mtimers 1 &#x9; for jj = ii to mtimers mque(jj) = mque(jj+1) next ii = ii 1 &#x9; elseif mque(ii)(1) = 1 then &#x9; mquecopy = mque(ii)(2) &#x9; controller switch(mquecopy) = false &#x9; mque(ii)(0) = mnow + mque(ii)(4) mque(ii)(1) = 0 &#x9; else '2 &#x9; mquecopy = mque(ii)(2) &#x9; controller switch(mquecopy) = true &#x9; mque(ii)(1) = 1 &#x9; end if &#x9; end if &#x9; ii = ii + 1 &#x9; loop &#x9;end sub &#x9;public sub addresetobj(aobj) mresets add aobj, 0 end sub &#x9;public sub pulsesw(aswno) pulseswitch aswno, 0, 0 end sub &#x9;public default sub pulseswitch(aswno, adelay, acallback) &#x9; dim ii, count, last &#x9; count = 0 &#x9; for ii = 1 to mtimers &#x9; if mque(ii)(1) > 0 and mque(ii)(2) = aswno then count = count + 1 last = ii &#x9; next &#x9; if count >= conmaxswhit or mtimers = conmaxtimers then exit sub &#x9; mtimers = mtimers + 1 mque(mtimers) = array(mnow, 2, aswno, acallback, adelay\contimerpulse) &#x9; if count then mque(mtimers)(0) = mque(last)(0) + mque(last)(1) &#x9;end sub &#x9;public sub addtimer(adelay, acallback) &#x9; if mtimers = conmaxtimers then exit sub &#x9; mtimers = mtimers + 1 &#x9; mque(mtimers) = array(mnow + adelay \ contimerpulse, 0, 0, acallback) &#x9;end sub &#x9; &#x9;public sub addtimer2(adelay, acallback, aid) &#x9; if mtimers = conmaxtimers then exit sub &#x9; mtimers = mtimers + 1 &#x9; mque(mtimers) = array(mnow + adelay \ contimerpulse, 0, aid, acallback) &#x9;end sub end class ' ' trough ' class cvpmtrough ' takes over for older cvpmballstack in "trough mode" theory of operation ' a trough can hold up to n balls, and has n 2 "slots" a ball effectively takes ' up two slots, so no two adjacent slots (0 and 1) can be occupied at the same time ' switches are assigned to even slots only, which means that as balls move through ' the trough, each switch is allowed to flip between open and closed ' slot 0 is the exit, and can have additional balls "stacked" on it, simulating balls ' falling onto the exit kicker instead of coming in from the entrance extra balls ' can be queued up at the entrance, and will enter the trough only if there's room ' for them private mslot(), msw(), mentrysw private mballsinentry, mmaxballsperkick, mstackexitballs private mexitkicker, mexitdir, mexitforce, mdirvar, mforcevar private msounds ' if you want to see what the trough is doing internally, add a textbox to your table ' named "debugbox" (recommend courier new or fixedsys at a small font size) and set ' this variable to true via isdebug = true &#x9;private mdebug private sub class initialize dim ii redim msw(conmaxballs), mslot(conmaxballs 2) for ii = 0 to ubound(mslot) mslot(ii) = 0 next ' all slots empty to start for ii = 0 to ubound(msw) msw(ii) = 0 next ' all switches unassigned to start mentrysw = 0 set mexitkicker = nothing mexitdir = 0 mexitforce = 1 mdirvar = 0 mforcevar = 0 mballsinentry = 0 mmaxballsperkick = 1 mstackexitballs = 1 set msounds = new cvpmdictionary &#x9; mdebug = false if not isobject(vpmtrough) then set vpmtrough = me end sub public property let istrough(ayes) if ayes then set vpmtrough = me elseif me is vpmtrough then set vpmtrough = nothing end if end property public property get istrough istrough = (me is vpmtrough) end property ' initialization public property let isdebug(enabled) mdebug = enabled end property public property let size(asize) dim oldsize, newsize, ii oldsize = ubound(msw) newsize = vpmax(1, asize) redim preserve mslot(newsize 2) redim preserve msw(newsize) for ii = oldsize+1 to newsize msw(ii) = 0 next for ii = (oldsize 2) + 1 to (newsize 2) mslot(ii) = 0 next end property public property get size size = ubound(msw) end property ' set entrysw = 0 if you want balls to just fall into the trough automatically ' set it to a real switch number to indicate that a ball is occupying an entry kicker ' the rom in the controller is then responsible for kicking the ball into the trough public property let entrysw(swno) mentrysw = swno end property ' assign switches, starting from slot 0 and going to entrance ' this sub allows you to pass in as many switches as you wish public sub initswitches(switcharray) if not isarray(switcharray) then err raise 17, "cvpmtrough initswitches input must be an array " end if dim ii for ii = 0 to ubound(msw) if ii > ubound(switcharray) then msw(ii) = 0 else msw(ii) = switcharray(ii) end if next end sub ' alternative assign a switch to a specific slot public sub addsw(slotno, swno) if slotno < 0 or slotno > ubound(msw) then exit sub msw(slotno) = swno end sub ' maxballsperkick kick up to n balls total per exit kick balls are only kicked from slot 0 ' stackexitballs automatically stack up to n balls in slot 0 regardless of where they came from ' example subway where exit kicker is on the same level as the trough and a ball can ' come in from the exit stackexitballs = 1, maxballsperkick = 2 if slot 0 has 1 ' ball and slot 1 is occupied, only one ball will be kicked if slot 0 has 2 or more ' balls, it'll kick out 2 balls ' example twilight zone slot kicker kicker is below trough, so if a ball is in the ' exit chute, another ball can fall into the chute as well whether it came in from the ' exit (slot machine) or any other entrance (piano, camera) in both cases, the kicker ' will eject 2 balls at once set stackexitballs = 2, maxballsperkick = 2 to simulate public property let maxballsperkick(n) mmaxballsperkick = vpmax(1, n) end property public property let stackexitballs(n) mstackexitballs = vpmax(1, n) end property public sub initexit(akicker, adir, aforce) if typename(akicker) <> "kicker" then err raise 17, "cvpmtrough initexit cannot use object of type '" & typename(akicker) & "' " end if set mexitkicker = akicker mexitdir = adir mexitforce = vpmax(1, aforce) end sub public sub initexitvariance(adirvar, aforcevar) mdirvar = adirvar mforcevar = aforcevar end sub ' setup sounds public sub initentrysounds(addsound, entrysoundempty, entrysoundball) msounds item("add") = addsound msounds item("entry") = entrysoundempty msounds item("entryball") = entrysoundball end sub public sub initexitsounds(exitsoundempty, exitsoundball) msounds item("exit") = exitsoundempty msounds item("exitball") = exitsoundball end sub ' start trough with this many balls public property let balls(numballs) dim ii, ballsadded ' first clear all slots for ii = 0 to ubound(mslot) mslot(ii) = 0 next ' now put a ball in each even numbered slot up to the number requested ' first, stack exit slot (note, we may get a negative number vpmin/vpmax prevent that ) mslot(0) = vpmax(0, vpmin(mstackexitballs, numballs)) ballsadded = mslot(0) ' fill remaining slots for ii = 1 to vpmin(numballs mslot(0), ubound(msw)) mslot(ii 2) = 1 ballsadded = ballsadded + 1 next ' if we asked to put more balls in the trough than it can handle, queue up the rest mballsinentry = vpmax(0, numballs ballsadded) updatetroughswitches end property public property get balls balls = 0 dim ii for ii = 0 to ubound(mslot) balls = balls + mslot(ii) next end property public property get ballspending ballspending = mballsinentry end property ' auto generate events for any entry kickers (eg outhole, tz camera and piano, etc ) ' accepts a single kicker, an array, or a collection &#x9;public sub createevents(aname, akicker) &#x9; dim obj, tmp &#x9; if not vpmcheckevent(aname, me) then exit sub &#x9; vpmsetarray tmp, akicker &#x9; for each obj in tmp &#x9; if isobject(obj) then &#x9; vpmbuildevent obj, "hit", aname & " addball me" &#x9; else &#x9; vpmbuildevent mkicker, "hit", aname & " addball me" &#x9; end if &#x9; next &#x9;end sub ' vpm update management &#x9;private property let needupdate(aenabled) vpmtimer enableupdate me, false, aenabled end property &#x9;public sub reset &#x9; dim mentryswcopy &#x9; updatetroughswitches &#x9; if mentrysw then &#x9; mentryswcopy = mentrysw &#x9; controller switch(mentryswcopy) = (mballsinentry > 0) &#x9; end if &#x9;end sub &#x9;public sub update &#x9; needupdate = advanceballs &#x9; updatetroughswitches end sub ' switch and slot management private sub setsw(slotno, enabled) dim mswcopy if msw(slotno) then mswcopy = msw(slotno) controller switch(mswcopy) = enabled end if end sub private sub updatetroughswitches &#x9; dim ii, mswcopy &#x9; for ii = 0 to ubound(msw) &#x9; if msw(ii) then &#x9; mswcopy = msw(ii) &#x9; controller switch(mswcopy) = (mslot(ii 2) > 0) &#x9; end if &#x9; next &#x9; if mdebug then updatedebugbox end sub &#x9;private sub updatedebugbox ' requires a textbox named debugbox &#x9; dim str, ii, mswcopy &#x9; str = "entry " & mballsinentry & " (sw" & mentrysw & " = " &#x9; if mentrysw > 0 then &#x9; mswcopy = mentrysw &#x9; str = str & controller switch(mswcopy) &#x9; else &#x9; str = str & "n/a" &#x9; end if &#x9; str = str & ")" & vbnewline &#x9; str = str & "\[" &#x9; for ii = ubound(mslot) to 0 step 1 str = str & mslot(ii) next &#x9; str = str & "]" & vbnewline &#x9; str = str & "\[" &#x9; for ii = ubound(mslot) to 0 step 1 &#x9; if ii mod 2 = 0 then &#x9; if msw(ii\2) then &#x9; mswcopy = msw(ii\2) &#x9; if controller switch(mswcopy) then &#x9; str = str & "1" &#x9; else &#x9; str = str & "0" &#x9; end if &#x9; else &#x9; str = str & " " &#x9; end if &#x9; else &#x9; str = str & " " &#x9; end if &#x9; next &#x9; str = str & "]" &#x9; debugbox text = str &#x9;end sub private function advanceballs dim ii, canmove, maxslot maxslot = ubound(mslot) advanceballs = false ' move balls through slots, one slot at a time for ii = 0 to maxslot if mslot(ii) then ' ball in this slot &#x9; canmove = false ' can this ball move? (slot 0 = no) if ii = 0 then ' slot 0 never moves (except when ejected) canmove = false &#x9; elseif ii = 1 then &#x9; ' slot 1 automatically moves to slot 0 &#x9; canmove = true &#x9; elseif ii = 2 then &#x9; ' slot 2 moves if the number of balls in slot 0 is less than the stack target &#x9; canmove = (mslot(0) < mstackexitballs) &#x9; else &#x9; ' only move if there is no ball in ii 1 or ii 2 &#x9; canmove = (mslot(ii 2) = 0) and (mslot(ii 1) = 0) &#x9; end if if canmove then mslot(ii) = mslot(ii) 1 mslot(ii 1) = mslot(ii 1) + 1 advanceballs = true ' mark balls as having moved end if end if next ' if balls are supposed to fall into the trough without going through a kicker, ' see if any balls are pending and try to add one automatically if so if mballsinentry > 0 and mentrysw <= 0 then advanceballs = addballatentrance or advanceballs end if end function ' ball management private function addballatentrance dim mswcopy dim maxslot maxslot = ubound(mslot) addballatentrance = false ' only add a ball if there's room for it at the entrance ' if the trough is full (or the entrance is occupied), the ball will remain ' in the entry queue in a kicker gated trough, the entry switch will remain ' pressed down, usually resulting in the machine retrying the load in a fall in ' trough, the ball will just remain queued until the entrance opens up if mslot(maxslot) = 0 and mslot(maxslot 1) = 0 then mslot(maxslot) = 1 mballsinentry = vpmax(0, mballsinentry 1) if mballsinentry = 0 and mentrysw then mswcopy = mentrysw controller switch(mswcopy) = false end if addballatentrance = true end if end function public sub addball(akicker) dim mswcopy dim adddone adddone = false if isobject(akicker) then akicker destroyball if akicker is mexitkicker then ' ball fell in from exit stack it up on slot 0 mslot(0) = mslot(0) + 1 needupdate = true updatetroughswitches adddone = true end if end if if not adddone then ' ball came in from entrance queue it up for entry mballsinentry = mballsinentry + 1 &#x9; if mentrysw > 0 then &#x9; mswcopy = mentrysw &#x9; ' trough has an entry kicker ball will not enter trough &#x9; ' until the entry solenoid is fired &#x9; controller switch(mswcopy) = true &#x9; end if needupdate = true &#x9; end if &#x9; playsound msounds item("add") &#x9;end sub ' use solcallback(solno) on the trough entry kicker solenoid public sub solin(aenabled) if aenabled then if mballsinentry > 0 then needupdate = addballatentrance playsound msounds item("entryball") else playsound msounds item("entry") end if end if end sub public sub entrysol on solin(true) end sub ' use solcallback(solno) on the trough exit kicker solenoid &#x9;public sub solout(aenabled) dim iiball, kdir, kforce, kbasedir, ballsejected ballsejected = 0 &#x9; if aenabled then &#x9; for iiball = 0 to (mmaxballsperkick 1) &#x9; kdir = (mexitdir + (rnd 0 5) mdirvar) &#x9; kforce = vpmax(1, mexitforce + (rnd 0 5) mforcevar (0 8 iiball)) ' dampen force a bit on subsequent balls &#x9; if mslot(0) > 0 then &#x9; ' remove ball from this slot &#x9; mslot(0) = mslot(0) 1 &#x9; if isobject(mexitkicker) then &#x9; vpmtimer addtimer ballsejected 200, "vpmcreateball(" & mexitkicker name & ") kick " & &#x9; cint(kdir) & "," & replace(kforce,","," ") & ", 0 '" &#x9; end if &#x9; ballsejected = ballsejected + 1 &#x9; end if &#x9; next &#x9; if ballsejected > 0 then &#x9; playsound msounds item("exitball") &#x9; updatetroughswitches &#x9; needupdate = true &#x9; else &#x9; playsound msounds item("exit") &#x9; end if &#x9; end if end sub public sub exitsol on solout(true) end sub end class ' ' saucer ' class cvpmsaucer ' takes over for older cvpmballstack in "saucer mode" private msw, mkicker, mexternalkicker private mdir(1), mforce(1), mzforce(1), mdirvar, mforcevar private msounds private sub class initialize msw = 0 mkicker = 0 mexternalkicker = 0 mdir(0) = 0 mforce(0) = 1 mzforce(0) = 0 mdir(1) = 0 mforce(1) = 1 mzforce(1) = 0 mdirvar = 0 mforcevar = 0 set msounds = new cvpmdictionary end sub ' initialization public sub initkicker(akicker, asw, adir, aforce, azforce) if typename(akicker) <> "kicker" then err raise 17, "cvpmsaucer initkicker cannot use object of type '" & typename(akicker) & "' " end if set mkicker = akicker msw = asw mdir(0) = adir mforce(0) = vpmax(1, aforce) mzforce(0) = vpmax(0, azforce) end sub public sub initexitvariance(adirvar, aforcevar) mdirvar = adirvar mforcevar = aforcevar end sub ' alternate kick params (simulates a saucer with two kickers) public sub initaltkick(adir, aforce, azforce) mdir(1) = adir mforce(1) = vpmax(1, aforce) mzforce(1) = vpmax(0, azforce) end sub ' setup sounds public sub initsounds(addsound, exitsoundempty, exitsoundball) msounds item("add") = addsound msounds item("exit") = exitsoundempty msounds item("exitball") = exitsoundball end sub ' generate hit event for the kicker(s) associated with this saucer ' accepts a single kicker, an array, or a collection &#x9;public sub createevents(aname, akicker) &#x9; dim obj, tmp &#x9; if not vpmcheckevent(aname, me) then exit sub &#x9; vpmsetarray tmp, akicker &#x9; for each obj in tmp &#x9; if isobject(obj) then &#x9; vpmbuildevent obj, "hit", aname & " addball me" &#x9; else &#x9; vpmbuildevent mkicker, "hit", aname & " addball me" &#x9; end if &#x9; next &#x9;end sub ' ball management public sub addball(akicker) &#x9; dim mswcopy &#x9; if isobject(akicker) then &#x9; if akicker is mkicker then &#x9; mkicker enabled = false &#x9; mexternalkicker = 0 &#x9; else &#x9; akicker enabled = false &#x9; set mexternalkicker = akicker &#x9; end if &#x9; else &#x9; mkicker enabled = false &#x9; mexternalkicker = 0 &#x9; end if &#x9; if msw then &#x9; mswcopy = msw &#x9; controller switch(mswcopy) = true &#x9; end if &#x9; playsound msounds item("add") end sub public property get hasball hasball = false if isobject(mexternalkicker) then hasball = true else hasball = not mkicker enabled end if end property ' solcallback solno, "mysaucer solout" public sub solout(aenabled) if aenabled then kickout 0 end if end sub public sub exitsol on kickout 0 end sub ' solcallback solno, "mysaucer soloutalt" public sub soloutalt(aenabled) if aenabled then kickout 1 end if end sub public sub exitaltsol on kickout 1 end sub private sub kickout(kickindex) dim mswcopy if hasball then dim kdir, kforce, kzforce kdir = mdir(kickindex) + (rnd 0 5) mdirvar kforce = vpmax(1, mforce(kickindex) + (rnd 0 5) mforcevar) kzforce = mzforce(kickindex) if isobject(mexternalkicker) then ' transfer ball to internal kicker and remove relationship vpmcreateball mkicker mexternalkicker destroyball mexternalkicker enabled = true else mkicker enabled = true end if mkicker kick kdir, kforce, kzforce if msw then mswcopy = msw controller switch(mswcopy) = false end if playsound msounds item("exitball") else playsound msounds item("exit") end if end sub end class ' ' ballstack (deprecated/legacy) ' known issues ' adding more balls than conmaxballs will crash the script ' if there are more balls in trough than are ever used in a game (eg bride of pinbot), ' one or more trough switches will be permanently stuck down and may result in a rom test report ' trough does not handle stacking balls at exit ' saucer mode is essentially a hack on top of the trough logic ' class cvpmballstack &#x9;private msw(), mentrysw, mballs, mballin, mballpos(), msaucer, mballsmoving &#x9;private minitkicker, mexitkicker, mexitdir, mexitforce &#x9;private mexitdir2, mexitforce2 &#x9;private mentrysnd, mentrysndball, mexitsnd, mexitsndball, maddsnd &#x9;public kickz, kickballs, kickforcevar, kickanglevar &#x9;private sub class initialize &#x9; redim msw(constacksw), mballpos(conmaxballs) &#x9; mballin = 0 mballs = 0 mexitkicker = 0 minitkicker = 0 mballsmoving = false &#x9; kickballs = 1 msaucer = false mexitdir = 0 mexitforce = 0 &#x9; mexitdir2 = 0 mexitforce2 = 0 kickz = 0 kickforcevar = 0 kickanglevar = 0 &#x9; maddsnd = 0 mentrysnd = 0 mentrysndball = 0 mexitsnd = 0 mexitsndball = 0 &#x9; vpmtimer addresetobj me &#x9;end sub &#x9;private property let needupdate(aenabled) vpmtimer enableupdate me, false, aenabled end property &#x9;private function setsw(ano, astatus) dim mswcopy setsw = false if hassw(ano) then mswcopy = msw(ano) controller switch(mswcopy) = astatus setsw = true end if &#x9;end function &#x9;private function hassw(ano) &#x9; hassw = false if ano <= constacksw then if msw(ano) then hassw = true &#x9;end function &#x9;public sub reset &#x9; dim mswcopy &#x9; dim ii if mballs then for ii = 1 to mballs setsw mballpos(ii), true next &#x9; if mentrysw and mballin > 0 then &#x9; mswcopy = mentrysw &#x9; controller switch(mswcopy) = true &#x9; end if &#x9;end sub &#x9;public sub update &#x9; dim ballque, ii, mswcopy &#x9; needupdate = false ballque = 1 &#x9; for ii = 1 to mballs &#x9; if mballpos(ii) > ballque then ' next slot available &#x9; needupdate = true &#x9; if hassw(mballpos(ii)) then ' has switch &#x9; mswcopy = msw(mballpos(ii)) &#x9; if controller switch(mswcopy) then &#x9; setsw mballpos(ii), false &#x9; else &#x9; mballpos(ii) = mballpos(ii) 1 &#x9; setsw mballpos(ii), true &#x9; end if &#x9; else ' no switch move ball to first switch or occupied slot &#x9; do &#x9; mballpos(ii) = mballpos(ii) 1 &#x9; loop until setsw(mballpos(ii), true) or mballpos(ii) = ballque &#x9; end if &#x9; end if &#x9; ballque = mballpos(ii) + 1 &#x9; next &#x9;end sub &#x9;public sub addball(akicker) &#x9; dim mswcopy &#x9; if isobject(akicker) then &#x9; if msaucer then &#x9; if akicker is mexitkicker then &#x9; mexitkicker enabled = false minitkicker = 0 &#x9; else &#x9; akicker enabled = false set minitkicker = akicker &#x9; end if &#x9; else &#x9; akicker destroyball &#x9; end if &#x9; elseif msaucer then &#x9; mexitkicker enabled = false minitkicker = 0 &#x9; end if &#x9; if mentrysw then &#x9; mswcopy = mentrysw &#x9; controller switch(mswcopy) = true mballin = mballin + 1 &#x9; else &#x9; mballs = mballs + 1 mballpos(mballs) = constacksw + 1 needupdate = true &#x9; end if &#x9; playsound maddsnd &#x9;end sub &#x9;' a bug in the script engine forces the "end if" at the end &#x9;public sub solin(aenabled) if aenabled then kickin end if end sub &#x9;public sub solout(aenabled) if aenabled then kickout false end if end sub &#x9;public sub soloutalt(aenabled) if aenabled then kickout true end if end sub &#x9;public sub entrysol on kickin end sub &#x9;public sub exitsol on kickout false end sub &#x9;public sub exitaltsol on kickout true end sub &#x9;private sub kickin &#x9; dim mswcopy &#x9; if mballin then playsound mentrysndball else playsound mentrysnd exit sub &#x9; mballs = mballs + 1 mballin = mballin 1 mballpos(mballs) = constacksw + 1 needupdate = true &#x9; if mentrysw and mballin = 0 then &#x9; mswcopy = mentrysw &#x9; controller switch(mswcopy) = false &#x9; end if &#x9;end sub &#x9;private sub kickout(aaltsol) &#x9; dim ii,jj, kforce, kdir, kbasedir &#x9; if mballs then playsound mexitsndball else playsound mexitsnd exit sub &#x9; if aaltsol then kforce = mexitforce2 kbasedir = mexitdir2 else kforce = mexitforce kbasedir = mexitdir &#x9; kforce = kforce + (rnd 0 5) kickforcevar &#x9; if msaucer then &#x9; setsw 1, false mballs = 0 kdir = kbasedir + (rnd 0 5) kickanglevar &#x9; if isobject(minitkicker) then &#x9; vpmcreateball mexitkicker minitkicker destroyball minitkicker enabled = true &#x9; else &#x9; mexitkicker enabled = true &#x9; end if &#x9; mexitkicker kick kdir, kforce, kickz &#x9; else &#x9; for ii = 1 to kickballs &#x9; if mballs = 0 or mballpos(1) <> ii then exit for ' no more balls &#x9; for jj = 2 to mballs ' move balls in array &#x9; mballpos(jj 1) = mballpos(jj) &#x9; next &#x9; mballpos(mballs) = 0 mballs = mballs 1 needupdate = true &#x9; setsw ii, false &#x9; if isobject(mexitkicker) then &#x9; if kforce < 1 then kforce = 1 &#x9; kdir = kbasedir + (rnd 0 5) kickanglevar &#x9; vpmtimer addtimer (ii 1) 200, "vpmcreateball(" & mexitkicker name & ") kick " & &#x9; cint(kdir) & "," & replace(kforce,","," ") & "," & replace(kickz,","," ") & " '" &#x9; end if &#x9; kforce = kforce 0 8 &#x9; next &#x9; end if &#x9;end sub &#x9;public sub initsaucer(akicker, asw, adir, apower) &#x9; initkick akicker, adir, apower msaucer = true &#x9; if asw then msw(1) = asw else msw(1) = akicker timerinterval &#x9;end sub &#x9;public sub initnotrough(akicker, asw, adir, apower) &#x9; initkick akicker, adir, apower balls = 1 &#x9; if asw then msw(1) = asw else msw(1) = akicker timerinterval &#x9; if not isobject(vpmtrough) then set vpmtrough = me &#x9;end sub &#x9;public sub initsw(aentry, asw1, asw2, asw3, asw4, asw5, asw6, asw7) &#x9; mentrysw = aentry msw(1) = asw1 msw(2) = asw2 msw(3) = asw3 msw(4) = asw4 &#x9; msw(5) = asw5 msw(6) = asw6 msw(7) = asw7 msw(8) = 0 &#x9; if not isobject(vpmtrough) then set vpmtrough = me &#x9;end sub &#x9;public sub initsw8(aentry, asw1, asw2, asw3, asw4, asw5, asw6, asw7, asw8) &#x9; mentrysw = aentry msw(1) = asw1 msw(2) = asw2 msw(3) = asw3 msw(4) = asw4 &#x9; msw(5) = asw5 msw(6) = asw6 msw(7) = asw7 msw(8) = asw8 &#x9; if not isobject(vpmtrough) then set vpmtrough = me &#x9;end sub &#x9;public sub initkick(akicker, adir, aforce) &#x9; set mexitkicker = akicker mexitdir = adir mexitforce = aforce &#x9;end sub &#x9;public sub createevents(aname, akicker) &#x9; dim obj, tmp &#x9; if not vpmcheckevent(aname, me) then exit sub &#x9; vpmsetarray tmp, akicker &#x9; for each obj in tmp &#x9; if isobject(obj) then &#x9; vpmbuildevent obj, "hit", aname & " addball me" &#x9; else &#x9; vpmbuildevent mexitkicker, "hit", aname & " addball me" &#x9; end if &#x9; next &#x9;end sub &#x9;public property let istrough(aistrough) &#x9; if aistrough then &#x9; set vpmtrough = me &#x9; elseif isobject(vpmtrough) then &#x9; if vpmtrough is me then vpmtrough = 0 &#x9; end if &#x9;end property &#x9;public property get istrough istrough = vpmtrough is me end property &#x9;public sub initaltkick(adir, aforce) &#x9; mexitdir2 = adir mexitforce2 = aforce &#x9;end sub &#x9;public sub initentrysnd(aball, anoball) mentrysndball = aball mentrysnd = anoball end sub &#x9;public sub initexitsnd(aball, anoball) mexitsndball = aball mexitsnd = anoball end sub &#x9;public sub initaddsnd(asnd) maddsnd = asnd end sub &#x9;public property let balls(aballs) &#x9; dim ii &#x9; for ii = 1 to constacksw &#x9; setsw ii, false mballpos(ii) = constacksw + 1 &#x9; next &#x9; if msaucer and aballs > 0 and mballs = 0 then vpmcreateball mexitkicker &#x9; mballs = aballs needupdate = true &#x9;end property &#x9;public default property get balls balls = mballs end property &#x9;public property get ballspending ballspending = mballin end property &#x9;' obsolete stuff &#x9;public sub solentry(asnd1, asnd2, aenabled) &#x9; if aenabled then mentrysndball = asnd1 mentrysnd = asnd2 kickin &#x9;end sub &#x9;public sub solexit(asnd1, asnd2, aenabled) &#x9; if aenabled then mexitsndball = asnd1 mexitsnd = asnd2 kickout false &#x9;end sub &#x9;public sub initproxy(aproxypos, aswno) end sub &#x9;public tempballcolour, tempballimage, ballcolour &#x9;public property let ballimage(aimage) vpmballimage = aimage end property end class ' ' nudge ' class cvpmnudge &#x9;private mcount, msensitivity, mnudgetimer, mslingbump, mforce &#x9;public tiltswitch &#x9;private sub class initialize &#x9; mcount = 0 tiltswitch = 0 msensitivity = 5 vpmtimer addresetobj me &#x9;end sub &#x9;private property let needupdate(aenabled) vpmtimer enableupdate me, false, aenabled end property &#x9;public property let tiltobj(aslingbump) &#x9; dim ii &#x9; redim mforce(vpmsetarray(mslingbump, aslingbump)) &#x9; for ii = 0 to ubound(mforce) &#x9; if typename(mslingbump(ii)) = "bumper" then mforce(ii) = mslingbump(ii) threshold &#x9; if vpmvpver >= 90 and typename(mslingbump(ii)) = "wall" then mforce(ii) = mslingbump(ii) slingshotthreshold &#x9; next &#x9;end property &#x9;public property let sensitivity(asens) msensitivity = (10 asens)+1 end property &#x9;public sub donudge(byval adir, byval aforce) &#x9; adir = adir + (rnd 0 5) 15 aforce aforce = (0 6+rnd 0 8) aforce &#x9; nudge adir, aforce &#x9; if tiltswitch = 0 then exit sub ' if no switch why care &#x9; mcount = mcount + aforce 1 2 &#x9; if mcount > msensitivity + 10 then mcount = msensitivity + 10 &#x9; if mcount >= msensitivity then vpmtimer pulsesw tiltswitch &#x9; needupdate = true &#x9;end sub &#x9;public sub update &#x9; if mcount > 0 then &#x9; mnudgetimer = mnudgetimer + 1 &#x9; if mnudgetimer > 1000\contimerpulse then &#x9; if mcount > msensitivity+1 then mcount = mcount 1 vpmtimer pulsesw tiltswitch &#x9; mcount = mcount 1 mnudgetimer = 0 &#x9; end if &#x9; else &#x9; mcount = 0 needupdate = false &#x9; end if &#x9;end sub &#x9;public sub reset mcount = 0 end sub &#x9;public sub solgameon(aenabled) &#x9; if isempty(mforce) then exit sub 'prevent errors if vpmnudge tiltobj isn't set &#x9; dim obj, ii &#x9; if aenabled then &#x9; ii = 0 &#x9; for each obj in mslingbump &#x9; if typename(obj) = "bumper" then obj threshold = mforce(ii) &#x9; if vpmvpver >= 90 and typename(obj) = "wall" then obj slingshotthreshold = mforce(ii) &#x9; ii = ii + 1 &#x9; next &#x9; else &#x9; for each obj in mslingbump &#x9; if typename(obj) = "bumper" then obj threshold = 100 &#x9; if vpmvpver >= 90 and typename(obj) = "wall" then obj slingshotthreshold = 100 &#x9; next &#x9; end if &#x9;end sub end class ' ' droptarget ' class cvpmdroptarget &#x9;private mdropobj, mdropsw(), mdropsnd, mraisesnd, mswanyup, mswalldn, malldn, mlink &#x9;private sub class initialize &#x9; mdropsnd = 0 mraisesnd = 0 mswanyup = 0 mswalldn = 0 malldn = false mlink = empty &#x9;end sub &#x9;private sub checkalldn(byval astatus) &#x9; dim obj &#x9; if not isempty(mlink) then &#x9; if astatus then &#x9; for each obj in mlink astatus = astatus and obj alldown next &#x9; end if &#x9; for each obj in mlink obj setalldn astatus next &#x9; end if &#x9; setalldn astatus &#x9;end sub &#x9;public sub setalldn(astatus) &#x9; dim mswcopy &#x9; if mswalldn then &#x9; mswcopy = mswalldn &#x9; controller switch(mswcopy) = astatus &#x9; end if &#x9; if mswanyup then &#x9; mswcopy = mswanyup &#x9; controller switch(mswcopy) = not astatus &#x9; end if &#x9;end sub &#x9;public sub initdrop(awalls, asw) &#x9; dim obj, obj2, ii &#x9; ' fill in switch number &#x9; on error resume next redim mdropsw(0) &#x9; if isarray(asw) then &#x9; redim mdropsw(ubound(asw)) &#x9; for ii = 0 to ubound(asw) mdropsw(ii) = asw(ii) next &#x9; elseif asw = 0 or err then &#x9; on error goto 0 &#x9; if vpmisarray(awalls) then &#x9; ii = 0 if isarray(awalls) then redim mdropsw(ubound(awalls)) else redim mdropsw(awalls count 1) &#x9; for each obj in awalls &#x9; if vpmisarray(obj) then &#x9; for each obj2 in obj &#x9; if obj2 hashitevent then mdropsw(ii) = obj2 timerinterval exit for &#x9; next &#x9; else &#x9; mdropsw(ii) = obj timerinterval &#x9; end if &#x9; ii = ii + 1 &#x9; next &#x9; else &#x9; mdropsw(0) = awalls timerinterval &#x9; end if &#x9; else &#x9; mdropsw(0) = asw &#x9; end if &#x9; ' copy walls &#x9; vpmsetarray mdropobj, awalls &#x9;end sub &#x9;public sub createevents(aname) &#x9; dim ii, obj1, obj2 &#x9; if not vpmcheckevent(aname, me) then exit sub &#x9; ii = 1 &#x9; for each obj1 in mdropobj &#x9; if vpmisarray(obj1) then &#x9; for each obj2 in obj1 &#x9; if typename(obj2) = "hittarget" then 'if object in array is a target, use dropped &#x9; vpmbuildevent obj2, "dropped", aname & " hit " & ii 'droptarget dropped dtbank hit 1 end sub &#x9; else &#x9; if obj2 hashitevent then vpmbuildevent obj2, "hit", aname & " hit " & ii &#x9; end if &#x9; next &#x9; else &#x9; if typename(obj1) = "hittarget" then 'if object in array is a target, use dropped &#x9; vpmbuildevent obj1, "dropped", aname & " hit " & ii &#x9; else &#x9; vpmbuildevent obj1, "hit", aname & " hit " & ii &#x9; end if &#x9; end if &#x9; ii = ii + 1 &#x9; next &#x9;end sub &#x9;public property let anyupsw(aswanyup) &#x9; dim mswcopy &#x9; mswanyup = aswanyup &#x9; mswcopy = mswanyup &#x9; controller switch(mswcopy) = true &#x9;end property &#x9;public property let alldownsw(aswalldn) mswalldn = aswalldn end property &#x9;public property get alldown alldown = malldn end property &#x9;public sub initsnd(adrop, araise) mdropsnd = adrop mraisesnd = araise end sub &#x9;public property let linkedto(alink) &#x9; if isarray(alink) then mlink = alink else mlink = array(alink) &#x9;end property &#x9;public sub hit(ano) &#x9; dim ii, mswcopy &#x9; vpmsolwall mdropobj(ano 1), mdropsnd, true &#x9; mswcopy = mdropsw(ano 1) &#x9; controller switch(mswcopy) = true &#x9; for each ii in mdropsw &#x9; mswcopy = ii &#x9; if not controller switch(mswcopy) then exit sub &#x9; next &#x9; malldn = true checkalldn true &#x9;end sub &#x9;public sub solhit(ano, aenabled) if aenabled then hit ano end if end sub &#x9;public sub solunhit(ano, aenabled) &#x9; dim mswcopy &#x9; dim ii if not aenabled then exit sub &#x9; playsound mraisesnd vpmsolwall mdropobj(ano 1), false, false &#x9; mswcopy = mdropsw(ano 1) &#x9; controller switch(mswcopy) = false &#x9; malldn = false checkalldn false &#x9;end sub &#x9;public sub soldropdown(aenabled) &#x9; dim mswcopy &#x9; dim ii if not aenabled then exit sub &#x9; playsound mdropsnd &#x9; for each ii in mdropobj vpmsolwall ii, false, true next &#x9; for each ii in mdropsw mswcopy = ii controller switch(mswcopy) = true next &#x9; malldn = true checkalldn true &#x9;end sub &#x9;public sub soldropup(aenabled) &#x9; dim mswcopy &#x9; dim ii if not aenabled then exit sub &#x9; playsound mraisesnd &#x9; for each ii in mdropobj vpmsolwall ii, false, false next &#x9; for each ii in mdropsw mswcopy = ii controller switch(mswcopy) = false next &#x9; malldn = false checkalldn false &#x9;end sub &#x9;public sub dropsol on soldropup true end sub end class ' ' magnet ' class cvpmmagnet &#x9;private menabled, mballs, mtrigger &#x9;public x, y, strength, size, grabcenter, solenoid &#x9;private sub class initialize &#x9; size = 1 strength = 0 solenoid = 0 menabled = false &#x9; set mballs = new cvpmdictionary &#x9;end sub &#x9;private property let needupdate(aenabled) vpmtimer enableupdate me, true, aenabled end property &#x9;public sub initmagnet(atrigger, astrength) &#x9; dim tmp &#x9; if vpmisarray(atrigger) then set tmp = atrigger(0) else set tmp = atrigger &#x9; x = tmp x y = tmp y size = tmp radius vpmtimer inittimer tmp, true &#x9; if isarray(atrigger) then mtrigger = atrigger else set mtrigger = atrigger &#x9; strength = astrength grabcenter = astrength > 14 &#x9;end sub &#x9;public sub createevents(aname) &#x9; if vpmcheckevent(aname, me) then &#x9; vpmbuildevent mtrigger, "hit", aname & " addball activeball" &#x9; vpmbuildevent mtrigger, "unhit", aname & " removeball activeball" &#x9; end if &#x9;end sub &#x9;public property let magneton(aenabled) menabled = aenabled end property &#x9;public property get magneton &#x9; if solenoid > 0 then magneton = controller solenoid(solenoid) else magneton = menabled &#x9;end property &#x9;public sub addball(aball) &#x9; with mballs &#x9; if exists(aball) then item(aball) = item(aball) + 1 else add aball, 1 needupdate = true &#x9; end with &#x9;end sub &#x9;public sub removeball(aball) &#x9; with mballs &#x9; if exists(aball) then item(aball) = item(aball) 1 if item(aball) <= 0 then remove aball &#x9; needupdate = ( count > 0) &#x9; end with &#x9;end sub &#x9;public property get balls balls = mballs keys end property &#x9;public sub update &#x9; dim obj &#x9; if magneton then &#x9; on error resume next &#x9; for each obj in mballs keys &#x9; if obj x < 0 or err then mballs remove obj else attractball obj &#x9; next &#x9; on error goto 0 &#x9; end if &#x9;end sub &#x9;public sub attractball(aball) &#x9; dim dx, dy, dist, force, ratio &#x9; dx = aball x x dy = aball y y dist = sqr(dx dx + dy dy) &#x9; if dist > size or dist < 1 then exit sub 'just to be safe &#x9; if grabcenter and dist < 20 then &#x9; aball velx = 0 aball vely = 0 aball x = x aball y = y &#x9; else &#x9; ratio = dist / (1 5 size) &#x9; force = strength exp( 0 2/ratio)/(ratio ratio 56) 1 5 &#x9; aball velx = (aball velx dx force / dist) 0 985 &#x9; aball vely = (aball vely dy force / dist) 0 985 &#x9; end if &#x9;end sub &#x9;' obsolete &#x9;public property let range(asize) size = asize end property &#x9;public property get range range = size end property end class ' ' turntable ' class cvpmturntable &#x9;private mx, my, msize, mtrigger, mballs, mspinup, mspindown &#x9;private mmotoron, mspincw &#x9;private mmaxspeed, mtargetspeed, mcurrentaccel &#x9;public speed &#x9;private sub class initialize &#x9; set mballs = new cvpmdictionary &#x9; mmotoron = false mspincw = true speed = 0 mspinup = 10 mspindown = 4 &#x9; adjusttargets &#x9;end sub &#x9;private property let needupdate(aenabled) vpmtimer enableupdate me, true, aenabled end property &#x9;public sub initturntable(atrigger, amaxspeed) &#x9; mx = atrigger x my = atrigger y msize = atrigger radius vpmtimer inittimer atrigger, true &#x9; mmaxspeed = amaxspeed set mtrigger = atrigger &#x9; adjusttargets &#x9;end sub &#x9;public sub createevents(aname) &#x9; if vpmcheckevent(aname, me) then &#x9; vpmbuildevent mtrigger, "hit", aname & " addball activeball" &#x9; vpmbuildevent mtrigger, "unhit", aname & " removeball activeball" &#x9; end if &#x9;end sub &#x9;public sub solmotorstate(acw, amotoron) &#x9; mspincw = acw &#x9; mmotoron = amotoron &#x9; adjusttargets &#x9;end sub private sub adjusttargets &#x9; if mmotoron then &#x9; mtargetspeed = maxspeed &#x9; mcurrentaccel = spinup &#x9; if not mspincw then mtargetspeed = maxspeed &#x9; else &#x9; mtargetspeed = 0 &#x9; mcurrentaccel = spindown &#x9; end if needupdate = mballs count or spinup or spindown end sub public property let maxspeed(newspeed) mmaxspeed = newspeed adjusttargets end property public property let spinup(newrate) mspinup = newrate adjusttargets end property public property let spindown(newrate) mspindown = newrate adjusttargets end property public property get maxspeed maxspeed = mmaxspeed end property public property get spinup spinup = mspinup end property public property get spindown spindown = mspindown end property &#x9;public property let motoron(aenabled) solmotorstate mspincw, aenabled end property &#x9;public property let spincw(acw) solmotorstate acw, mmotoron end property &#x9;public property get motoron motoron = mmotoron end property &#x9;public property get spincw spincw = mspincw end property &#x9;public sub addball(aball) &#x9; on error resume next mballs add aball,0 needupdate = true &#x9;end sub &#x9;public sub removeball(aball) &#x9; on error resume next &#x9; mballs remove aball needupdate = mballs count or spinup or spindown &#x9;end sub &#x9;public property get balls balls = mballs keys end property &#x9;public sub update &#x9; if speed > mtargetspeed then &#x9; speed = speed mcurrentaccel/100 &#x9; if speed < mtargetspeed then speed = mtargetspeed needupdate = mballs count &#x9; elseif speed < mtargetspeed then &#x9; speed = speed + mcurrentaccel/100 &#x9; if speed > mtargetspeed then speed = mtargetspeed needupdate = mballs count &#x9; end if &#x9; if speed then &#x9; dim obj &#x9; on error resume next &#x9; for each obj in mballs keys &#x9; if obj x < 0 or err then mballs remove obj else affectball obj &#x9; next &#x9; on error goto 0 &#x9; end if &#x9;end sub &#x9;public sub affectball(aball) &#x9; dim dx, dy, dist &#x9; dx = aball x mx dy = aball y my dist = sqr(dx dx + dy dy) &#x9; if dist > msize or dist < 1 or speed = 0 then exit sub &#x9; aball velx = aball velx (dy speed / 8000) &#x9; aball vely = aball vely + (dx speed / 8000) &#x9;end sub end class ' ' mech ' const vpmmechlinear = \&h00 const vpmmechnonlinear = \&h01 const vpmmechcircle = \&h00 const vpmmechstopend = \&h02 const vpmmechreverse = \&h04 const vpmmechonesol = \&h00 const vpmmechonedirsol = \&h10 const vpmmechtwodirsol = \&h20 const vpmmechstepsol = \&h40 const vpmmechslow = \&h00 const vpmmechfast = \&h80 const vpmmechstepsw = \&h00 const vpmmechlengthsw = \&h100 class cvpmmech &#x9;public sol1, sol2, mtype, length, steps, acc, ret &#x9;private mmechno, mnextsw, msw(), mlastpos, mlastspeed, mcallback &#x9;private sub class initialize &#x9; redim msw(10) &#x9; gnextmechno = gnextmechno + 1 mmechno = gnextmechno mnextsw = 0 mlastpos = 0 mlastspeed = 0 &#x9; mtype = 0 length = 0 steps = 0 acc = 0 ret = 0 vpmtimer addresetobj me &#x9;end sub &#x9;public sub addsw(aswno, astart, aend) &#x9; msw(mnextsw) = array(aswno, astart, aend, 0) &#x9; mnextsw = mnextsw + 1 &#x9;end sub &#x9;public sub addpulseswnew(aswno, ainterval, astart, aend) &#x9; if controller version >= "01200000" then &#x9; msw(mnextsw) = array(aswno, astart, aend, ainterval) &#x9; else &#x9; msw(mnextsw) = array(aswno, ainterval, aend astart + 1, 0) &#x9; end if &#x9; mnextsw = mnextsw + 1 &#x9;end sub &#x9;public sub start &#x9; dim sw, ii &#x9; with controller &#x9; mech(1) = sol1 mech(2) = sol2 mech(3) = length &#x9; mech(4) = steps mech(5) = mtype mech(6) = acc mech(7) = ret &#x9; ii = 10 &#x9; for each sw in msw &#x9; if isarray(sw) then &#x9; mech(ii) = sw(0) mech(ii+1) = sw(1) &#x9; mech(ii+2) = sw(2) mech(ii+3) = sw(3) &#x9; ii = ii + 10 &#x9; end if &#x9; next &#x9; mech(0) = mmechno &#x9; end with &#x9; if isobject(mcallback) then mcallback 0, 0, 0 mlastpos = 0 vpmtimer enableupdate me, false, true &#x9;end sub &#x9;public property get position position = controller getmech(mmechno) end property &#x9;public property get speed speed = controller getmech( mmechno) end property &#x9;public property let callback(acallback) set mcallback = acallback end property &#x9;public sub update &#x9; dim currpos, speed &#x9; currpos = controller getmech(mmechno) &#x9; speed = controller getmech( mmechno) &#x9; if currpos < 0 or (mlastpos = currpos and mlastspeed = speed) then exit sub &#x9; mcallback currpos, speed, mlastpos mlastpos = currpos mlastspeed = speed &#x9;end sub &#x9;public sub reset start end sub &#x9;' obsolete &#x9;public sub addpulsesw(aswno, ainterval, alength) addsw aswno, ainterval, alength end sub end class ' ' captive ball ' class cvpmcaptiveball &#x9;private mballkicked, mballdir, mballcos, mballsin, mtrighit &#x9;private mtrig, mwall, mkickers, mvelx, mvely, mkickno &#x9;public forcetrans, minforce, restswitch, nailedballs &#x9;private sub class initialize &#x9; mballkicked = false forcetrans = 0 5 mtrighit = false minforce = 3 nailedballs = 0 &#x9; vpmtimer addresetobj me &#x9;end sub &#x9;public sub initcaptive(atrig, awall, akickers, aballdir) &#x9; set mtrig = atrig set mwall = awall &#x9; mkickno = vpmsetarray(mkickers, akickers) &#x9; mballdir = aballdir mballcos = cos(aballdir 3 1415927/180) mballsin = sin(aballdir 3 1415927/180) &#x9;end sub &#x9;public sub start &#x9; dim mswcopy &#x9; vpmcreateball mkickers(mkickno + (mkickno <> nailedballs)) &#x9; if restswitch then &#x9; mswcopy = restswitch &#x9; controller switch(mswcopy) = true &#x9; end if &#x9;end sub &#x9;public sub trighit(aball) &#x9; mtrighit = isobject(aball) if mtrighit then mvelx = aball velx mvely = aball vely &#x9;end sub &#x9;public sub reset &#x9; dim mswcopy &#x9; if restswitch then &#x9; mswcopy = restswitch &#x9; controller switch(mswcopy) = true &#x9; end if &#x9;end sub &#x9;public sub ballhit(aball) &#x9; dim dx, dy, force, mswcopy &#x9; if mballkicked then exit sub ' ball is not here &#x9; if mtrighit then mtrighit = false else mvelx = aball velx mvely = aball vely &#x9; dx = aball x mkickers(0) x dy = aball y mkickers(0) y &#x9; force = forcetrans (dy mvely + dx mvelx) (dy mballcos + dx mballsin) / (dx dx + dy dy) &#x9; if force < 1 then exit sub &#x9; if force < minforce then force = minforce &#x9; if mkickno <> nailedballs then &#x9; vpmcreateball mkickers(mkickno) &#x9; mkickers(mkickno 1) destroyball &#x9; end if &#x9; mkickers(mkickno) kick mballdir, force mballkicked = true &#x9; if restswitch then &#x9; mswcopy = restswitch &#x9; controller switch(mswcopy) = false &#x9; end if &#x9;end sub &#x9;public sub ballreturn(akicker) &#x9; dim mswcopy &#x9; if mkickno <> nailedballs then vpmcreateball mkickers(mkickno 1) akicker destroyball &#x9; mballkicked = false &#x9; if restswitch then &#x9; mswcopy = restswitch &#x9; controller switch(mswcopy) = true &#x9; end if &#x9;end sub &#x9;public sub createevents(aname) &#x9; if vpmcheckevent(aname, me) then &#x9; if not mtrig is nothing then &#x9; vpmbuildevent mtrig, "hit", aname & " trighit activeball" &#x9; vpmbuildevent mtrig, "unhit", aname & " trighit 0" &#x9; end if &#x9; vpmbuildevent mwall, "hit", aname & " ballhit activeball" &#x9; vpmbuildevent mkickers(mkickno), "hit", aname & " ballreturn me" &#x9; end if &#x9;end sub &#x9;' obsolete &#x9;public ballimage, ballcolour end class ' ' visible locks ' class cvpmvlock &#x9;private mtrig, mkick, msw(), msize, mballs, mgateopen, mrealforce, mballsnd, mnoballsnd &#x9;public exitdir, exitforce, kickforcevar &#x9;private sub class initialize &#x9; mballs = 0 exitdir = 0 exitforce = 0 kickforcevar = 0 mgateopen = false &#x9; vpmtimer addresetobj me &#x9;end sub &#x9;public sub initvlock(atrig, akick, asw) &#x9; dim ii &#x9; msize = vpmsetarray(mtrig, atrig) &#x9; if vpmsetarray(mkick, akick) <> msize then msgbox "cvpmvlock unmatched kick+trig" exit sub &#x9; on error resume next &#x9; redim msw(msize) &#x9; if isarray(asw) then &#x9; for ii = 0 to ubound(asw) msw(ii) = asw(ii) next &#x9; elseif asw = 0 or err then &#x9; for ii = 0 to msize msw(ii) = mtrig(ii) timerinterval next &#x9; else &#x9; msw(0) = asw &#x9; end if &#x9;end sub &#x9;public sub initsnd(aball, anoball) mballsnd = aball mnoballsnd = anoball end sub &#x9;public sub createevents(aname) &#x9; dim ii &#x9; if not vpmcheckevent(aname, me) then exit sub &#x9; for ii = 0 to msize &#x9; vpmbuildevent mtrig(ii), "hit", aname & " trighit activeball," & ii+1 &#x9; vpmbuildevent mtrig(ii), "unhit", aname & " trigunhit activeball," & ii+1 &#x9; vpmbuildevent mkick(ii), "hit", aname & " kickhit " & ii+1 &#x9; next &#x9;end sub &#x9;public sub solexit(aenabled) &#x9; dim ii, mswcopy &#x9; mgateopen = aenabled &#x9; if not aenabled then exit sub &#x9; if mballs > 0 then playsound mballsnd else playsound mnoballsnd exit sub &#x9; for ii = 0 to mballs 1 &#x9; mkick(ii) enabled = false &#x9; if msw(ii) then &#x9; mswcopy = msw(ii) &#x9; controller switch(mswcopy) = false &#x9; end if &#x9; next &#x9; if exitforce > 0 then ' up &#x9; mrealforce = exitforce + (rnd 0 5) kickforcevar mkick(mballs 1) kick exitdir, mrealforce &#x9; else ' down &#x9; mkick(0) kick 0, 0 &#x9; end if &#x9;end sub &#x9;public sub reset &#x9; dim mswcopy &#x9; dim ii if mballs = 0 then exit sub &#x9; for ii = 0 to mballs 1 &#x9; if msw(ii) then &#x9; mswcopy = msw(ii) &#x9; controller switch(mswcopy) = true &#x9; end if &#x9; next &#x9;end sub &#x9;public property get balls balls = mballs end property &#x9;public property let balls(aballs) &#x9; dim mswcopy &#x9; dim ii mballs = aballs &#x9; for ii = 0 to msize &#x9; mswcopy = msw(ii) &#x9; if ii >= aballs then &#x9; mkick(ii) destroyball if mswcopy then controller switch(mswcopy) = false &#x9; else &#x9; vpmcreateball mkick(ii) if mswcopy then controller switch(mswcopy) = true &#x9; end if &#x9; next &#x9;end property &#x9;public sub trighit(aball, ano) &#x9; dim mswcopy &#x9; ano = ano 1 &#x9; if msw(ano) then &#x9; mswcopy = msw(ano) &#x9; controller switch(mswcopy) = true &#x9; end if &#x9; if aball vely < 1 then exit sub ' allow small upwards speed &#x9; if ano = msize then mballs = mballs + 1 &#x9; if mballs > ano then mkick(ano) enabled = not mgateopen &#x9;end sub &#x9;public sub trigunhit(aball, ano) &#x9; dim mswcopy &#x9; ano = ano 1 &#x9; if msw(ano) then &#x9; mswcopy = msw(ano) &#x9; controller switch(mswcopy) = false &#x9; end if &#x9; if aball vely > 1 then &#x9; if ano = 0 then mballs = mballs 1 &#x9; if ano < msize then mkick(ano+1) kick 0, 0 &#x9; else &#x9; if ano = msize then mballs = mballs 1 &#x9; if ano > 0 then mkick(ano 1) kick exitdir, mrealforce &#x9; end if &#x9;end sub &#x9;public sub kickhit(ano) mkick(ano 1) enabled = false end sub end class ' ' view dips ' class cvpmdips &#x9;private mlwf, mchkcount, moptcount, mitems() &#x9;private sub class initialize &#x9; redim mitems(100) &#x9;end sub &#x9;private sub addchkbox(atype, aleft, atop, awidth, anames) &#x9; dim ii, obj &#x9; if not isobject(mlwf) then exit sub &#x9; for ii = 0 to ubound(anames) step 2 &#x9; set obj = mlwf addctrl("chkbox", 10+aleft, 5+atop+ii 7, awidth, 14, anames(ii)) &#x9; mchkcount = mchkcount + 1 mitems(mchkcount+moptcount) = array(atype, obj, mchkcount, anames(ii+1), anames(ii+1)) &#x9; next &#x9;end sub &#x9;private sub addoptbox(atype, aleft, atop, awidth, aheading, amask, anames) &#x9; dim ii, obj &#x9; if not isobject(mlwf) then exit sub &#x9; mlwf addctrl "frame", 10+aleft, 5+atop, 10+awidth, 7 ubound(anames)+25, aheading &#x9; if amask then &#x9; for ii = 0 to ubound(anames) step 2 &#x9; set obj = mlwf addctrl("optbtn", 10+aleft+5, 5+atop+ii 7+14, awidth, 14, anames(ii)) &#x9; moptcount = moptcount + 1 mitems(mchkcount+moptcount) = array(atype+2,obj,moptcount,anames(ii+1),amask) &#x9; next &#x9; else &#x9; addchkbox atype, 5+aleft, 15+atop, awidth, anames &#x9; end if &#x9;end sub &#x9;public sub addform(byval awidth, aheight, aname) &#x9; if awidth < 80 then awidth = 80 &#x9; on error resume next &#x9; set mlwf = createobject("vpinmame wshdlg") if err then exit sub &#x9; with mlwf &#x9; x = 1 y = 1 ' w = awidth h = aheight+60 &#x9; title = aname addctrl "okbtn", 1, 1, 70, 25, "\&ok" &#x9; end with &#x9; mchkcount = 0 moptcount = 0 &#x9;end sub &#x9;public sub addchk(aleft, atop, awidth, anames) &#x9; addchkbox 0, aleft, atop, awidth, anames &#x9;end sub &#x9;public sub addchkextra(aleft, atop, awidth, anames) &#x9; addchkbox 1, aleft, atop, awidth, anames &#x9;end sub &#x9;public sub addframe(aleft, atop, awidth, aheading, amask, anames) &#x9; addoptbox 0, aleft, atop, awidth, aheading, amask, anames &#x9;end sub &#x9;public sub addframeextra(aleft, atop, awidth, aheading, amask, anames) &#x9; addoptbox 1, aleft, atop, awidth, aheading, amask, anames &#x9;end sub &#x9;public sub addlabel(aleft, atop, awidth, aheight, acaption) &#x9; if not isobject(mlwf) then exit sub &#x9; mlwf addctrl "label", 10+aleft, 5+atop, awidth, aheight, acaption &#x9;end sub &#x9;public sub viewdips viewdipsextra 0 end sub &#x9;public function viewdipsextra(aextra) &#x9; dim dips(1), ii, usedip &#x9; if not isobject(mlwf) then exit function &#x9; with controller &#x9; dips(0) = dip(0) + dip(1) 256 + dip(2) 65536 + ( dip(3) and \&h7f) \&h1000000 &#x9; if dip(3) and \&h80 then dips(0) = dips(0) or \&h80000000 'workaround for overflow error &#x9; end with &#x9; usedip = false dips(1) = aextra &#x9; for ii = 1 to mchkcount + moptcount &#x9; mitems(ii)(1) value = ((dips(mitems(ii)(0) and \&h01) and mitems(ii)(4)) = mitems(ii)(3)) &#x9; if (mitems(ii)(0) and \&h01) = 0 then usedip = true &#x9; next &#x9; mlwf show getplayerhwnd &#x9; dips(0) = 0 dips(1) = 0 &#x9; for ii = 1 to mchkcount + moptcount &#x9; if mitems(ii)(1) value then dips(mitems(ii)(0) and \&h01) = dips(mitems(ii)(0) and \&h01) or mitems(ii)(3) &#x9; next &#x9; if usedip then &#x9; with controller &#x9; dip(0) = (dips(0) and 255) &#x9; dip(1) = ((dips(0) and 65280)\256) and 255 &#x9; dip(2) = ((dips(0) and \&h00ff0000)\65536) and 255 &#x9; dip(3) = ((dips(0) and \&hff000000)\\\&h01000000) and 255 &#x9; end with &#x9; end if &#x9; viewdipsextra = dips(1) &#x9;end function end class ' ' impulse plunger ' class cvpmimpulsep &#x9;private menabled, mballs, mtrigger, mentrysnd, mexitsnd, mexitsndball &#x9;public x, y, strength, res, size, solenoid, impowerout, time, mcount, pull, impowertrans, cfactor, auto, randomout, switchnum, switchon, ballon &#x9;private sub class initialize &#x9; size = 1 strength = 0 solenoid = 0 res = 1 impowerout = 0 time = 0 mcount = 0 menabled = false &#x9; pull = 0 impowertrans = 0 auto = false randomout = 0 switchon = 0 switchnum = 0 ballon = 0 &#x9; set mballs = new cvpmdictionary &#x9;end sub &#x9;private property let needupdate(aenabled) vpmtimer enableupdate me, true, aenabled end property &#x9;public sub initimpulsep(atrigger, astrength, atime) &#x9; dim tmp &#x9; if vpmisarray(atrigger) then set tmp = atrigger(0) else set tmp = atrigger &#x9; x = tmp x y = tmp y size = tmp radius vpmtimer inittimer tmp, true &#x9; if isarray(atrigger) then mtrigger = atrigger else set mtrigger = atrigger &#x9; strength = astrength &#x9; res = 500 &#x9; time = atime &#x9; if atime = 0 then &#x9; auto = true &#x9; else &#x9; cfactor = (res / time) / 100 &#x9; auto = false &#x9; end if &#x9;end sub &#x9;public sub createevents(aname) &#x9; if vpmcheckevent(aname, me) then &#x9; vpmbuildevent mtrigger, "hit", aname & " addball activeball" &#x9; vpmbuildevent mtrigger, "unhit", aname & " removeball activeball" &#x9; end if &#x9;end sub &#x9;public property let plungeon(aenabled) menabled = aenabled end property &#x9;public property get plungeon &#x9; if solenoid > 0 then plungeon = controller solenoid(solenoid) else plungeon = menabled &#x9;end property &#x9;public sub addball(aball) &#x9; dim mswcopy &#x9; with mballs &#x9; if exists(aball) then item(aball) = item(aball) + 1 else add aball, 1 needupdate = true &#x9; end with &#x9; if switchon = true then &#x9; mswcopy = switchnum &#x9; controller switch(mswcopy) = 1 &#x9; end if &#x9; ballon = 1 &#x9;end sub &#x9;public sub removeball(aball) &#x9; dim mswcopy &#x9; with mballs &#x9; if exists(aball) then item(aball) = item(aball) 1 if item(aball) <= 0 then remove aball &#x9; needupdate = ( count > 0) &#x9; end with &#x9; if switchon = true then &#x9; mswcopy = switchnum &#x9; controller switch(mswcopy) = 0 &#x9; end if &#x9; ballon = 0 &#x9;end sub &#x9;public property get balls balls = mballs keys end property &#x9;public sub update &#x9; dim obj &#x9; if pull = 1 and mcount < res then &#x9; mcount = mcount + cfactor &#x9; impowertrans = mcount &#x9; needupdate = true &#x9; else &#x9; impowertrans = mcount &#x9; needupdate = false &#x9; end if &#x9; if plungeon then &#x9; on error resume next &#x9; for each obj in mballs keys &#x9; if obj x < 0 or err then mballs remove obj else plungeball obj end if &#x9; next &#x9; on error goto 0 &#x9; end if &#x9;end sub &#x9;public sub plungeball(aball) &#x9; aball vely = impowerout &#x9;end sub &#x9;public sub random(ainput) ' random output varience &#x9; randomout = ainput &#x9;end sub &#x9;public sub fire ' resets system and transfer power value &#x9; if auto = true then &#x9; impowerout = strength + ((rnd) randomout) &#x9; else &#x9; impowerout = strength (impowertrans + ((rnd 0 5) cfactor randomout)) / res &#x9; end if &#x9; plungeon = true &#x9; update &#x9; plungeon = false &#x9; pull = 0 impowerout = 0 impowertrans = 0 mcount = 0 &#x9; if ballon = 1 then playsound mexitsndball else playsound mexitsnd end if &#x9;end sub &#x9;public sub autofire ' auto fire specific call (so you don't have to change timing) &#x9; impowerout = strength + ((rnd) randomout) &#x9; plungeon = true &#x9; update &#x9; plungeon = false &#x9; pull = 0 impowerout = 0 impowertrans = 0 mcount = 0 &#x9; if ballon = 1 then playsound mexitsndball else playsound mexitsnd end if &#x9;end sub &#x9; &#x9;public sub pullback ' pull plunger &#x9; pull = 0 impowerout = 0 impowertrans = 0 mcount = 0 ' reinitialize to be sure &#x9; pull = 1 needupdate = true playsound mentrysnd &#x9;end sub &#x9; &#x9;public sub switch(asw) &#x9; switchon = true &#x9; switchnum = asw &#x9;end sub &#x9; public sub initentrysnd(anoball) mentrysnd = anoball end sub public sub initexitsnd(aball, anoball) mexitsndball = aball mexitsnd = anoball end sub end class set vpmtimer = new cvpmtimer if loadscript("nudgeplugin vbs") then set vpmnudge = new cvpmnudge2 else set vpmnudge = new cvpmnudge ' 'cvpmflips (fastflips) 2 beta 1 ' 'redesigned to better support games from the solid state flipper era, including previously unsupported games thanks to djrobx and stumblor! 'new features ' switches from script to rom control after a delay (100ms default, vpmflips romcontroldelay) ' this works independently for each flipper, ex the thing flip will not interfere even briefly with lower flippers ' new feature vpmflips enabled vpmflips enabled = true / false will enable / disable fastflips (this does the same thing as vpmflipssam romcontrol) ' may be necessary to manually disable flippers for video mode on some games ' new method to disable upper flippers without getting rom errors from the double action cab switches call helper subs noupperleftflipper, noupperrightflipper ' on ss games that reuse upper flipper coils, call the appropriate helper subs from the table script noupperleftflipper, noupperrightflipper (for example afm) ' on ss games that reuse upper flipper switches, you will still need the csinglelflip/csinglerflip lines! ' csinglexflip automatically disables flippers to retain legacy behavior ' initializes using pulsetimer vpminit me line no longer necessary (? may change) 'todo 'test delay works okay but a little weird if longer than romcontroldelay 'test more tables 'test red & ted with the left side flippers 'test region safety 'update sam vbs ? dim vpmflips set vpmflips = new cvpmflips2 vpmflips name = "vpmflips" sub noupperleftflipper() vpmflips flippersolnumber(2) = 0 end sub sub noupperrightflipper() vpmflips flippersolnumber(3) = 0 end sub function nullfunction(a) end function vpmtimer addtimer 40, "vpmflips init'" 'this might be a dumb idea but it would replace the requirement for vpminit me class cvpmflips2 'test fastflips switches to rom control after 100ms or so delay public name, delay, tiltobjects, sol, debugon public lagcompensation 'flag for solenoid jitter (may not be a problem anymore) set private public flippersolnumber(3) 'flipper solenoid number by default these are set to use the core constants 0=left 1=right 2=uleft 3=uright public buttonstate(3) 'key flip state 'set private public solstate(3) 'rom flip state 'set private 'public subl, subul, subr, subur 'may restore these to reduce nested calls for now the script is compressed a bit public flippersub(3) 'set to the flipper subs by init public flippersenabled 'flipper circuit state (from the rom) public onoff 'fastflips enabled separate from flippersenabled, which is the flipper circuit state 'private 'todo rename public flipat(3) 'flip time in gametime 'private public romcontroldelay 'delay after flipping that rom controlled flips are accepted (default 100ms) private sub class initialize() dim idx \ for idx = 0 to 3 \ flippersub(idx) = "nullfunction" onoff=true buttonstate(idx)=0\ solstate(idx)=0 next delay=0 flippersenabled=0 debugon=0 lagcompensation=0 sol=0 tiltobjects=1 romcontroldelay = 100 'romcontroldelay ms between switching to rom controlled flippers flippersolnumber(0)=sllflipper \ flippersolnumber(1)=slrflipper \ flippersolnumber(2)=sulflipper flippersolnumber(3)=surflipper end sub &#x9;sub init() 'called by a timer, but previously was called by vpminit sub &#x9; on error resume next 'if there's no usesolenoids variable present, exit &#x9; call eval(usesolenoids) if err then exit sub &#x9; on error goto 0 &#x9; err clear &#x9; 'set solenoid &#x9; if not usesolenoids > 1 then exit sub &#x9; on error resume next &#x9; 'for some wpc games (ij) that reuse upper flipper &#x9; 'switch numbers, and legacy fast flip code, disable &#x9; 'flippers if csinglexflip is set &#x9; if not csinglelflip then &#x9; if err number = 0 then noupperleftflipper &#x9; end if &#x9; err clear &#x9; if not csinglerflip then &#x9; if err number = 0 then noupperrightflipper &#x9; end if &#x9; err clear &#x9; if usesolenoids > 2 then &#x9; solenoid = usesolenoids &#x9; else &#x9; err clear &#x9; if isempty(gameonsolenoid) or err then msgbox "vpmflips error " & err description &#x9; if err = 500 then 'error 500 variable not defined &#x9; msgbox "usesolenoids = 2 error!" & vbnewline & vbnewline & "gameonsolenoid is not defined!" & vbnewline & &#x9; "system may be incompatible (check the compatibility list) or your system scripts may be out of date" &#x9; end if &#x9; solenoid = gameonsolenoid &#x9; end if &#x9; on error goto 0 &#x9; 'set callbacks &#x9; dim idx for idx = 0 to 3 &#x9; if isnumeric(flippersolnumber(idx)) then &#x9; callback(idx) = solcallback(abs(flippersolnumber(idx))) &#x9; end if &#x9; next &#x9;&#x9; &#x9; 'dim str &#x9; 'for idx = 0 to 3 str = str & "callback" & idx & " " & callback(idx) \&vbnewline next &#x9; 'str = "init successful" \&vbnewline& &#x9; ' "sol=" & solenoid & " " & sol \&vbnewline& str &#x9; 'msgbox str &#x9;''''vpmflips debugtestinit = true 'removed debug stuff for the moment &#x9;end sub &#x9;'index based callbacks &#x9;public property let callback(aidx, ainput) &#x9; if not isempty(ainput) then &#x9; flippersub(aidx) = ainput 'hold old flipper subs &#x9; solcallback(flippersolnumber(aidx)) = name & " romflip(" & aidx & ")=" &#x9; end if &#x9;end property &#x9;public property get callback(aidx) callback = flippersub(aidx) end property &#x9;public property let enabled(byval aenabled) 'improving choreography &#x9; aenabled = cbool(aenabled) &#x9; if aenabled <> onoff then 'disregard redundant updates &#x9; onoff = aenabled &#x9; dim idx &#x9; if aenabled then 'switch to rom solenoid states or button states immediately &#x9; for idx = 0 to 3 &#x9; if solstate(idx) <> buttonstate(idx) and flippersenabled then execute flippersub(idx) &" "& buttonstate(idx) end if &#x9; next &#x9; else &#x9; for idx = 0 to 3 if buttonstate(idx) <> solstate(idx) then execute flippersub(idx) &" "& solstate(idx) end if next &#x9; end if &#x9; end if &#x9;end property &#x9;public property get enabled enabled = onoff end property &#x9;public property let solenoid(ainput) if isnumeric(ainput) then sol = abs(ainput) end if end property 'set solenoid &#x9;public property get solenoid solenoid = sol end property &#x9;public property let flip(aidx, byval aenabled) 'key flip indexed base flip may keep may not &#x9; aenabled = abs(aenabled) 'true / false is not region safe with execute convert to 1 or 0 instead &#x9; buttonstate(aidx) = aenabled 'track flipper button states the game on sol flips immediately if the button is held down &#x9; 'debug print "key flip " & aidx &" @ " & gametime & " ff on " & onoff & " circuit on? " & flippersenabled &#x9; if onoff and flippersenabled or debugon then &#x9; execute flippersub(aidx) & " " & aenabled &#x9; flipat(aidx) = gametime &#x9; end if &#x9;end property 'call callbacks 'legacy public sub flipl(aenabled) flip(0)=aenabled \ end sub public sub flipr(aenabled) flip(1)=aenabled \ end sub public sub flipul(aenabled) flip(2)=aenabled \ end sub public sub flipur(aenabled) flip(3)=aenabled \ end sub public property let romflip(aidx, byval aenabled) aenabled = abs(aenabled) solstate(aidx) = aenabled &#x9; if not onoff or gametime >= flipat(aidx) + romcontroldelay then &#x9; execute flippersub(aidx) & " " & aenabled &#x9; 'tb text = "rom flip " & aidx & " state " & aenabled \&vbnewline& &#x9; 'gametime & " >= " & flipat(aidx) & "+" & romcontroldelay &#x9; 'debug print "rom flip @ " & gametime & "solenoid " & sol & " " & flippersenabled &#x9; end if end property public sub tiltsol(byval aenabled) 'handle solenoid / delay (if delayinit) aenabled = cbool(aenabled) if delay > 0 and not aenabled then 'handle delay vpmtimer addtimer delay, name & " firedelay" & "'" lagcompensation = 1 else if delay > 0 then lagcompensation = 0 enableflippers(aenabled) end if end sub sub firedelay() if lagcompensation then enableflippers false end if end sub public sub enableflippers(byval aenabled) 'private aenabled = abs(aenabled) 'might fix tmnt issue with vpmnudge solgameon? dim idx 'if aenabled then execute subl &" "& buttonstate(0) \ execute subr &" "& buttonstate(1) \ execute subul &" "& buttonstate(2) execute subur &" "& buttonstate(3)'\ end if if aenabled then for idx = 0 to 3 execute flippersub(idx) &" "& buttonstate(idx) next end if flippersenabled = aenabled if tiltobjects then vpmnudge solgameon aenabled if not aenabled then ' execute subl & " " & 0 execute subr & " " & 0 ' execute subul & " " & 0 execute subur & " " & 0 for idx = 0 to 3 execute flippersub(idx) &" "& 0 next end if end sub 'debug for finding sols 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 end class ' ' check vp version running ' private function vpmcheckvpver &#x9;on error resume next &#x9;' a bug in vbs? err object is not cleared on exit function &#x9;if vpbuildversion < 0 or err then vpmcheckvpver = 50 err clear exit function &#x9;if vpbuildversion > 2806 and vpbuildversion < 9999 then &#x9; vpmcheckvpver = 63 &#x9;elseif vpbuildversion > 2721 and vpbuildversion < 9999 then &#x9; vpmcheckvpver = 61 &#x9;elseif vpbuildversion >= 900 and vpbuildversion <= 999 then &#x9; vpmcheckvpver = 90 &#x9;elseif vpbuildversion >= 10000 then &#x9; vpmcheckvpver = 100 &#x9;else &#x9; vpmcheckvpver = 60 &#x9;end if end function private vpmvpver vpmvpver = vpmcheckvpver() ' ' initialise timers ' sub pulsetimer init vpmtimer inittimer me, false end sub sub pinmametimer init me interval = pinmameinterval me enabled = true end sub ' ' init function called from table init event ' public sub vpminit(atable) &#x9;set vpmtable = atable &#x9;if vpmvpver >= 60 then &#x9; on error resume next &#x9; if not isobject(getref(atable name & " paused")) or err then err clear vpmbuildevent atable, "paused", "controller pause = true" &#x9; if not isobject(getref(atable name & " unpaused")) or err then err clear vpmbuildevent atable, "unpaused", "controller pause = false" &#x9; if not isobject(getref(atable name & " exit")) or err then err clear vpmbuildevent atable, "exit", "controller pause = false\ controller stop" &#x9;end if &#x9;if usemodsol then &#x9; if controller version >= 02080000 then &#x9; controller solmask(2)=1 &#x9; else &#x9; msgbox "modulated flashers/solenoids not supported with this visual pinmame version (2 8 or newer is required)" &#x9; end if &#x9;end if &#x9;'initvpmflips 'have vpmtimer doing this atm end sub ' exit function called in table exit event public sub vpmexit end sub ' ' all classes call this function to create a ball ' assign vpmcreateball if you want a custom function ' private function vpmdefcreateball(akicker) &#x9;if not isempty(vpmballimage) then akicker createball image = vpmballimage else akicker createball end if &#x9;set vpmdefcreateball = akicker end function private function vpmdefcreateball2(akicker) &#x9;if not isempty(vpmballimage) then akicker createsizedball(bsize) image = vpmballimage else akicker createsizedball(bsize) end if &#x9;set vpmdefcreateball2 = akicker end function private function vpmdefcreateball3(akicker) &#x9;if not isempty(vpmballimage) then &#x9; akicker createsizedballwithmass(bsize,bmass) image = vpmballimage &#x9;else &#x9; akicker createsizedballwithmass bsize,bmass ' for whatever reason it doesn't work if using () &#x9;end if &#x9;set vpmdefcreateball3 = akicker end function if vpbuildversion >= 10000 then &#x9;set vpmcreateball = getref("vpmdefcreateball3") elseif vpbuildversion > 909 and vpmvpver >= 90 then set vpmcreateball = getref("vpmdefcreateball2") else &#x9;set vpmcreateball = getref("vpmdefcreateball") end if private vpmtrough ' default trough used to clear up missing balls private vpmtable ' table object ' ' main loop ' private const chgno = 0 private const chgstate = 1 private vpmtruefalse vpmtruefalse = array(" true", " false"," true") sub vpmdosolcallback(ano, aenabled) &#x9;if solcallback(ano) <> "" then execute solcallback(ano) & vpmtruefalse(aenabled+1) end sub sub vpmdolampupdate(ano, aenabled) &#x9;on error resume next lights(ano) state = abs(aenabled) end sub sub pinmametimer timer &#x9;dim chglamp,chgsol,chggi, ii, tmp, idx, nsol, solon, chgled &#x9;dim dmdp &#x9;dim chgnvram &#x9;'me enabled = false 'this was supposed to be some kind of weird mutex, disable it &#x9;on error resume next &#x9; if usedmd then &#x9; dmdp = controller rawdmdpixels &#x9; if not isempty(dmdp) then &#x9; dmdwidth = controller rawdmdwidth &#x9; dmdheight = controller rawdmdheight &#x9; dmdpixels = dmdp &#x9; end if &#x9; elseif usecoloreddmd then &#x9; dmdp = controller rawdmdcoloredpixels &#x9; if not isempty(dmdp) then &#x9; dmdwidth = controller rawdmdwidth &#x9; dmdheight = controller rawdmdheight &#x9; dmdcoloredpixels = dmdp &#x9; end if &#x9; end if &#x9; if usenvram then &#x9; if isobject(nvramcallback) then &#x9; chgnvram = controller changednvram 'controller nvram would deliver everything of the nvram all the time as 1d array &#x9; if(not isempty(chgnvram)) then nvramcallback chgnvram &#x9; end if &#x9; end if &#x9; if uselamps then chglamp = controller changedlamps else lampcallback &#x9; if usepdbleds then chgled = controller changedpdleds else pdledcallback &#x9; if usesolenoids then chgsol = controller changedsolenoids &#x9; if isobject(gicallback) or isobject(gicallback2) then chggi = controller changedgistrings &#x9; motorcallback &#x9;on error goto 0 &#x9;if not isempty(chglamp) then &#x9; on error resume next &#x9; for ii = 0 to ubound(chglamp) &#x9; idx = chglamp(ii, 0) &#x9; if isarray(lights(idx)) then &#x9; for each tmp in lights(idx) tmp state = chglamp(ii, 1) next &#x9; else &#x9; lights(idx) state = chglamp(ii, 1) &#x9; end if &#x9; next &#x9; for each tmp in vpmmultilights &#x9; for ii = 1 to ubound(tmp) tmp(ii) state = tmp(0) state next &#x9; next &#x9; lampcallback &#x9; on error goto 0 &#x9;end if &#x9;if not isempty(chgsol) then &#x9; for ii = 0 to ubound(chgsol) &#x9; nsol = chgsol(ii, 0) &#x9; tmp = solcallback(nsol) &#x9; solon = chgsol(ii, 1) &#x9; if solon > 1 then solon = 1 &#x9; if usemodsol then &#x9; if solon <> solprevstate(nsol) then &#x9; solprevstate(nsol) = solon &#x9; if tmp <> "" then execute tmp & vpmtruefalse(solon+1) &#x9; end if &#x9; tmp = solmodcallback(nsol) &#x9; if tmp <> "" then execute tmp & " " & chgsol(ii, 1) &#x9; else &#x9; if tmp <> "" then execute tmp & vpmtruefalse(solon+1) &#x9; end if &#x9; if usesolenoids > 1 then if nsol = vpmflips solenoid then vpmflips tiltsol solon ' msgbox solon &#x9; next &#x9;end if &#x9;if not isempty(chggi) then &#x9; for ii = 0 to ubound(chggi) &#x9; gicallback chggi(ii, 0), cbool(chggi(ii, 1)) &#x9; gicallback2 chggi(ii, 0), chggi(ii, 1) &#x9; next &#x9;end if &#x9;if not isempty(chgled) then &#x9; on error resume next &#x9; for ii = 0 to ubound(chgled) &#x9; dim color,ledstate &#x9; idx = chgled(ii, 0) &#x9; color = chgled(ii, 1) &#x9; if color = 0 then ledstate = 0 else ledstate = 1 end if &#x9; if isarray(lights(idx)) then &#x9; for each tmp in lights(idx) tmp color = color tmp state = ledstate next &#x9; else &#x9; lights(idx) color = color lights(idx) state = ledstate &#x9; end if &#x9; next &#x9; for each tmp in vpmmultilights &#x9; for ii = 1 to ubound(tmp) tmp(ii) color = tmp(0) color tmp(ii) state = tmp(0) state next &#x9; next &#x9; pdledcallback &#x9; on error goto 0 &#x9;end if &#x9;'me enabled = true 'this was supposed to be some kind of weird mutex, disable it end sub ' ' private helper functions ' private sub vpmplaysound(aenabled, asound) &#x9;if vartype(asound) = vbstring then &#x9; if aenabled then stopsound asound playsound asound &#x9;elseif asound then &#x9; if aenabled then playsound ssolenoidon else playsound ssolenoidoff &#x9;end if end sub private sub vpmtoggleobj(aobj, aenabled) &#x9;dim mswcopy &#x9;select case typename(aobj) &#x9; case "wall", "hittarget" aobj isdropped = aenabled &#x9; case "bumper", "light" aobj state = abs(aenabled) &#x9; case "kicker", "trigger", "timer" aobj enabled = aenabled &#x9; case "gate" aobj open = aenabled &#x9; case "primitive", "ramp", "rubber", "flasher" aobj visible = aenabled &#x9; case "integer" mswcopy = aobj controller switch(mswcopy) = aenabled &#x9; case else msgbox "vpmtoggleobj unhandled object " & typename(aobj) &#x9;end select end sub private function vpmcheckevent(aname, aobj) &#x9;vpmcheckevent = true &#x9;on error resume next &#x9;if not eval(aname) is aobj or err then msgbox "createevents wrong name " & aname vpmcheckevent = false end function private sub vpmbuildevent(aobj, aevent, atask) &#x9;dim obj, str &#x9;str = " " & aevent & " " & atask & " end sub" &#x9;if vpmisarray(aobj) then &#x9; for each obj in aobj executeglobal "sub " & obj name & str next &#x9;else &#x9; executeglobal "sub " & aobj name & str &#x9;end if end sub private function vpmiscollection(aobj) &#x9;vpmiscollection = typename(aobj) = "collection" or typename(aobj) = "icollection" end function private function vpmisarray(aobj) &#x9;vpmisarray = isarray(aobj) or vpmiscollection(aobj) end function private function vpmsetarray(ato, afrom) &#x9;if isarray(afrom) then &#x9; ato = afrom vpmsetarray = ubound(afrom) &#x9;elseif vpmiscollection(afrom) then &#x9; set ato = afrom vpmsetarray = afrom count 1 &#x9;else &#x9; ato = array(afrom) vpmsetarray = 0 &#x9;end if end function sub vpmcreateevents(ahitobjs) &#x9;dim obj &#x9;for each obj in ahitobjs &#x9; select case typename(obj) &#x9; case "trigger" &#x9; vpmbuildevent obj, "hit", "controller switch(" & obj timerinterval & ") = true" &#x9; vpmbuildevent obj, "unhit", "controller switch(" & obj timerinterval & ") = false" &#x9; case "wall" &#x9; if obj hashitevent then &#x9; vpmbuildevent obj, "hit", "vpmtimer pulsesw " & obj timerinterval &#x9; else &#x9; vpmbuildevent obj, "slingshot", "vpmtimer pulsesw " & obj timerinterval &#x9; end if &#x9; case "bumper", "gate", "primitive", "hittarget", "rubber" &#x9; vpmbuildevent obj, "hit", "vpmtimer pulsesw " & obj timerinterval &#x9; case "spinner" &#x9; vpmbuildevent obj, "spin", "vpmtimer pulsesw " & obj timerinterval &#x9; end select &#x9;next end sub sub vpmmaplights(alights) &#x9;dim obj, str, ii, idx &#x9;for each obj in alights &#x9; idx = obj timerinterval &#x9; if isarray(lights(idx)) then &#x9; str = "lights(" & idx & ") = array(" &#x9; for each ii in lights(idx) str = str & ii name & "," next &#x9; executeglobal str & obj name & ")" &#x9; elseif isobject(lights(idx)) then lights(idx) = array(lights(idx),obj) &#x9; else &#x9; set lights(idx) = obj &#x9; end if &#x9;next end sub function vpmmoveball(aball, afromkick, atokick) &#x9;with atokick createball &#x9; if typename(aball) = "iball" then &#x9; color = aball color image = aball image &#x9; if vpmvpver >= 60 then &#x9; frontdecal = aball frontdecal backdecal = aball backdecal ' uservalue = aball uservalue &#x9; end if &#x9; end if &#x9;end with &#x9;afromkick destroyball set vpmmoveball = atokick end function sub vpmaddball &#x9;dim answer &#x9;if isobject(vpmtrough) then &#x9; answer=msgbox("click yes to add a ball to the trough, no removes a ball from the trough",vbyesnocancel + vbquestion) &#x9; if answer = vbyes then vpmtrough addball 0 &#x9; if answer = vbno then vpmtrough balls=vpmtrough balls 1 &#x9;end if end sub ' ' generic solenoid handlers ' ' flippers sub vpmsolflipper(aflip1, aflip2, aenabled) &#x9;dim oldstrength, oldspeed ' only for pre vp10 &#x9;if aenabled then &#x9; playsound sflipperon aflip1 rotatetoend if not aflip2 is nothing then aflip2 rotatetoend &#x9;else &#x9; playsound sflipperoff if vpbuildversion < 10000 then &#x9; oldstrength = aflip1 strength aflip1 strength = conflipretstrength oldspeed = aflip1 speed aflip1 speed = conflipretspeed end if &#x9; aflip1 rotatetostart if vpbuildversion < 10000 then &#x9; aflip1 strength = oldstrength aflip1 speed = oldspeed end if &#x9; if not aflip2 is nothing then if vpbuildversion < 10000 then &#x9; oldstrength = aflip2 strength aflip2 strength = conflipretstrength oldspeed = aflip2 speed aflip2 speed = conflipretspeed end if &#x9; aflip2 rotatetostart if vpbuildversion < 10000 then &#x9; aflip2 strength = oldstrength aflip2 speed = oldspeed end if &#x9; end if &#x9;end if end sub ' flippers with speed control sub vpmsolflip2(aflip1, aflip2, aflipspeedup, aflipspeeddn, asnd, aenabled) ' deprecated, as vp10 does not feature speed on flippers anymore &#x9;dim oldstrength, oldspeed &#x9;if aenabled then &#x9; if asnd = true then playsound sflipperon end if &#x9; if not aflipspeedup = 0 then &#x9; aflip1 speed = aflipspeedup &#x9; aflip1 rotatetoend &#x9; else &#x9; aflip1 rotatetoend &#x9; end if &#x9; if not aflip2 is nothing then &#x9; if not aflipspeedup = 0 then &#x9; aflip2 speed = aflipspeedup &#x9; aflip2 rotatetoend &#x9; else &#x9; aflip2 rotatetoend &#x9; end if &#x9; end if &#x9;else &#x9; if asnd = true then playsound sflipperoff end if &#x9; oldstrength = aflip1 strength &#x9; aflip1 strength = conflipretstrength &#x9; oldspeed = aflip1 speed &#x9; if not aflipspeeddn = 0 then &#x9; aflip1 speed = aflipspeeddn &#x9; else &#x9; aflip1 speed = conflipretspeed &#x9; end if &#x9; aflip1 rotatetostart aflip1 strength = oldstrength aflip1 speed = oldspeed &#x9; if not aflip2 is nothing then &#x9; oldstrength = aflip2 strength &#x9; oldspeed = aflip2 speed &#x9; if not aflipspeeddn = 0 then &#x9; aflip2 speed = aflipspeeddn &#x9; else &#x9; aflip2 speed = conflipretspeed &#x9; end if &#x9; aflip2 strength = conflipretstrength &#x9; aflip2 rotatetostart aflip2 strength = oldstrength aflip2 speed = oldspeed &#x9; end if &#x9;end if end sub ' diverters sub vpmsoldiverter(adiv, asound, aenabled) &#x9;if aenabled then adiv rotatetoend else adiv rotatetostart &#x9;vpmplaysound aenabled, asound end sub ' walls sub vpmsolwall(awall, asound, aenabled) &#x9;dim obj &#x9;if vpmisarray(awall) then &#x9; for each obj in awall obj isdropped = aenabled next &#x9;else &#x9; awall isdropped = aenabled &#x9;end if &#x9;vpmplaysound aenabled, asound end sub sub vpmsoltogglewall(awall1, awall2, asound, aenabled) &#x9;dim obj &#x9;if vpmisarray(awall1) then &#x9; for each obj in awall1 obj isdropped = aenabled next &#x9;else &#x9; awall1 isdropped = aenabled &#x9;end if &#x9;if vpmisarray(awall2) then &#x9; for each obj in awall2 obj isdropped = not aenabled next &#x9;else &#x9; awall2 isdropped = not aenabled &#x9;end if &#x9;vpmplaysound aenabled, asound end sub ' autoplunger sub vpmsolautoplunger(aplung, avar, aenabled) &#x9;dim oldfire &#x9;if aenabled then &#x9; oldfire = aplung firespeed aplung firespeed = oldfire (100 avar (2 rnd 1))/100 &#x9; playsound ssolenoidon aplung fire aplung firespeed = oldfire &#x9;else &#x9; aplung pullback &#x9;end if end sub ' autoplunger with specified sound to play sub vpmsolautoplunges(aplung, asound, avar, aenabled) &#x9;dim oldfire &#x9;if aenabled then &#x9; oldfire = aplung firespeed aplung firespeed = oldfire (100 avar (2 rnd 1))/100 &#x9; playsound asound aplung fire aplung firespeed = oldfire &#x9;else &#x9; aplung pullback &#x9;end if end sub ' gate sub vpmsolgate(agate, asound, aenabled) &#x9;dim obj &#x9;if vpmisarray(agate) then &#x9; for each obj in agate obj open = aenabled next &#x9;else &#x9; agate open = aenabled &#x9;end if &#x9;vpmplaysound aenabled, asound end sub ' sound only sub vpmsolsound(asound, aenabled) &#x9;if aenabled then stopsound asound playsound asound end sub ' flashers sub vpmflasher(aflash, aenabled) &#x9;dim obj &#x9;if vpmisarray(aflash) then &#x9; for each obj in aflash obj state = abs(aenabled) next &#x9;else &#x9; aflash state = abs(aenabled) &#x9;end if end sub ' generic object toggle sub vpmsoltoggleobj(aobj1, aobj2, asound, aenabled) &#x9;dim obj &#x9;if vpmisarray(aobj1) then &#x9; if isarray(aobj1(0)) then &#x9; for each obj in aobj1(0) vpmtoggleobj obj, aenabled next &#x9; for each obj in aobj1(1) vpmtoggleobj obj, not aenabled next &#x9; else &#x9; for each obj in aobj1 vpmtoggleobj obj, aenabled next &#x9; end if &#x9;elseif not aobj1 is nothing then &#x9; vpmtoggleobj aobj1, aenabled &#x9;end if &#x9;if vpmisarray(aobj2) then &#x9; if isarray(aobj2(0)) then &#x9; for each obj in aobj2(0) vpmtoggleobj obj, not aenabled next &#x9; for each obj in aobj2(1) vpmtoggleobj obj, aenabled next &#x9; else &#x9; for each obj in aobj2 vpmtoggleobj obj, not aenabled next &#x9; end if &#x9;elseif not aobj2 is nothing then &#x9; vpmtoggleobj aobj2, not aenabled &#x9;end if &#x9;vpmplaysound aenabled, asound end sub ' ' stubs to allow older games to still work ' these will be removed one day ' sub solflipper(f1,f2,e) vpmsolflipper f1,f2,e end sub sub soldiverter(d,s,e) vpmsoldiverter d,s,e end sub sub solsound(s,e) vpmsolsound s,e end sub sub flasher(f,e) vpmflasher f,e end sub sub solmagnet(m,e) vpmsolmagnet m,e end sub sub solautoplunger(p,e) vpmsolautoplunger p,0,e end sub function keydownhandler(byval k) keydownhandler = vpmkeydown(k) end function function keyuphandler(byval k) keyuphandler = vpmkeyup(k) end function function keyname(byval k) keyname = vpmkeyname(k) end function sub vpmsolmagnet(m,e) m enabled = e if not e then m kick 180,1 end if end sub dim vpmballimage vpmballimage = empty ' default ball properties dim vpmballcolour ' flipper solenoids (all games) const slrflipper = 46 const sllflipper = 48 const surflipper = 34 const sulflipper = 36 ' convert keycode to readable string private keynames1, keynames2 keynames1 = array("escape","1","2","3","4","5","6","7","8","9","0","minus ' '", "equals '='","backspace","tab","q","w","e","r","t","y","u","i","o","p","\[","]", "enter","left ctrl","a","s","d","f","g","h","j","k","l",";","'","`","left shift", "\\","z","x","c","v","b","n","m",","," ","/","right shift"," ","left menu","space", "caps lock","f1","f2","f3","f4","f5","f6","f7","f8","f9","f10","numlock","scrllock", "numpad 7","numpad 8","numpad 9","numpad ","numpad 4","numpad 5","numpad 6", "numpad +","numpad 1","numpad 2","numpad 3","numpad 0","numpad ","?","?","?", "f11","f12","f13","f14","f15") keynames2 = array("pause","?","home","up","pageup","?","left","?","right","?", "end","down","pagedown","insert","delete") function vpmkeyname(byval akeycode) &#x9;if akeycode 1 <= ubound(keynames1) then &#x9; vpmkeyname = keynames1(akeycode 1) &#x9;elseif akeycode >= 197 and akeycode <= 211 then &#x9; vpmkeyname = keynames2(akeycode 197) &#x9;elseif akeycode = 184 then &#x9; vpmkeyname = "r alt" &#x9;else &#x9; vpmkeyname = "?" &#x9;end if end function private vpmsystemhelp private sub vpmshowhelp &#x9;dim szkeymsg &#x9;szkeymsg = "the following keys are defined " & vbnewline & &#x9; "(american keyboard layout)" & vbnewline & &#x9; vbnewline & "visual pinmame keys " & vbnewline & &#x9; vpmkeyname(keyshowopts) & vbtab & "game options " & vbnewline & &#x9; vpmkeyname(keyshowkeys) & vbtab & "keyboard settings " & vbnewline & &#x9; vpmkeyname(keyreset) & vbtab & "reset emulation" & vbnewline & &#x9; vpmkeyname(keyframe) & vbtab & "toggle display lock" & vbnewline & &#x9; vpmkeyname(keydoublesize) & vbtab & "toggle display size" & vbnewline &#x9;if isobject(vpmshowdips) then &#x9; szkeymsg = szkeymsg & vpmkeyname(keyshowdips) & vbtab & "show dip switch / option menu" & vbnewline &#x9; end if &#x9;if isobject(vpmtrough) then &#x9; szkeymsg = szkeymsg & vpmkeyname(keyaddball) & vbtab & "add / remove ball from table" & vbnewline &#x9;end if &#x9;szkeymsg = szkeymsg & vpmkeyname(keybangback) & vbtab & "bang back" & vbnewline & &#x9; vbnewline & vpmsystemhelp & vbnewline &#x9;if extrakeyhelp <> "" then &#x9; szkeymsg = szkeymsg & vbnewline & "game specific keys " & &#x9; vbnewline & extrakeyhelp & vbnewline &#x9;end if &#x9;szkeymsg = szkeymsg & vbnewline & "visual pinball keys " & vbnewline & &#x9; vpmkeyname(leftflipperkey) & vbtab & "left flipper" & vbnewline & &#x9; vpmkeyname(rightflipperkey) & vbtab & "right flipper" & vbnewline & &#x9; vpmkeyname(leftmagnasave) & vbtab & "left magna save" & vbnewline & &#x9; vpmkeyname(rightmagnasave) & vbtab & "right magna save" & vbnewline & &#x9; vpmkeyname(plungerkey) & vbtab & "launch ball" & vbnewline & &#x9; vpmkeyname(startgamekey) & vbtab & "start button" & vbnewline & &#x9; vpmkeyname(addcreditkey) & vbtab & "insert coin 1" & vbnewline & &#x9; vpmkeyname(addcreditkey2) & vbtab & "insert coin 2" & vbnewline & &#x9; vpmkeyname(exitgame) & vbtab & "exit game" & vbnewline & &#x9; vpmkeyname(mechanicaltilt) & vbtab & "mechanical tilt" & vbnewline & &#x9; vpmkeyname(lefttiltkey) & vbtab & "nudge from left" & vbnewline & &#x9; vpmkeyname(righttiltkey) & vbtab & "nudge from right" & vbnewline & &#x9; vpmkeyname(centertiltkey) & vbtab & "nudge forward" & vbnewline &#x9;msgbox szkeymsg,vbokonly,"keyboard settings " end sub private sub nullsub(no,enabled) 'place holder sub end sub 'added thanks to koadic sub nvoffset(version) ' version 2 for db2s compatibility &#x9;dim check,nvcheck,v,vv,nvpath,rom &#x9;set check = createobject("scripting filesystemobject") &#x9;set nvcheck = createobject("wscript shell") &#x9;nvpath = nvcheck regread("hkcu\software\freeware\visual pinmame\globals\nvram directory") & "\\" &#x9;rom = controller gamename &#x9;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) &#x9; if check fileexists(nvpath & rom & " v" & v & " txt") then vv=v exit for end if &#x9; vv=0 &#x9;next &#x9;if vv=version or version = 0 then &#x9; exit sub &#x9;elseif vv=0 then &#x9; check createtextfile nvpath & rom & " v" & version & " txt", true &#x9; exit sub &#x9;else &#x9; check movefile nvpath & rom & " v" & vv & " txt", nvpath & rom & " v" & version & " txt" &#x9; if check fileexists(nvpath & rom & " nv") then &#x9; check copyfile nvpath & rom & " nv", nvpath & rom & " v" & vv & " nv", true &#x9; end if &#x9; if check fileexists(nvpath & rom & " v" & version & " nv") then &#x9; check copyfile nvpath & rom & " v" & version & " nv", nvpath & rom & " nv", true &#x9; end if &#x9;end if end sub sub vpmvol &#x9;dim volpm,volpmnew &#x9;volpm = controller games(controller gamename) settings value("volume") &#x9;volpmnew = inputbox ("enter desired vpinmame volume level ( 32 to 0)","vpinmame volume",volpm) &#x9;if volpmnew = "" then exit sub &#x9;if volpmnew <=0 and volpmnew >= 32 then &#x9; controller games(controller gamename) settings value("volume")= round(volpmnew) &#x9; msgbox "the visual pinmame global volume is now set to " & round(volpmnew) & "db " & vbnewline & vbnewline & "please reset visual pinmame (f3) to apply " &#x9;else &#x9; 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 & " " &#x9;end if end sub ' simple min/max functions function vpmin(a, b) if a < b then vpmin = a else vpmin = b end if end function function vpmax(a, b) if a > b then vpmax = a else vpmax = b end if end function loadscript("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 loadscript("globalplugin vbs") ' checks for existance of globalplugin vbs and loads it if found, useful for adding &#x9; ' custom scripting that can be used for all tables instead of altering the core vbs