' ' #DEBUG ERROR ON ' (Don't forget to un-comment the "ON ERROR GOTO...") ' #COMPILE EXE #RESOURCE "SBS.PBR" ' ' ** Strategic Baseball Simulator v 4.9 for Windows under PB/CC 2.11 ' Copyright 1988-2008 David B. Schmidt ' ' #INCLUDE "WIN32API.INC" '========================================================================= ' Equates and declares extracted from Win32api.inc for following code file ' and all its includes: C:\PBCC21\sbs49\Basev49.bas ' Saved as: C:\PBCC21\sbs49\WinClean.inc ' ' Note: WinClean.inc can be used as direct replacement for Win32api.inc ' in above mentioned code file, but you can also copy and paste the contents ' directly into the above mentioned code file, instead of including it.. :) '----------------------------------------------------------- ' Equates: 47 '----------------------------------------------------------- %WINAPI = 1 %TRUE = 1 %FALSE = 0 %NULL = 0 %Black = &H000000??? %Gray = &H808080??? %GMEM_FIXED = &H0 %CREATE_NEW_CONSOLE = &H10 %NORMAL_PRIORITY_CLASS = &H0020 %STARTF_USESHOWWINDOW = &H00000001 %MK_SHIFT = &H4 %MK_CONTROL = &H8 %COLOR_SCROLLBAR = 0 %COLOR_BACKGROUND = 1 %COLOR_ACTIVECAPTION = 2 %COLOR_INACTIVECAPTION = 3 %COLOR_MENU = 4 %COLOR_MSGBOX = 4 %COLOR_WINDOW = 5 %COLOR_WINDOWFRAME = 6 %COLOR_MENUTEXT = 7 %COLOR_MSGBOXTEXT = 7 %COLOR_WINDOWTEXT = 8 %COLOR_CAPTIONTEXT = 9 %COLOR_ACTIVEBORDER = 10 %COLOR_INACTIVEBORDER = 11 %COLOR_APPWORKSPACE = 12 %COLOR_HIGHLIGHT = 13 %COLOR_HIGHLIGHTTEXT = 14 %COLOR_BTNFACE = 15 %COLOR_BTNSHADOW = 16 %COLOR_GRAYTEXT = 17 %COLOR_BTNTEXT = 18 %COLOR_INACTIVECAPTIONTEXT = 19 %COLOR_BTNHIGHLIGHT = 20 %COLOR_3DDKSHADOW = 21 %COLOR_3DLIGHT = 22 %COLOR_INFOTEXT = 23 %COLOR_INFOBK = 24 %IDI_APPLICATION = 32512& %IDI_HAND = 32513& %IDI_QUESTION = 32514& %IDI_EXCLAMATION = 32515& %IDI_ASTERISK = 32516& %IDI_WINLOGO = 32517& %SND_ASYNC = &H1 ' play asynchronously %SND_MEMORY = &H4 ' lpszSoundName points to a memory file '----------------------------------------------------------- ' TYPE and UNION: 5 '----------------------------------------------------------- TYPE SECURITY_ATTRIBUTES nLength AS DWORD lpSecurityDescriptor AS LONG bInheritHandle AS LONG END TYPE TYPE PROCESS_INFORMATION hProcess AS DWORD hThread AS DWORD dwProcessId AS DWORD dwThreadId AS DWORD END TYPE TYPE STARTUPINFO cb AS DWORD lpReserved AS ASCIIZ PTR lpDesktop AS ASCIIZ PTR lpTitle AS ASCIIZ PTR dwX AS DWORD dwY AS DWORD dwXSize AS DWORD dwYSize AS DWORD dwXCountChars AS DWORD dwYCountChars AS DWORD dwFillAttribute AS DWORD dwFlags AS DWORD wShowWindow AS WORD cbReserved2 AS WORD lpReserved2 AS BYTE PTR hStdInput AS LONG hStdOutput AS LONG hStdError AS LONG END TYPE TYPE SMALL_RECT xLeft AS INTEGER xTop AS INTEGER xRight AS INTEGER xBottom AS INTEGER END TYPE TYPE CONSOLE_CURSOR_INFO dwSize AS DWORD bVisible AS LONG END TYPE '----------------------------------------------------------- ' Declared Functions: 11 '----------------------------------------------------------- DECLARE FUNCTION CloseHandle LIB "KERNEL32.DLL" ALIAS "CloseHandle" (BYVAL hObject AS DWORD) AS LONG DECLARE FUNCTION CreateProcess LIB "KERNEL32.DLL" ALIAS "CreateProcessA" (lpApplicationName AS ASCIIZ, lpCommandLine AS ASCIIZ, lpProcessAttributes AS SECURITY_ATTRIBUTES, lpThreadAttributes AS SECURITY_ATTRIBUTES, _ BYVAL bInheritHandles AS LONG, BYVAL dwCreationFlags AS DWORD, lpEnvironment AS ANY, lpCurrentDirectory AS ASCIIZ, lpStartupInfo AS STARTUPINFO, lpProcessInformation AS PROCESS_INFORMATION) AS LONG DECLARE FUNCTION GetConsoleCursorInfo LIB "KERNEL32.DLL" ALIAS "GetConsoleCursorInfo" (BYVAL hConsoleOutput AS DWORD, lpConsoleCursorInfo AS CONSOLE_CURSOR_INFO) AS LONG DECLARE FUNCTION GlobalAlloc LIB "KERNEL32.DLL" ALIAS "GlobalAlloc" (BYVAL wFlags AS DWORD, BYVAL dwBytes AS DWORD) AS LONG DECLARE FUNCTION GlobalFree LIB "KERNEL32.DLL" ALIAS "GlobalFree" (BYVAL hMem AS DWORD) AS LONG DECLARE FUNCTION mciSendString LIB "WINMM.DLL" ALIAS "mciSendStringA" (lpstrCommand AS ASCIIZ, lpstrReturnString AS ASCIIZ, BYVAL uReturnLength AS DWORD, BYVAL hwndCallback AS DWORD) AS LONG DECLARE FUNCTION ReadConsoleOutput LIB "KERNEL32.DLL" ALIAS "ReadConsoleOutputA" (BYVAL hConsoleOutput AS DWORD, BYVAL lpBuffer AS DWORD, BYVAL dwBufferSize AS DWORD, BYVAL dwBufferCoord AS DWORD, lpReadRegion AS SMALL_RECT) AS LONG DECLARE FUNCTION SetConsoleCursorInfo LIB "KERNEL32.DLL" ALIAS "SetConsoleCursorInfo" (BYVAL hConsoleOutput AS DWORD, lpConsoleCursorInfo AS CONSOLE_CURSOR_INFO) AS LONG DECLARE FUNCTION SetConsoleCursorPosition LIB "KERNEL32.DLL" ALIAS "SetConsoleCursorPosition" (BYVAL hConsoleOutput AS DWORD, BYVAL dwCursorPosition AS DWORD) AS LONG DECLARE FUNCTION sndPlaySound LIB "WINMM.DLL" ALIAS "sndPlaySoundA" (lpszSoundName AS ASCIIZ, BYVAL uFlags AS DWORD) AS LONG DECLARE FUNCTION WriteConsoleOutput LIB "KERNEL32.DLL" ALIAS "WriteConsoleOutputA" (BYVAL hConsoleOutput AS DWORD, BYVAL lpBuffer AS DWORD, BYVAL dwBufferSize AS DWORD, BYVAL dwBufferCoord AS DWORD, lpWriteRegion AS SMALL_RECT) AS LONG '========================================================================= #INCLUDE "SCRNIO.INC" #INCLUDE "\CONTOOLS\CT_STD.INC" #INCLUDE "\GFXTOOLS\GfxT_Pro.INC" DECLARE SUB AddToAnnouncer(team&, x$) DECLARE SUB MyBeep DECLARE SUB Pauseit DECLARE SUB LOCATEs (row&, col&) DECLARE SUB QPRINTs (row&, col&, x$, attr&) DECLARE FUNCTION ConsoleShell (BYVAL CmdLine$, BYVAL ShowWindState&) AS LONG DECLARE FUNCTION PitcherCloneUnused (SearchName$, tm&) AS LONG DECLARE FUNCTION SearchDAT (s1&, s2&, tm&, SearchName$, posit&) AS LONG DECLARE FUNCTION DrawToRow (row&, wincols&) AS LONG DECLARE FUNCTION DrawToCol (col&, wincols&) AS LONG DECLARE FUNCTION InBox (r1&, c1&, r2&, c2&, r&, c&, b&) AS LONG DECLARE FUNCTION CalcAttr (i&, j&) AS LONG DECLARE FUNCTION CircularFcn! (x!) DECLARE FUNCTION HITRATING! (i&, j&) DECLARE FUNCTION CalcOPS! (i&, j&) DECLARE FUNCTION FoundInMMList(x$) AS LONG DECLARE FUNCTION LineSCORE$(t&) DECLARE FUNCTION Canada (x$) AS LONG DECLARE FUNCTION FRND (i&) AS LONG DECLARE FUNCTION FIRSTNAME$(x$) DECLARE FUNCTION FULLNAME$(x$) DECLARE FUNCTION LASTNAME$(x$) DECLARE FUNCTION FLASTNAME$(i&, j&) DECLARE FUNCTION FLASTNAMER$(i&, j&) DECLARE FUNCTION BUBuildLine$(j&, t&, k&) DECLARE FUNCTION FOUNDPOSITION(i&, j&, k&) AS LONG DECLARE FUNCTION MenuRoutine2$ DECLARE FUNCTION MYINPUT$ (AutoSw&, KeyEscape&, KeyCustomEsc&, KeyAccept&, kc&, fore&, back&, row&, col&, leng&, edit$, lowlim&, uplim&, default$, msx&, msy&) DECLARE FUNCTION NUMERIC(x$, j&, k&) AS LONG DECLARE FUNCTION NUMBERON AS LONG DECLARE FUNCTION PADRIGHT$(x$, i&) DECLARE FUNCTION PADLEFT$(x$, i&) DECLARE FUNCTION PADZEROS$(x$, i&) DECLARE FUNCTION WHOATGUY(i&) AS LONG DECLARE FUNCTION YesOrNo$(i&, j&, k&, l&, x$) DECLARE FUNCTION CountGamesInSCH(w$, x$, y$, z$, i&, j&, k&, l&) AS LONG DECLARE FUNCTION CountGamesInSER AS LONG DECLARE FUNCTION Subdoublequote$(x$) DECLARE FUNCTION DefaultDHResponse$ DECLARE FUNCTION ExpectedPitchCount(i&, j&) AS LONG DECLARE FUNCTION HiSaves(i&) AS LONG DECLARE FUNCTION Codesum(x$) AS LONG DECLARE FUNCTION PlayWav(WavFile$) AS LONG DECLARE FUNCTION JDATE(x$) AS LONG DECLARE FUNCTION GetDaysOff(i&, j&) AS LONG DECLARE FUNCTION DHinDAT (i&) AS LONG DECLARE FUNCTION FindRA$ (RecNum&, fp&, Reclen&, start&, leng&) DECLARE FUNCTION FFormat$(InValue!, mask$) DECLARE FUNCTION LFormat$(InValue&, mask$) DECLARE FUNCTION IFormat$(InValue%, mask$) DECLARE FUNCTION ReturnLineInTextFile$(f$, k$, start&, leng&) DECLARE FUNCTION MyRound!(InValue!, DecPts&) DECLARE FUNCTION DEFSplit!(n&, defp!, adj!) DECLARE FUNCTION DEFPCT!(i&) DECLARE FUNCTION TotalBases (Hits&, Doubles&, Triples&, HR&) AS LONG DECLARE FUNCTION RunsCreated! (TB&, Hits&, BB&, AB&) DECLARE FUNCTION RunsAllowed! (TB&, Hits&, BB&, INNINGS&, SO&) DECLARE FUNCTION BattersFacedByPit! (Innings&, Hits&, BB&, SO&) DECLARE FUNCTION LW! (Hits&, Doubles&, Triples&, HR&, BB&) DECLARE FUNCTION RunsCreated27! (AB&, Hits&, H2&, H3&, HR&, BB&, HBP&, SH&, SF&, SB&, CS&, GIDP&) DECLARE FUNCTION FindPP! '-------------------------------------------------------- ' DECLARE FUNCTION MSGBOX(sText$, lStyle&, sTitle$) AS LONG TYPE MType 'Messages mgs AS STRING * 50 END TYPE TYPE PbyPType class AS STRING * 2 pos AS STRING * 1 seq AS STRING * 1 trk AS STRING * 2 pndx AS STRING * 3 text AS STRING * 71 END TYPE TYPE PbyP_OVL PbyP_Rec AS STRING * 80 END TYPE TYPE MMType 'Manual manager list MMFile AS STRING * 8 END TYPE TYPE ArgType 'Argument list Arg AS STRING * 25 END TYPE TYPE WLType 'Simulation Summary WLTeam AS STRING * 12 WLWins AS LONG WLLoss AS LONG WLLeague AS STRING * 1 WLDiv AS STRING * 1 WLPct AS STRING * 4 END TYPE TYPE HiLiteType HLGameNo AS LONG HLMessage AS STRING * 40 END TYPE TYPE ScoreCardType SCInn AS INTEGER SCTeam AS INTEGER SCRef AS INTEGER SCCode AS STRING * 1 SCResult AS STRING * 30 'was 10 SCBase1 AS STRING * 2 SCBase2 AS STRING * 2 SCBase3 AS STRING * 2 SCBase4 AS STRING * 2 END TYPE TYPE List1Type 'Input to sorting routines ListItem AS STRING * 120 'was 35/50 END TYPE TYPE PlyListType 'Input to sorting routines Item AS STRING * 80 Ref AS INTEGER END TYPE TYPE PosPoolType PSlot AS INTEGER PABbyPos AS SINGLE PPct AS SINGLE PRepl AS INTEGER END TYPE TYPE RotType RotTeam AS STRING * 12 RotMeth AS STRING * 2 RotSpot AS STRING * 1 RotIndex AS INTEGER RotList(5) AS INTEGER END TYPE TYPE RefOrgType RefNo AS INTEGER RefPos AS INTEGER END TYPE TYPE RankType Criteria AS STRING * 4 Slot AS INTEGER END TYPE TYPE PHType Criteria1 AS STRING * 4 Criteria2 AS STRING * 4 Slot AS INTEGER END TYPE TYPE TotPctType PctOfTot AS SINGLE Slot AS INTEGER END TYPE TYPE StatSummary VLeague AS STRING * 1 VDiv AS STRING * 1 VNam AS STRING * 12 VRuns AS LONG VHits AS LONG VErrs AS LONG VLOB AS LONG VDPs AS LONG HLeague AS STRING * 1 HDiv AS STRING * 1 HNam AS STRING * 12 HRuns AS LONG HHits AS LONG HErrs AS LONG HLOB AS LONG HDPs AS LONG WP AS STRING * 14 LP AS STRING * 14 SP AS STRING * 14 SumFil AS STRING * 2 END TYPE TYPE BatSummary BLeague AS STRING * 1 BTmNam AS STRING * 12 BNam AS STRING * 16 BBats AS STRING * 1 BGameCtr AS LONG BGames AS LONG BABs AS LONG BABsRHP AS LONG BABsLHP AS LONG BRuns AS LONG BHits AS LONG BHitsRHP AS LONG BHitsLHP AS LONG BRBIs AS LONG B2Bs AS LONG B2BsRHP AS LONG B2BsLHP AS LONG B3Bs AS LONG B3BsRHP AS LONG B3BsLHP AS LONG BHRs AS LONG BHRsRHP AS LONG BHRsLHP AS LONG BSBs AS LONG BCSs AS LONG BBBs AS LONG BBBsRHP AS LONG BBBsLHP AS LONG BHB AS LONG BKs AS LONG BKsRHP AS LONG BKsLHP AS LONG BErrs AS LONG BStreak AS LONG BGDP AS LONG BSacB AS LONG BSacF AS LONG END TYPE TYPE BatSummaryOVL BatSummaryRec AS STRING * 162 END TYPE TYPE PitSummary PLeague AS STRING * 1 PTmNam AS STRING * 12 PNam AS STRING * 16 PThrows AS STRING * 1 PGameCtr AS LONG PGames AS LONG PStarts AS LONG PCGs AS LONG PShOs AS LONG PInns AS LONG P3rds AS LONG PRuns AS LONG PERuns AS LONG PHits AS LONG P2Bs AS LONG P3Bs AS LONG PHRs AS LONG PBBs AS LONG PHB AS LONG PSOs AS LONG PWin AS LONG PLoss AS LONG PSave AS LONG PBS AS LONG PBF AS LONG PDaysOff AS LONG PJDate AS LONG PStreak AS LONG END TYPE TYPE PitSummaryOVL PitSummaryRec AS STRING * 126 END TYPE TYPE FldSummary FLeague AS STRING * 1 FTmNam AS STRING * 12 FNam AS STRING * 16 FThrows AS STRING * 1 FCount AS LONG FGamesByPos (1 TO 12) AS LONG ' 11=PH 12=PR FErrsByPos (1 TO 10) AS LONG FPutOutsByPos(1 TO 10) AS LONG FAssistsByPos(1 TO 10) AS LONG END TYPE TYPE FldSummaryOVL FldSummaryRec AS STRING * 202 END TYPE TYPE RestartType ResSCHName AS STRING * 12 ResSCHDate AS STRING * 8 ResSCHSlotPtr AS INTEGER ResSlotGameCtr AS INTEGER ResSlotGames AS INTEGER ResSimGameCtr AS LONG END TYPE TYPE VirtualWinType item AS STRING * 140 END TYPE TYPE LAvgType 'Stores League Averages for each YYYYL - Not GLOBAL LAvgYr AS STRING * 4 LAvgLg AS STRING * 1 LAvgBB AS SINGLE LAvgSO AS SINGLE LAvgS2 AS SINGLE LAvg1B AS SINGLE LAvg2B AS SINGLE LAvg3B AS SINGLE LAvgHR AS SINGLE LAvgRG AS SINGLE LTeams AS INTEGER Innings AS LONG Hits AS LONG Doubles AS INTEGER Triples AS INTEGER HR AS INTEGER BB AS INTEGER Rating AS INTEGER END TYPE TYPE BufType 'For File-Listing Sub BufferItem AS STRING * 210 END TYPE TYPE ScrType ScrLine AS STRING * 18 END TYPE TYPE PosiType ScrLine AS STRING * 1 END TYPE TYPE PitTblType ScrLine AS STRING * 39 END TYPE TYPE STSAnal ALeague AS STRING * 1 ADiv AS STRING * 1 APct AS STRING * 4 ANam AS STRING * 12 AWins AS LONG ALosses AS LONG AHomWins AS LONG AHomLosses AS LONG AHRunsS AS LONG AHRunsA AS LONG AVisWins AS LONG AVisLosses AS LONG AVRunsS AS LONG AVRunsA AS LONG ARuns AS LONG AOppRuns AS LONG AHits AS LONG AErrs AS LONG ALOB AS LONG ADP AS LONG END TYPE TYPE SortStrType SSItem AS STRING * 29 END TYPE TYPE BoxType row1 AS LONG col1 AS LONG row2 AS LONG col2 AS LONG END TYPE TYPE ScheduleLineType Visitor AS STRING * 8 Home AS STRING * 8 Options AS STRING * 12 END TYPE TYPE ScheduleType Header AS STRING * 2 SDate AS STRING * 8 Slot(15) AS ScheduleLineType END TYPE 'GLOBAL ARRAYS 'GLOBAL TYPED ARRAYS: GLOBAL Announcer() AS MType GLOBAL MMList() AS MMType GLOBAL WLRec() AS WLType GLOBAL HLRec() AS HiLiteType GLOBAL SCRec() AS ScoreCardType GLOBAL RefOrg() AS RefOrgType GLOBAL RefOrgSave() AS RefOrgType GLOBAL RotRec() AS RotType GLOBAL VirtualWin() AS VirtualWinType GLOBAL SSum AS StatSummary GLOBAL BSum() AS BatSummary GLOBAL PSum() AS PitSummary GLOBAL FSum() AS FldSummary GLOBAL ArgList() AS ArgType GLOBAL RestartRec AS RestartType GLOBAL PbyP() AS PbyPType 'GLOBAL STRING ARRAYS: GLOBAL DataName() AS STRING GLOBAL DataPlat() AS STRING GLOBAL DataHand() AS STRING GLOBAL DataCode() AS STRING GLOBAL DataHP() AS STRING GLOBAL NameRef() AS STRING GLOBAL HandRef() AS STRING GLOBAL RefByBO() AS STRING GLOBAL Century() AS STRING GLOBAL Names() AS STRING GLOBAL League() AS STRING GLOBAL TeamLogo() AS STRING GLOBAL Year() AS STRING GLOBAL Div() AS STRING GLOBAL POS() AS STRING GLOBAL PosDesc() AS STRING GLOBAL GMMessage() AS STRING GLOBAL ActiveSTAT() AS STRING GLOBAL DataFil() AS STRING GLOBAL DATPath() AS STRING GLOBAL WildPit() AS STRING GLOBAL PassedB() AS STRING GLOBAL HitByPit() AS STRING GLOBAL AdjustBO() AS STRING * 1 'GLOBAL LONG INTEGER ARRAYS: GLOBAL DataGByP() AS LONG GLOBAL DataPosi() AS LONG GLOBAL SimGames() AS LONG GLOBAL SimAB() AS LONG GLOBAL SimHits() AS LONG GLOBAL SimHR() AS LONG GLOBAL SimRBI() AS LONG GLOBAL SimBStreak() AS LONG GLOBAL SimBB() AS LONG GLOBAL SimSO() AS LONG GLOBAL SimHitsAlw() AS LONG GLOBAL SimERuns() AS LONG GLOBAL SimWins() AS LONG GLOBAL SimLosses() AS LONG GLOBAL SimSaves() AS LONG GLOBAL SimBBAlw() AS LONG GLOBAL SimSO_P() AS LONG GLOBAL SimDaysOff() AS LONG GLOBAL WarmUpStatus() AS LONG GLOBAL mpo() AS LONG GLOBAL mpk() AS LONG GLOBAL mph() AS LONG GLOBAL mpw() AS LONG GLOBAL mpr() AS LONG GLOBAL mpbf() AS LONG GLOBAL mper() AS LONG GLOBAL mp2b() AS LONG GLOBAL mp3b() AS LONG GLOBAL mphr() AS LONG GLOBAL mphb() AS LONG GLOBAL mpBS() AS LONG GLOBAL DataRef() AS LONG GLOBAL DataPos() AS LONG GLOBAL DataAB() AS LONG GLOBAL DataHits() AS LONG GLOBAL Data2B() AS LONG GLOBAL Data3B() AS LONG GLOBAL DataHR() AS LONG GLOBAL DataBB() AS LONG GLOBAL DataSO() AS LONG GLOBAL DataRBI() AS LONG GLOBAL DataSB() AS LONG GLOBAL DataCS() AS LONG GLOBAL DataDef() AS LONG GLOBAL DataSpeed() AS LONG GLOBAL DataGames() AS LONG GLOBAL DataPBatAB() AS LONG GLOBAL DataPBatHi() AS LONG GLOBAL DataPBatHR() AS LONG GLOBAL DataPBatBB() AS LONG GLOBAL DataPBatSO() AS LONG GLOBAL iused() AS LONG GLOBAL OrgPos() AS LONG GLOBAL mab() AS LONG GLOBAL mabRHP() AS LONG GLOBAL mabLHP() AS LONG GLOBAL mruns() AS LONG GLOBAL mhits() AS LONG GLOBAL mhitsRHP() AS LONG GLOBAL mhitsLHP() AS LONG GLOBAL mrbi() AS LONG GLOBAL mhr() AS LONG GLOBAL mhrRHP() AS LONG GLOBAL mhrLHP() AS LONG GLOBAL m3b() AS LONG GLOBAL m3bRHP() AS LONG GLOBAL m3bLHP() AS LONG GLOBAL m2b() AS LONG GLOBAL m2bRHP() AS LONG GLOBAL m2bLHP() AS LONG GLOBAL mbb() AS LONG GLOBAL mbbRHP() AS LONG GLOBAL mbbLHP() AS LONG GLOBAL mhb() AS LONG GLOBAL merr() AS LONG GLOBAL mso() AS LONG GLOBAL msoRHP() AS LONG GLOBAL msoLHP() AS LONG GLOBAL msb() AS LONG GLOBAL mcs() AS LONG GLOBAL mGDP() AS LONG GLOBAL mSacF() AS LONG GLOBAL mSacB() AS LONG GLOBAL iScoreBd() AS LONG GLOBAL iScore() AS LONG GLOBAL itruns() AS LONG GLOBAL ithits() AS LONG GLOBAL iterrs() AS LONG GLOBAL GameLOB() AS LONG GLOBAL ipa() AS LONG GLOBAL np() AS LONG GLOBAL iyp() AS LONG GLOBAL LastPiAd() AS LONG GLOBAL amgr() AS LONG GLOBAL ibp() AS LONG GLOBAL dp() AS LONG GLOBAL mpp() AS LONG GLOBAL SoundQ() AS LONG GLOBAL AutoLineUpSw() AS LONG GLOBAL DHDATOvr() AS LONG GLOBAL Gender() AS LONG GLOBAL TeamAttr() AS LONG GLOBAL ERRSw() AS LONG GLOBAL StBSw() AS LONG GLOBAL NewStyle() AS LONG GLOBAL NewStyleWithSaves() AS LONG GLOBAL CloserIn() AS LONG GLOBAL PitcherBatted() AS LONG GLOBAL SumErrors() AS LONG GLOBAL SumAssists() AS LONG GLOBAL SumPutOuts() AS LONG GLOBAL pHRind() AS LONG GLOBAL HoleStatus() AS LONG GLOBAL BasPatRow() AS LONG GLOBAL BasPatCol() AS LONG GLOBAL DupNameTeam() AS LONG GLOBAL DLN() AS LONG GLOBAL LeagueRating() AS LONG GLOBAL StealAttemptsPlayer() AS LONG GLOBAL StealAttemptsTeam() AS LONG GLOBAL RemoveReason() AS LONG 'GLOBAL FLOAT ARRAYS: GLOBAL SimInn() AS SINGLE GLOBAL PitchersPerGame() AS SINGLE GLOBAL DefChancesPerGameF() AS SINGLE GLOBAL TeamSpeed() AS SINGLE GLOBAL NormDEF() AS SINGLE GLOBAL pwbaseF() AS SINGLE GLOBAL pkbaseF() AS SINGLE GLOBAL psbaseF() AS SINGLE GLOBAL p1baseF() AS SINGLE GLOBAL p2baseF() AS SINGLE GLOBAL p3baseF() AS SINGLE GLOBAL p4baseF() AS SINGLE GLOBAL phit1bF() AS SINGLE GLOBAL phit2bF() AS SINGLE GLOBAL phit3bF() AS SINGLE GLOBAL phit4bF() AS SINGLE GLOBAL RunsPerGame() AS SINGLE GLOBAL LgTotInns() AS LONG GLOBAL LgTotHits() AS LONG GLOBAL LgTot2B() AS LONG GLOBAL LgTot3B() AS LONG GLOBAL LgTotHR() AS LONG GLOBAL LgTotBB() AS LONG GLOBAL nPitch() AS LONG GLOBAL P32() AS LONG GLOBAL P33() AS LONG GLOBAL P48() AS LONG GLOBAL P52() AS LONG GLOBAL FatRnd() AS SINGLE GLOBAL ParkBatAdj() AS SINGLE GLOBAL ParkPitAdj() AS SINGLE ' 'GLOBAL BYTE ARRAYS: GLOBAL GpPos() AS BYTE GLOBAL PutOuts() AS BYTE GLOBAL Assists() AS BYTE ' ' --------- GLOBAL VARIABLES ' 'GLOBAL LONG INTEGERS: GLOBAL SimGameCtr AS LONG GLOBAL SCx AS LONG GLOBAL HLx AS LONG GLOBAL GMx AS LONG GLOBAL ANx AS LONG GLOBAL MMx AS LONG GLOBAL RTx AS LONG GLOBAL WLx AS LONG GLOBAL SQx AS LONG GLOBAL STx AS LONG GLOBAL WhoAtPos AS LONG GLOBAL OrgWhoAtPos AS LONG GLOBAL ir1 AS LONG GLOBAL ir2 AS LONG GLOBAL ir3 AS LONG GLOBAL iout AS LONG GLOBAL iwin AS LONG GLOBAL dh AS LONG GLOBAL RunAnnounced AS LONG GLOBAL HitType AS LONG GLOBAL ForceSBAlways AS LONG GLOBAL WPteam AS LONG GLOBAL WPpit AS LONG GLOBAL LPteam AS LONG GLOBAL LPpit AS LONG GLOBAL SPteam AS LONG GLOBAL SPpit AS LONG GLOBAL ib AS LONG GLOBAL ip AS LONG GLOBAL it AS LONG GLOBAL id AS LONG GLOBAL inn AS LONG GLOBAL ref AS LONG GLOBAL ref2 AS LONG GLOBAL innct AS LONG GLOBAL innr AS LONG GLOBAL innh AS LONG GLOBAL inne AS LONG GLOBAL innadverr AS LONG GLOBAL innLOB AS LONG GLOBAL ThrowError AS LONG GLOBAL OneBaseError AS LONG GLOBAL InfieldHit AS LONG GLOBAL ResetHitter AS LONG GLOBAL Tight AS LONG GLOBAL Errorx AS LONG GLOBAL BullD AS LONG GLOBAL BullO AS LONG GLOBAL Bunt AS LONG GLOBAL Boxx AS LONG GLOBAL HitAndRun AS LONG GLOBAL IGone AS LONG GLOBAL PH AS LONG GLOBAL Subx AS LONG GLOBAL Steal AS LONG GLOBAL IWalk AS LONG GLOBAL POut AS LONG GLOBAL BatPOut AS LONG GLOBAL PAround AS LONG GLOBAL ViewHome AS LONG GLOBAL ViewVisi AS LONG GLOBAL SwPos AS LONG GLOBAL PRun AS LONG GLOBAL HotBull AS LONG GLOBAL deffor AS LONG GLOBAL defbac AS LONG GLOBAL revfor AS LONG GLOBAL revbac AS LONG GLOBAL fldfor AS LONG GLOBAL fldbac AS LONG GLOBAL labfor AS LONG GLOBAL labbac AS LONG GLOBAL drtfor AS LONG GLOBAL drtbac AS LONG GLOBAL prmfor AS LONG GLOBAL prmbac AS LONG GLOBAL scofor AS LONG GLOBAL scobac AS LONG GLOBAL scdfor AS LONG GLOBAL scdbac AS LONG GLOBAL dimfor AS LONG GLOBAL dimbac AS LONG GLOBAL defattr AS LONG GLOBAL revattr AS LONG GLOBAL fldattr AS LONG GLOBAL drtattr AS LONG GLOBAL prmattr AS LONG GLOBAL errattr AS LONG GLOBAL linattr AS LONG GLOBAL labattr AS LONG GLOBAL scoattr AS LONG GLOBAL scdattr AS LONG GLOBAL drkattr AS LONG GLOBAL dimattr AS LONG GLOBAL skipattr AS LONG GLOBAL VisiPtr AS LONG GLOBAL HomePtr AS LONG GLOBAL VisiReady AS LONG GLOBAL HomeReady AS LONG GLOBAL DelFac AS LONG GLOBAL OrgSimDelFac AS LONG GLOBAL SoundOn AS LONG GLOBAL LPTNum AS LONG GLOBAL RegInns AS LONG GLOBAL fr2 AS LONG GLOBAL fr3 AS LONG GLOBAL fr4 AS LONG GLOBAL fr5 AS LONG GLOBAL fr6 AS LONG GLOBAL fr7 AS LONG GLOBAL STATTEAMLIMIT AS LONG GLOBAL TRUE AS LONG GLOBAL FALSE AS LONG GLOBAL KeyEsc AS LONG GLOBAL KeyF2 AS LONG GLOBAL KeyF3 AS LONG GLOBAL KeyF4 AS LONG GLOBAL SelX AS LONG GLOBAL OutfErr AS LONG GLOBAL NewUI AS LONG GLOBAL QualSave1IP AS LONG GLOBAL QualSave1ID AS LONG GLOBAL QualSave2IP AS LONG GLOBAL QualSave2ID AS LONG GLOBAL DPsw AS LONG GLOBAL SimAtBats AS LONG GLOBAL SimTotHits AS LONG GLOBAL SimTotHRs AS LONG GLOBAL StrictCloserRule AS LONG GLOBAL GameRnd AS LONG GLOBAL DaysOffRule AS LONG GLOBAL WarmUpRule AS LONG GLOBAL RunsBeforePlay AS LONG GLOBAL SchedSw AS LONG GLOBAL SeriesSw AS LONG GLOBAL CmdDel AS LONG GLOBAL CmdDelIsOnCommandLine AS LONG GLOBAL CmdSlotGames AS LONG GLOBAL SCHSlotPtr AS LONG GLOBAL SCHGamesPerRecord AS LONG GLOBAL ProtectSCH AS LONG GLOBAL SlotGameCtr AS LONG GLOBAL LastGameThisDate AS LONG GLOBAL FilterOK AS LONG GLOBAL SubRecLen AS LONG GLOBAL SubRecOff AS LONG GLOBAL VisiOffset AS LONG GLOBAL HomeOffset AS LONG GLOBAL OptiOffset AS LONG GLOBAL zz0 AS LONG GLOBAL zz1 AS LONG GLOBAL zz2 AS LONG GLOBAL zz3 AS LONG GLOBAL zz4 AS LONG GLOBAL zz5 AS LONG GLOBAL zz6 AS LONG GLOBAL zzzsb AS LONG GLOBAL zzzcs AS LONG GLOBAL zzzcer AS LONG GLOBAL zzzdp AS LONG GLOBAL zzzprun AS LONG GLOBAL zzzDSW AS LONG GLOBAL zzsacok AS LONG GLOBAL zzsacfa AS LONG GLOBAL zzzSumR AS SINGLE GLOBAL zzzSumN AS LONG GLOBAL zzzPO AS LONG GLOBAL zzzNoPO AS LONG GLOBAL zzzWalkAdj AS LONG GLOBAL zzzNoWalkAdj AS LONG GLOBAL zzziwalk1 AS LONG GLOBAL zzziwalk2 AS LONG GLOBAL zzziwalk3 AS LONG GLOBAL zzzph AS LONG GLOBAL zzsabp AS LONG GLOBAL zzssbp AS LONG GLOBAL GameIsOver AS LONG GLOBAL RegDsply AS LONG GLOBAL PbyP_Cnt AS LONG GLOBAL AutoCoach AS LONG GLOBAL AutoDefense AS LONG GLOBAL ColorScheme AS LONG GLOBAL BatterOveruse AS LONG GLOBAL InsideThePark AS LONG GLOBAL ConsRows AS LONG GLOBAL ConsCols AS LONG GLOBAL MidCol AS LONG GLOBAL MidRow AS LONG GLOBAL ColO AS LONG GLOBAL RowO AS LONG GLOBAL ObsD AS LONG GLOBAL ObsY AS LONG GLOBAL ObsH AS LONG GLOBAL ObsTz AS LONG GLOBAL ObsTy AS LONG GLOBAL Gfx AS LONG GLOBAL TopPitLim AS LONG GLOBAL ThreadNo AS LONG GLOBAL AllowStartersInRelief AS LONG GLOBAL TakeFromAnywhere AS INTEGER 'GLOBAL STRINGS: GLOBAL mon$ GLOBAL Result$ GLOBAL Result2$ GLOBAL Code2$ GLOBAL nulls$ GLOBAL ARROWS$ GLOBAL EditorSpec$ GLOBAL WordPadSpec$ GLOBAL AuxSpec$ GLOBAL CmdStat$ GLOBAL CmdLinF$ GLOBAL CmdBoxF$ GLOBAL CmdScrF$ GLOBAL CmdStar$ GLOBAL CmdVFil$ GLOBAL CmdHFil$ GLOBAL CmdWritePath$ GLOBAL CmdPath$ GLOBAL CmdSCH$ GLOBAL CmdSER$ GLOBAL CmdVP$ GLOBAL CmdHP$ GLOBAL CmdSP$ GLOBAL CmdSpot$ GLOBAL CmdVSpot$ GLOBAL CmdHSpot$ GLOBAL CmdVAutoMgr$ GLOBAL CmdHAutoMgr$ GLOBAL CmdAutoLU$ GLOBAL CmdVAutoLU$ GLOBAL CmdHAutoLU$ GLOBAL CmdAdjustBO$ GLOBAL CmdVAdjustBO$ GLOBAL CmdHAdjustBO$ GLOBAL CmdFavTeam$ GLOBAL CmdFavLeague$ GLOBAL CmdDateL$ GLOBAL CmdDateH$ GLOBAL CmdFocus$ GLOBAL CmdDeBug$ GLOBAL CmdPauseAftGame$ GLOBAL CmdPauseAftDate$ GLOBAL CmdERA$ GLOBAL CmdCmdFile$ GLOBAL CmdVM$ GLOBAL CmdHM$ GLOBAL CmdSound$ GLOBAL CmdDH$ GLOBAL CmdNoOpt$ GLOBAL CmdPic$ GLOBAL CmdFireworks$ GLOBAL CmdParkEffects$ GLOBAL CmdHomeFieldAdv$ GLOBAL CmdChangePhoto$ GLOBAL CmdHRWav$ GLOBAL CmdAutoExit$ GLOBAL BackGroundPic$ GLOBAL CurrentDir$ GLOBAL SCHDate$ GLOBAL SchBuffer$ GLOBAL MenuOpt$ GLOBAL CloseButton$ GLOBAL AbortButton$ GLOBAL LPtr$ GLOBAL RPtr$ GLOBAL UpPtr$ GLOBAL DnPtr$ GLOBAL xUpPtr$ GLOBAL xDnPtr$ GLOBAL xLPtr$ GLOBAL xRPtr$ GLOBAL EnterPtr$ 'GLOBAL FLOATS: GLOBAL p4baseNorm! GLOBAL p3baseNorm! GLOBAL p2baseNorm! GLOBAL p1baseNorm! GLOBAL pwbaseNorm! GLOBAL prbaseNorm! 'Constants: GLOBAL MAXPLAYERS AS LONG DEFLNG A-Z '************************************************************ 'FUNCTION PBMAIN() AS LONG FUNCTION WINMAIN(BYVAL hCurInstance AS LONG, _ BYVAL hPrevInstance AS LONG, _ lpszCmdLine AS ASCIIZ PTR, _ BYVAL nCmdShow AS LONG) _ EXPORT AS LONG ' ON ERROR GOTO PBM_ErrorTrap REGISTER i AS INTEGER ' GLOBAL: DIM Announcer(12) AS GLOBAL MType DIM HLRec(400) AS GLOBAL HiLiteType '150 DIM SCRec(300) AS GLOBAL ScoreCardType DIM WLRec(1 TO 300) AS GLOBAL WLType DIM DataName(51, 2) AS GLOBAL STRING DIM DataPlat(51, 2) AS GLOBAL STRING DIM DataHand(51, 2) AS GLOBAL STRING DIM DataCode(51, 2) AS GLOBAL STRING DIM DataHP (51, 2) AS GLOBAL STRING DIM NameRef(51, 2) AS GLOBAL STRING DIM HandRef(51, 2) AS GLOBAL STRING DIM RefByBO(9, 2) AS GLOBAL STRING DIM Century(2) AS GLOBAL STRING DIM Names(2) AS GLOBAL STRING DIM League(2) AS GLOBAL STRING DIM TeamLogo(2) AS GLOBAL STRING DIM Year(2) AS GLOBAL STRING DIM Div(2) AS GLOBAL STRING DIM POS(11) AS GLOBAL STRING DIM PosDesc(10) AS GLOBAL STRING DIM GMMessage(5) AS GLOBAL STRING DIM ActiveSTAT(10) AS GLOBAL STRING DIM DataFil(2) AS GLOBAL STRING DIM DATPath(2) AS GLOBAL STRING DIM WildPit(2) AS GLOBAL STRING DIM PassedB(2) AS GLOBAL STRING DIM HitByPit(2) AS GLOBAL STRING DIM AdjustBO(2) AS GLOBAL STRING * 1 DIM DataRef(51, 2) AS GLOBAL LONG DIM DataPos(51, 2) AS GLOBAL LONG DIM DataAB(51, 2) AS GLOBAL LONG DIM DataHits(51, 2) AS GLOBAL LONG DIM Data2B(51, 2) AS GLOBAL LONG DIM Data3B(51, 2) AS GLOBAL LONG DIM DataHR(51, 2) AS GLOBAL LONG DIM DataBB(51, 2) AS GLOBAL LONG DIM DataSO(51, 2) AS GLOBAL LONG DIM DataRBI(51, 2) AS GLOBAL LONG DIM DataSB(51, 2) AS GLOBAL LONG DIM DataCS(51, 2) AS GLOBAL LONG DIM DataDef(51, 2) AS GLOBAL LONG DIM DataSpeed(51, 2) AS GLOBAL LONG DIM DataGames(51, 2) AS GLOBAL LONG DIM iused(51, 2) AS GLOBAL LONG DIM OrgPos(51, 2) AS GLOBAL LONG DIM mab(51, 2) AS GLOBAL LONG DIM mabRHP(51, 2) AS GLOBAL LONG DIM mabLHP(51, 2) AS GLOBAL LONG DIM mruns(51, 2) AS GLOBAL LONG DIM mhits(51, 2) AS GLOBAL LONG DIM mhitsRHP(51, 2) AS GLOBAL LONG DIM mhitsLHP(51, 2) AS GLOBAL LONG DIM mrbi(51, 2) AS GLOBAL LONG DIM mhr(51, 2) AS GLOBAL LONG DIM mhrRHP(51, 2) AS GLOBAL LONG DIM mhrLHP(51, 2) AS GLOBAL LONG DIM m3b(51, 2) AS GLOBAL LONG DIM m3bRHP(51, 2) AS GLOBAL LONG DIM m3bLHP(51, 2) AS GLOBAL LONG DIM m2b(51, 2) AS GLOBAL LONG DIM m2bRHP(51, 2) AS GLOBAL LONG DIM m2bLHP(51, 2) AS GLOBAL LONG DIM mbb(51, 2) AS GLOBAL LONG DIM mbbRHP(51, 2) AS GLOBAL LONG DIM mbbLHP(51, 2) AS GLOBAL LONG DIM mhb(51, 2) AS GLOBAL LONG DIM merr(51, 2) AS GLOBAL LONG DIM mso(51, 2) AS GLOBAL LONG DIM msoRHP(51, 2) AS GLOBAL LONG DIM msoLHP(51, 2) AS GLOBAL LONG DIM msb(51, 2) AS GLOBAL LONG DIM mcs(51, 2) AS GLOBAL LONG DIM mSacF(51, 2) AS GLOBAL LONG DIM mSacB(51, 2) AS GLOBAL LONG DIM mGDP(51, 2) AS GLOBAL LONG DIM StealAttemptsPlayer(51, 2) AS GLOBAL LONG DIM iScoreBd(2, 10) AS GLOBAL LONG DIM iScore(2, 30) AS GLOBAL LONG DIM itruns(2) AS GLOBAL LONG DIM ithits(2) AS GLOBAL LONG DIM iterrs(2) AS GLOBAL LONG DIM GameLOB(2) AS GLOBAL LONG DIM ipa(2) AS GLOBAL LONG DIM np(2) AS GLOBAL LONG DIM iyp(15, 2) AS GLOBAL LONG DIM LastPiAd(2) AS GLOBAL LONG DIM amgr(2) AS GLOBAL LONG DIM ibp(2) AS GLOBAL LONG DIM dp(2) AS GLOBAL LONG DIM mpp(9) AS GLOBAL LONG DIM SoundQ(10) AS GLOBAL LONG DIM AutoLineUpSw(2) AS GLOBAL LONG DIM HoleStatus(32) AS GLOBAL LONG DIM BasPatRow(5) AS GLOBAL LONG DIM BasPatCol(5) AS GLOBAL LONG DIM ERRSw(2) AS GLOBAL LONG DIM StBSw(2) AS GLOBAL LONG DIM NewStyle(2) AS GLOBAL LONG DIM NewStyleWithSaves(2) AS GLOBAL LONG DIM CloserIn(2) AS GLOBAL LONG DIM PitcherBatted(2) AS GLOBAL LONG DIM DHDATOvr(2) AS GLOBAL LONG DIM Gender(2) AS GLOBAL LONG DIM TeamAttr(2) AS GLOBAL LONG DIM StealAttemptsTeam(2) AS GLOBAL LONG DIM SumErrors(10) AS GLOBAL LONG DIM SumAssists(10) AS GLOBAL LONG DIM SumPutouts(10) AS GLOBAL LONG DIM pHRind(2) AS GLOBAL LONG DIM DupNameTeam(2) AS GLOBAL LONG DIM LeagueRating(2) AS GLOBAL LONG DIM LgTotInns(3) AS GLOBAL LONG DIM LgTotHits(3) AS GLOBAL LONG DIM LgTot2B(3) AS GLOBAL LONG DIM LgTot3B(3) AS GLOBAL LONG DIM LgTotHR(3) AS GLOBAL LONG DIM LgTotBB(3) AS GLOBAL LONG DIM P32(10) AS GLOBAL LONG DIM P33(10) AS GLOBAL LONG DIM P48(10) AS GLOBAL LONG DIM P52(10) AS GLOBAL LONG DIM RemoveReason(10) AS GLOBAL LONG DIM PitchersPerGame(2) AS GLOBAL SINGLE DIM DefChancesPerGameF(10) AS GLOBAL SINGLE DIM TeamSpeed(2) AS GLOBAL SINGLE DIM NormDEF(10) AS GLOBAL SINGLE DIM pwbaseF(2) AS GLOBAL SINGLE DIM pkbaseF(2) AS GLOBAL SINGLE DIM psbaseF(2) AS GLOBAL SINGLE DIM p1baseF(2) AS GLOBAL SINGLE DIM p2baseF(2) AS GLOBAL SINGLE DIM p3baseF(2) AS GLOBAL SINGLE DIM p4baseF(2) AS GLOBAL SINGLE DIM phit1bF(2) AS GLOBAL SINGLE DIM phit2bF(2) AS GLOBAL SINGLE DIM phit3bF(2) AS GLOBAL SINGLE DIM phit4bF(2) AS GLOBAL SINGLE DIM RunsPerGame(3) AS GLOBAL SINGLE DIM FatRnd(3) AS GLOBAL SINGLE ' LOCAL: REDIM LAvg(300) AS LAvgType DIM Flen(13) DIM Flitrow(13) DIM Flitcol(13) DIM Flit$(13) DIM Frow(13) DIM Fcol(13) DIM Fed$(13) DIM FContents$(13) DIM ColorDescTable$(15) DIM LUAltered(2) DIM TeamsInLeague(2) DIM PlayUSA AS ASCIIZ * 40 DIM PlayCAN AS ASCIIZ * 40 DIM StopUSA AS ASCIIZ * 40 DIM StopCAN AS ASCIIZ * 40 DIM HBF!(2) DIM HPF!(2) ' =============================================== 'First executable line ConsoleToolsAuthorize &h00000000 'Your Console Tools serial number InitConsoleTools hCurInstance, 0, 0, 3, 0, 0 GraphicsToolsAuthorize &h00000000 'Your Graphics Tools serial number ConsoleWindow %HIDE PAGE 1, 1 CURSOR OFF RANDOMIZE TIMER 'Set default screen size depending on Windows version winver = 0 ConsRows = 25 ConsCols = 80 j = WindowsVersion(%WIN_MAJORVERSION) k = WindowsVersion(%WIN_MINORVERSION) IF j = 4 AND k = 0 THEN 'Windows 95 ConsRows = 35 ConsCols = 102 winver = 0 END IF IF j = 4 AND k > 0 THEN 'Windows 98/Me ConsRows = 44 ConsCols = 102 winver = 1 END IF IF j = 5 THEN IF k = 0 THEN '2000 ConsRows = 44 ConsCols = 102 winver = 2 END IF IF k > 0 THEN 'XP ConsRows = 44 ConsCols = 102 winver = 3 END IF END IF MAXPLAYERS = 51 TopPitLim = 35 TRUE = -1 FALSE = 0 KeyF4 = -62 KeyF3 = -61 KeyF2 = -60 KeyEsc = 27 CloseButton$ = CHR$(254) AbortButton$ = CHR$(249) nulls$ = "" HomeDir$ = UCASE$(CURDIR$) PlayUSA = "PLAY " + HomeDir$ + "\usan.mid" PlayCAN = "PLAY " + HomeDir$ + "\canada.mid" StopUSA = "STOP " + HomeDir$ + "\usan.mid" StopCAN = "STOP " + HomeDir$ + "\canada.mid" %directorymask = 16 PosDesc(1) = "the mound" PosDesc(2) = "the catcher" PosDesc(3) = "first" PosDesc(4) = "second" PosDesc(5) = "third" PosDesc(6) = "short" PosDesc(7) = "left" PosDesc(8) = "center" PosDesc(9) = "right" 'Increasing numbers yield fewer errors 'Decreasing numbers yield more errors DefChancesPerGameF(0) = 0. DefChancesPerGameF(1) = 1.0 'dummy - hardcoded at .952 DefChancesPerGameF(2) = 1.0 '1.05 1.4 1.3 1.5 2.0 DefChancesPerGameF(3) = 2.2 '2.7 1.9 1.85 'imperical since few errors on POs DefChancesPerGameF(4) = 5.7 DefChancesPerGameF(5) = 2.9 DefChancesPerGameF(6) = 4.8 DefChancesPerGameF(7) = 1.85 DefChancesPerGameF(8) = 2.45 DefChancesPerGameF(9) = 1.85 DefChancesPerGameF(10) = 0. NormDEF(1) = .952 NormDEF(2) = .990 NormDEF(3) = .993 NormDEF(4) = .981 NormDEF(5) = .953 NormDEF(6) = .967 NormDEF(7) = .977 NormDEF(8) = .984 NormDEF(9) = .981 NormDEF(10) = .999 'Outs (exc K's) Pitch Count Distribution average = 3.2 P32(1) = 1 P32(2) = 1 P32(3) = 2 P32(4) = 3 P32(5) = 3 P32(6) = 4 P32(7) = 4 P32(8) = 4 P32(9) = 5 P32(10)= 6 'Hits Pitch Count Distribution average = 3.3 P33(1) = 1 P33(2) = 1 P33(3) = 2 P33(4) = 3 P33(5) = 3 P33(6) = 4 P33(7) = 4 P33(8) = 5 P33(9) = 5 P33(10)= 6 'Strike Out Pitch Count Distribution average = 4.8 P48(1) = 3 P48(2) = 3 P48(3) = 4 P48(4) = 5 P48(5) = 5 P48(6) = 5 P48(7) = 6 P48(8) = 6 P48(9) = 6 P48(10)= 7 'Walk Pitch Count Distribution average = 5.2 P52(1) = 4 P52(2) = 4 P52(3) = 5 P52(4) = 5 P52(5) = 5 P52(6) = 5 P52(7) = 5 P52(8) = 6 P52(9) = 6 P52(10)= 8 'Load Background color descriptions ColorDescTable$(0) = "BLACK" ColorDescTable$(1) = "BLUE" ColorDescTable$(2) = "GREEN" ColorDescTable$(3) = "CYAN" ColorDescTable$(4) = "RED" ColorDescTable$(5) = "MAGENTA" ColorDescTable$(6) = "BROWN" ColorDescTable$(7) = "DONTUSE" ColorDescTable$(8) = "GRAY" ColorDescTable$(9) = "BRIGHT BLUE" 'bright blue ColorDescTable$(10) = "BRIGHT GREEN" 'bright green - need dark forg ColorDescTable$(11) = "BRIGHT CYAN" 'very light(powder) blue - need dark forg ColorDescTable$(12) = "BRIGHT RED" 'bright red ColorDescTable$(13) = "BRIGHT MAGENTA" 'almost pink ColorDescTable$(14) = "YELLOW" 'bright yellow - need dark forg ColorDescTable$(15) = "WHITE" 'nice '.SCH file field offset data SubRecLen = 28 VisiOffset = 1 HomeOffset = 9 OptiOffset = 17 STSOpen = FALSE Owner$ = " SBS " FOR i = 1 TO 11 Pos(i) = READ$(i) NEXT DATA "P ","C ",1B,2B,3B,SS,LF,CF,RF,DH," " ' Check existense of message file IF LEN(DIR$("BASEBALL.MSG")) = 0 THEN GOSUB DeclareConsole x$ = "The BASEBALL.MSG file was not found in the home directory." CALL ErrorBox (x$) GOTO QuickEnd END IF Reconfigure: ' Load default League Averages ' Load editor and custom League Averages if desired HiLvlHits = 5 HiLvlHRs = 3 HiLvlSBs = 4 HiLvlRBIs = 7 HiLvlSOs = 14 HiLvlPHits = 2 HiLvlBStr = 20 LPTNum = 1 RegInns = 9 IF winver < 2 THEN EditorSpec$ = "\WINDOWS\notepad.exe " WordPadSpec$ = "\Program Files\Accessories\wordpad.exe " ELSEIF winver = 2 THEN EditorSpec$ = "\WINNT\system32\notepad.exe " WordPadSpec$ = "\Program Files\Windows NT\Accessories\wordpad.exe " ELSEIF winver > 2 THEN IF LEN(DIR$("\WINNT\system32\notepad.exe")) THEN EditorSpec$ = "\WINNT\system32\notepad.exe " ELSE EditorSpec$ = "\WINDOWS\system32\notepad.exe " END IF WordPadSpec$ = "\Program Files\Windows NT\Accessories\wordpad.exe " END IF CmdStar$ = "STARBOX.TXT" CmdPic$ = "wrigley1.jpg" CmdFireworks$ = "Y" CmdParkEffects$ = "Y" CmdHomeFieldAdv$ = "Y" CmdAltFont$ = "N" CmdSound$ = "Y" CmdDel = 3 ColorScheme = 5 RefreshStandings = 20 ProtectSCH = FALSE ForceSBAlways = FALSE Force2TmLineup = FALSE StrictCloserRule = FALSE DaysOffRule = FALSE WarmUpRule = FALSE BatterOveruse = FALSE AutoCoach = FALSE AutoDefense = FALSE BlockDoubleSwitch = FALSE AllowStartersInRelief = FALSE OutOfPositionMsg = TRUE IF LEN(DIR$("BASEBALL.CFG")) THEN OPEN "BASEBALL.CFG" FOR INPUT AS #1 LEN = 128 LAvgNdx = 0 DO WHILE NOT EOF(1) LINE INPUT #1, rec$ rec$ = UCASE$(rec$) xS$ = MID$(rec$, 1, 4) yS$ = MID$(rec$, 1, 5) IF MID$(rec$, 1, 7) = "EDITOR=" THEN EditorSpec$ = RTRIM$(MID$(rec$, 8)) + " " ELSEIF MID$(rec$, 1, 13) = "M-MODE-SOUND=" THEN CmdSound$ = RTRIM$(MID$(rec$, 14, 1)) ELSEIF MID$(rec$, 1, 13) = "M-MODE-DELAY=" THEN CmdDel = VAL(RTRIM$(MID$(rec$, 14, 1))) ELSEIF MID$(rec$, 1, 13) = "CONSOLE-ROWS=" THEN IF MenuOpt$ <> "P" THEN ConsRows = VAL(MID$(rec$, 14, 2)) ELSEIF MID$(rec$, 1, 13) = "CONSOLE-COLS=" THEN IF MenuOpt$ <> "P" THEN ConsCols = VAL(MID$(rec$, 14)) ELSEIF MID$(rec$, 1, 8) = "WORDPAD=" THEN WordPadSpec$ = RTRIM$(MID$(rec$, 9)) + " " ELSEIF MID$(rec$, 1, 10) = "FIREWORKS=" THEN CmdFireworks$ = MID$(rec$, 11, 1) ELSEIF MID$(rec$, 1, 12) = "FIELD-PHOTO=" THEN CmdPic$ = RTRIM$(MID$(rec$, 13)) ELSEIF MID$(rec$, 1, 4) = "AUX=" THEN AuxSpec$ = RTRIM$(MID$(rec$, 5)) + " " ELSEIF MID$(rec$, 1, 13) = "HOME-RUN-WAV=" THEN CmdHRWav$ = MID$(rec$, 14) ELSEIF MID$(rec$, 1, 4) = "LPT=" THEN LPTNum = VAL(MID$(rec$, 5, 1)) ELSEIF MID$(rec$, 1, 16) = "STAT-TEAM-LIMIT=" THEN STATTEAMLIMIT = VAL(MID$(rec$, 17)) ELSEIF MID$(rec$, 1, 10) = "DATA-PATH=" THEN CmdPath$ = RTRIM$(MID$(rec$, 11)) IF RIGHT$(CmdPath$, 1) <> "\" THEN CmdPath$ = CmdPath$ + "\" END IF ELSEIF MID$(rec$, 1, 11) = "WRITE-PATH=" THEN CmdWritePath$ = RTRIM$(MID$(rec$, 12)) IF RIGHT$(CmdWritePath$, 1) <> "\" THEN CmdWritePath$ = CmdWritePath$ + "\" END IF ELSEIF MID$(rec$, 1, 19) = "REGULATION-INNINGS=" THEN RegInns = VAL(MID$(rec$, 20)) ELSEIF MID$(rec$, 1, 13) = "COLOR-SCHEME=" THEN ColorScheme = VAL(MID$(rec$, 14, 1)) ELSEIF MID$(rec$, 1, 18) = "REFRESH-STANDINGS=" THEN RefreshStandings = VAL(MID$(rec$, 19)) ELSEIF MID$(rec$, 1, 13) = "PARK-EFFECTS=" THEN CmdParkEffects$ = MID$(rec$, 14, 1) ELSEIF MID$(rec$, 1, 15) = "ALTERNATE-FONT=" THEN CmdAltFont$ = MID$(rec$, 16, 1) ELSEIF MID$(rec$, 1, 11) = "PROTECT-SCH" THEN IF MID$(rec$, 13, 1) <> "N" THEN ProtectSCH = TRUE END IF ELSEIF MID$(rec$, 1, 16) = "FORCE-SCOREBOARD" THEN IF MID$(rec$, 18, 1) <> "N" THEN ForceSBAlways = TRUE END IF ELSEIF MID$(rec$, 1, 12) = "FORCE-LINEUP" THEN IF MID$(rec$, 14, 1) <> "N" THEN Force2TmLineup = TRUE END IF ELSEIF MID$(rec$, 1, 18) = "STRICT-CLOSER-RULE" THEN IF MID$(rec$, 20, 1) <> "N" THEN StrictCloserRule = TRUE END IF ELSEIF MID$(rec$, 1, 13) = "DAYS-OFF-RULE" THEN IF MID$(rec$, 15, 1) <> "N" THEN DaysOffRule = TRUE END IF ELSEIF MID$(rec$, 1, 11) = "WARMUP-RULE" THEN IF MID$(rec$, 13, 1) <> "N" THEN WarmUpRule = TRUE END IF ELSEIF MID$(rec$, 1, 14) = "BATTER-OVERUSE" THEN IF MID$(rec$, 16, 1) <> "N" THEN BatterOveruse = TRUE END IF ELSEIF MID$(rec$, 1, 9) = "AUTOCOACH" THEN IF MID$(rec$, 11, 1) <> "N" THEN AutoCoach = TRUE END IF ELSEIF MID$(rec$, 1, 11) = "AUTODEFENSE" THEN IF MID$(rec$, 13, 1) <> "N" THEN AutoDefense = TRUE END IF ELSEIF MID$(rec$, 1, 19) = "OUT-OF-POSITION-MSG" THEN IF MID$(rec$, 21, 1) = "N" THEN OutOfPositionMsg = FALSE END IF ELSEIF MID$(rec$, 1, 16) = "NO-DOUBLE-SWITCH" THEN IF MID$(rec$, 18, 1) <> "N" THEN BlockDoubleSwitch = TRUE END IF ELSEIF MID$(rec$, 1, 20) = "STARTERS-MAY-RELIEVE" THEN IF MID$(rec$, 22, 1) <> "N" THEN AllowStartersInRelief = TRUE END IF ELSEIF MID$(rec$, 1, 6) = "HILITE" THEN HiLvlHits = VAL(MID$(rec$, 11, 6)) HiLvlHRs = VAL(MID$(rec$, 18, 6)) HiLvlRBIs = VAL(MID$(rec$, 25, 6)) HiLvlSBs = VAL(MID$(rec$, 32, 6)) HiLvlPHits = VAL(MID$(rec$, 39, 6)) HiLvlSOs = VAL(MID$(rec$, 46, 6)) HiLvlBStr = VAL(MID$(rec$, 53, 6)) IF HiLvlBStr = 0 THEN HiLvlBStr = 20 IF HiLvlHits = 0 OR HiLvlHRs = 0 OR HiLvlRBIs = 0 OR HiLvlSBs = 0 OR HiLvlSOs = 0 THEN GOSUB DeclareConsole CALL MyBeep x$ = "Warning: Problem with HILITE line of BASEBALL.CFG!" CALL ErrorBox (x$) END IF ELSEIF NUMERIC(xS$, FALSE, FALSE) OR LEFT$(xS$, 3) = "DEF" THEN IF LAvgNdx < 300 THEN INCR LAvgNdx j = VAL(MID$(rec$, 18, 6)) 'hits k = VAL(MID$(rec$, 25, 6)) 'doubles L = VAL(MID$(rec$, 32, 6)) 'triples m = VAL(MID$(rec$, 39, 6)) 'homers N = VAL(MID$(rec$, 46, 6)) 'walks o = VAL(MID$(rec$, 53, 6)) 'strike outs p = VAL(MID$(rec$, 60, 6)) 'teams in league q!= VAL(MID$(rec$, 67, 6)) 'runs-per-game (per team) r = VAL(MID$(rec$, 74, 3)) 'league rating IF r = 0 THEN r = 100 s = j - k - L - m 'singles IF j = 0 OR k = 0 OR L = 0 OR m = 0 OR N = 0 THEN GOSUB DeclareConsole CALL MyBeep x$ = "Warning: Problem with League Average data in|" x$ = x$ + "Line " + yS$ + " of BASEBALL.CFG!" CALL ErrorBox(x$) END IF bD = VAL(MID$(rec$, 11, 6)) 'innings IF j > 0 THEN IF bD / j > 1.5 OR bD / j < .5 THEN GOSUB DeclareConsole CALL MyBeep x$ = "Warning: Possible problem with League Average data|" x$ = x$ + "Line "+ yS$ + " of BASEBALL.CFG! Please check." CALL ErrorBox(x$) END IF END IF bF! = BattersFacedByPit! (bD, j, N, o) LAvg(LAvgNdx).LAvgYr = MID$(rec$, 1, 4) LAvg(LAvgNdx).LAvgLg = MID$(rec$, 5, 1) LAvg(LAvgNdx).LAvgBB = N / bF! LAvg(LAvgNdx).LAvgSO = o / (bD * 3) '% of outs that are K's LAvg(LAvgNdx).LAvgS2 = o / bF! LAvg(LAvgNdx).LAvg1B = s / bF! LAvg(LAvgNdx).LAvg2B = k / bF! LAvg(LAvgNdx).LAvg3B = L / bF! LAvg(LAvgNdx).LAvgHR = m / bF! LAvg(LAvgNdx).LTeams = p LAvg(LAvgNdx).LAvgRG = q! LAvg(LAvgNdx).Rating = r LAvg(LAvgNdx).Innings = bD LAvg(LAvgNdx).Hits = j LAvg(LAvgNdx).Doubles = k LAvg(LAvgNdx).Triples = L LAvg(LAvgNdx).HR = m LAvg(LAvgNdx).BB = N END IF LOOP CLOSE #1 END IF 'Check for Non-Raster Font option IF CmdAltFont$ = "N" THEN LPtr$ = CHR$(17) RPtr$ = CHR$(16) UpPtr$ = CHR$(30) DnPtr$ = CHR$(31) xUpPtr$ = CHR$(24) xDnPtr$ = CHR$(25) xLPtr$ = CHR$(27) xRPtr$ = CHR$(26) ARROWS$ = CHR$(27) + CHR$(18) + CHR$(26) EnterPtr$ = CHR$(32) + CHR$(17) + CHR$(196) + CHR$(217) ELSE LPtr$ = "<" RPtr$ = ">" UpPtr$ = "^" DnPtr$ = "v" xUpPtr$ = "u" xDnPtr$ = "d" xLPtr$ = "<" xRPtr$ = ">" ARROWS$ = "<|>" EnterPtr$ = " <" + CHR$(196) + CHR$(217) END IF 'Check command$ here? SimGameCtr = 0 SchedSw = FALSE SeriesSw = FALSE DspSw = TRUE 'Does not hide the options NewUI = TRUE ForceCLS = TRUE RegDsply = TRUE '------------------------------------------- ' Check the COMMAND LINE '------------------------------------------- xS$ = COMMAND$ CALL ParseCommand (xS$, nargs) IF CmdCmdFile$ > "!" THEN IF LEN(DIR$(CmdCmdFile$)) THEN OPEN CmdCmdFile$ FOR INPUT AS #1 LINE INPUT #1, xS$ CLOSE #1 CALL ParseCommand (xS$, nargs) END IF END IF CALL SetSwitches (nargs) SavCmdPath$ = CmdPath$ IF MenuOpt$ = "P" THEN GOTO MenuOptions 'Reconfigure GOSUB DeclareConsole 'Make it visible also MidRow = ConsRows \ 2 MidCol = ConsCols \ 2 RowO = MidRow - 12 ColO = MidCol - 40 x$ = "Your Windows version is: " + _ LTRIM$(STR$(WindowsVersion(%WIN_MAJORVERSION))) _ + "." + LTRIM$(STR$(WindowsVersion(%WIN_MINORVERSION))) _ + "." + LTRIM$(STR$(WindowsVersion(%WIN_BUILDNUMBER))) defattr = CalcAttr(15, 1) QPRINTs 1, 1, x$, defattr QPRINTs 2, 1, "---------------------------------", defattr QPRINTs 3, 1, "Initializing...", defattr DIM PbyP(1500) AS GLOBAL PbyPType CALL LoadPbyP SLEEP 500 MOUSE 3, DOUBLE, DOWN MOUSE ON PAGE 2 GOSUB PokeBackground PAGE 1 Gfx = FALSE BackgroundPic$ = CmdPic$ IF BackgroundPic$ > "!" THEN GOSUB GetPhotoSpecs 'Returns "Gfx" T or F GOSUB DefineBitmap 'Go here even if not Gfx! SimTotal = 0 IF SchedSw THEN IF LEN(DIR$(CmdPath$ + CmdSch$)) = 0 THEN x$ = "The schedule file was not found." CALL ErrorBox(x$) GOTO QuickEnd END IF SimTotal = CountGamesInSCH (nulls$, nulls$, nulls$, nulls$, SubRecLen, VisiOffset, HomeOffset, OptiOffset) REDIM MMList(100) AS GLOBAL MMType REDIM RotRec(300) AS GLOBAL RotType CALL SetRestartData GOSUB SetAutoMgr END IF IF SeriesSw THEN IF LEN(DIR$(CmdPath$ + CmdSER$)) = 0 THEN x$ = "The series file was not found." CALL ErrorBox(x$) GOTO QuickEnd END IF SimTotal = CountGamesInSER REDIM RotRec(300) AS GLOBAL RotType RTx = 0 'Reopen to get first line of .SER file OPEN CmdPath$ + CmdSER$ FOR INPUT AS #2 LEN = 128 LINE INPUT #2, xS$ CALL ParseCommand (xS$, nargs) CALL SetSwitches (nargs) GOSUB SetAutoMgr END IF IF CmdStat$ > "!" THEN GOSUB OpenStatFiles IF CmdVFil$ > "!" AND CmdHFil$ > "!" THEN 'You are always here from the command line because these 'variables are also set in "SetRestartData" 'We will not display the Logo PCOPY 2, 1 REDIM RotRec(300) AS GLOBAL RotType RTx = 0 IF CmdSlotGames > 1 THEN GOSUB SetAutoMgr ELSE IF CmdVAutoMgr$ = "Y" THEN amgr(1) = TRUE IF CmdHAutoMgr$ = "Y" THEN amgr(2) = TRUE END IF 'Default stuff for command-line IF CmdSpot$ = nulls$ THEN CmdSpot$ = "N" IF CmdVSpot$ = nulls$ THEN CmdVSpot$ = "N" IF CmdHSpot$ = nulls$ THEN CmdHSpot$ = "N" IF CmdFocus$ = nulls$ THEN CmdFocus$ = "N" IF amgr(1) AND amgr(2) THEN GOSUB Normalization IF CmdDelIsOnCommandLine = FALSE THEN CmdDel = 0 IF CmdDel = 0 AND CmdPauseAftGame$ = "N" _ AND CmdPauseAftDate$ = "N" THEN RegDsply = FALSE DelFac = CmdDel 'Delay Factor from the command line : auto-manage GOTO LoadTeamFiles END IF 'We are not in a series/schedule. 'We are not in a multi-game two-team sim. 'We ARE in a single manual game. 'We know both teams. 'We may or may not know the pitchers. 'Either team or both may be auto-managed. CmdLine = TRUE MenuOpt$ = "M" DataFil(1) = CmdVFil$ DataFil(2) = CmdHFil$ DelFac = CmdDel 'Delay Factor from the command line : not auto-manage (inherits "3" if not given) GOSUB ClearLineupData GOSUB ClearGameData GOTO LoadManual END IF '------------------------------------------ ' Opening Screen '------------------------------------------ IF Gfx THEN GOSUB DefineBigBitmap ELSE PCOPY 2, 1 'Light blue screen END IF CALL Logo(zS$) IF Gfx THEN CALL EliminateHole(32) END IF FromLogo = TRUE IF zS$ = "Q" THEN GOTO QuickEnd '------------------------------------------- ' Process Menu Option Selection '------------------------------------------- MenuOptions: CLOSE 'Close ALL Files COLOR 15, 3 CLS IF Gfx THEN IF FromLogo = FALSE THEN FOR n = 1 TO 32 CALL EliminateHole(n) NEXT GOSUB DefineBigBitmap CALL ShowGfx END IF ELSE PCOPY 2, 1 END IF REDIM amgr(2) AS GLOBAL LONG STSOpen = FALSE REDIM BSum(0 TO 1) AS GLOBAL BatSummary REDIM PSum(0 TO 1) AS GLOBAL PitSummary REDIM FSum(0 TO 1) AS GLOBAL FldSummary UseBigP = FALSE UseBigB = FALSE CmdPath$ = SavCmdPath$ MenuOpt$ = MenuRoutine2$ FromLogo = FALSE IF Gfx THEN COLOR 15, 3 CLS CALL EliminateHole(32) GOSUB DefineBitmap CALL HideGfx END IF LOCATE 1, 1 CURSOR OFF 'hide cursor IF MenuOpt$ = "Q" THEN GOTO QuickEnd '---------------------- 'Options P: Edit BASEBALL.CFG '---------------------- IF MenuOpt$ = "P" THEN zS$ = EditorSpec$ + "baseball.cfg" ShowWindState& = 1 ConsoleShell zS$, ShowWindState& 'this will launch in separate window SLEEP 1000 CALL DrawFrm(10+rowO, 12+colO, 18+rowO, 68+colO, defattr, nulls$, nulls$, 0, 0, 0) QPRINTs 12+rowO, 14+colO, " Apply changes now? [y/N] ", defattr QPRINTs 14+rowO, 14+colO, " Note: Changes to the console window size require ", dimattr QPRINTs 15+rowO, 14+colO, " shutting down and restarting SBS before they ", dimattr QPRINTs 16+rowO, 14+colO, " take effect. ", dimattr LOCATE 12+rowO, 40+colO IF YESorNO$(revfor, revbac, deffor, defbac, "N") = "Y" THEN GOTO Reconfigure ELSE GOTO MenuOptions END IF END IF '---------------------- 'Options R: Read Doc '---------------------- IF MenuOpt$ = "R" THEN CALL ShowDoc GOTO MenuOptions END IF '---------------------- 'Option F: File Viewer '---------------------- IF MenuOpt$ = "F" THEN DO r1 = 2 r2 = ConsRows - 3 c1 = 4 c2 = ConsCols - 5 QPRINTs MidRow, MidCol-10, " Loading file names... ", defattr FileLimit = 1500 REDIM List1(1 TO FileLimit) AS List1Type n = 0 Fil$ = CmdWritePath$ + "*.TXT" CALL LoadFilesToList1 (Fil$, List1(), FileLimit, n) ' [n] Fil$ = CmdWritePath$ + "*.PRN" CALL LoadFilesToList1 (Fil$, List1(), FileLimit, n) ' [n] Fil$ = CmdWritePath$ + "*.LOG" CALL LoadFilesToList1 (Fil$, List1(), FileLimit, n) ' [n] Fil$ = "*.DOC" CALL LoadFilesToList1 (Fil$, List1(), FileLimit, n) ' [n] Fil$ = CmdWritePath$ + "*. " CALL LoadFilesToList1 (Fil$, List1(), FileLimit, n) ' [n] ARRAY SORT List1(1) FOR n, FROM 1 TO 12, DESCEND CALL DrawFrm(r1, c1, r2, c2, defattr, "View Misc. Files", "ENTER:View Del:Delete ESC:Menu", 1, 0, 2) DO nr = r2-r1-1 nc = (c2-c1-1) \ 14 CALL PickFromList(List1(), n, nr, nc, 12, r1, c1, r2, c2, dimattr, revattr, Pick, RetKey, nulls$, mous, ms$) IF RetKey = KeyEsc OR RetKey = KeyF3 THEN EXIT DO IF Pick > 0 THEN IF RetKey = -83 THEN 'Delete CALL DrawFrm(19+rowO, 32+colO, 21+rowO, 50+colO, defattr, nulls$, nulls$, 0, 0, 0) QPRINTs 20+rowO, 33+colO, " Are you sure? ", defattr LOCATE 20+rowO, 48+colO IF YESorNO$(7, 0, deffor, defbac, "N") = "Y" THEN CALL KillIt(RTRIM$(List1(Pick).ListItem)) END IF EXIT DO ELSE QPush x$ = RTRIM$(List1(Pick).ListItem) IF UCASE$(RIGHT$(x$, 4)) = ".DOC" THEN ' SHELL WordPadSpec$ + " " + x$ 'this will launch in separate window ShowWindState& = 1 zS$ = WordPadSpec$ + " " + x$ ConsoleShell zS$, ShowWindState& ELSE CALL ListFile(CmdWritePath$ + x$) END IF QPop END IF END IF RetKey = -99 'forces PickFromList to just wait for input LOOP ERASE List1 LOOP WHILE RetKey = -83 'catches "delete" -> redisplays GOTO MenuOptions END IF '---------------------------------------- 'Options A: Display and Select Stat Files '---------------------------------------- 'RetKey = 0 IF MenuOpt$ = "A" THEN PCOPY 2, 1 'Show STAT Files and Pick One FileLimit = 500 IF CmdWritePath$ > "!" THEN CurrentDir$ = CmdWritePath$ ELSE CurrentDir$ = HomeDir$ END IF IF RIGHT$(CurrentDir$, 1) <> "\" THEN CurrentDir$ = CurrentDir$ + "\" DO REDIM List1(1 TO FileLimit) AS List1Type RetKey = -97 ReadDirsA: GOSUB LoadDirsToList1 'returns n 'Directory Tree Frame IF RetKey = -97 THEN j = 0: c1$ = CHR$(193): c2$ = CHR$(194) ELSE j = 1: c1$ = CHR$(208): c2$ = CHR$(210) END IF CALL DrawFrm(2+rowO,48+colO, 10+rowO, 78+colO, defattr, "Dbl-click folder", "F4", 0, j, 0) QPRINTs 5+rowO, 78+colO, c1$, defattr QPRINTs 6+rowO, 78+colO, UpPtr$, defattr QPRINTs 7+rowO, 78+colO, DnPtr$, defattr QPRINTs 8+rowO, 78+colO, c2$, defattr 'Fill instantly return [-97] OR pick a directory CALL PickFromList(List1(), n, 7, 1, 28, 2+rowO,48+colO, 10+rowO, 78+colO, dimattr, revattr, Pick, RetKey, nulls$, mous, ms$) IF Pick > 0 THEN xS$ = RTRIM$(List1(Pick).ListItem) IF xS$ < "!" THEN GOTO ReadDirsA IF LEFT$(xS$, 3) = "·Ž " THEN xS$ = MID$(xS$, 4) CHDIR xS$ CurrentDir$ = UCASE$(CURDIR$) IF RIGHT$(CurrentDir$, 1) <> "\" THEN CurrentDir$ = CurrentDir$ + "\" RetKey = -97 GOTO ReadDirsA END IF RetKey = 0 'Files Frame Fil$ = CurrentDir$ + "*.STS" CALL PickAFile (Fil$, FileLimit, List1(), RetKey, Pick, mous, 1) IF RetKey = KeyF4 OR (RetKey = KeyEsc AND mous = TRUE) THEN CALL DrawFrm (2+rowO, 2+colO, 10+rowO, 46+colO, defattr, "Statistics Files", "DEL:Delete ESC:Menu", 0, 0, 0) GOTO ReadDirsA END IF LOOP WHILE RetKey = -83 '[D]elete must redisplay CHDIR HomeDir$ IF RetKey = KeyEsc OR RetKey = KeyF3 OR Pick = 0 THEN GOTO MenuOptions CmdStat$ = RTRIM$(List1(Pick).ListItem) ERASE List1 CALL StatsIO (Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) CmdStat$ = nulls$ GOTO MenuOptions END IF '--------------------- 'Options M, T, S, E '--------------------- 'Manual / Two-team / Sch / Ser DisplaySchFiles: PCOPY 2, 1 IF MenuOpt$ = "T" OR MenuOpt$ = "S" OR MenuOpt$ = "E" THEN REDIM RotRec(300) AS GLOBAL RotType RTx = 0 REDIM MMList(100) AS GLOBAL MMType MMx = 0 REDIM WLRec(1 TO 300) AS GLOBAL WLType WLx = 0 END IF '------------------------------------------- 'Options S: Display and Select Schedule file '------------------------------------------- IF MenuOpt$ = "S" THEN 'Show Schedule Files and Pick One FileLimit = 150 DO REDIM List1(1 TO FileLimit) AS List1Type GOSUB GetCurrentDir 'return CurrentDir$ RetKey = -97 ReadDirsS: GOSUB LoadDirsToList1 'returns n 'Directory Tree Frame IF RetKey = -97 THEN j = 0: c1$ = CHR$(193): c2$ = CHR$(194) ELSE j = 1: c1$ = CHR$(208): c2$ = CHR$(210) END IF CALL DrawFrm(2+rowO,48+colO, 10+rowO, 78+colO, defattr, "Dbl-click folder", "F4", 0, j, 0) QPRINTs 5+rowO, 78+colO, c1$, defattr QPRINTs 6+rowO, 78+colO, UpPtr$, defattr QPRINTs 7+rowO, 78+colO, DnPtr$, defattr QPRINTs 8+rowO, 78+colO, c2$, defattr 'Display left frame and instantly return (-97) or pick a directory CALL PickFromList(List1(), n, 7, 1, 28, 2+rowO,48+colO, 10+rowO, 78+colO, dimattr, revattr, Pick, RetKey, nulls$, mous, ms$) IF Pick > 0 THEN xS$ = RTRIM$(List1(Pick).ListItem) IF xS$ < "!" THEN GOTO ReadDirsS IF LEFT$(xS$, 3) = "·Ž " THEN xS$ = MID$(xS$, 4) CHDIR xS$ CurrentDir$ = UCASE$(CURDIR$) IF RIGHT$(CurrentDir$, 1) <> "\" THEN CurrentDir$ = CurrentDir$ + "\" RetKey = -97 GOTO ReadDirsS END IF RetKey = 0 'Files Frame Fil$ = CurrentDir$ + "*.SCH" CALL PickAFile (Fil$, FileLimit, List1(), RetKey, Pick, mous, 1) IF RetKey = KeyF4 OR (RetKey = KeyEsc AND mous = TRUE) THEN CALL DrawFrm (2+rowO, 2+colO, 10+rowO, 46+colO, defattr, "Schedule Files", "[E]dit [N]ew ESC:Menu", 0, 0, 0) GOTO ReadDirsS END IF LOOP WHILE RetKey = 78 OR RetKey = 110 '[N]EW must redisplay CHDIR HomeDir$ IF RetKey = KeyEsc OR RetKey = KeyF3 OR Pick = 0 THEN GOTO MenuOptions CmdSCH$ = RTRIM$(List1(Pick).ListItem) CmdPath$ = CurrentDir$ 'Opportunity to Pick a Single Team and/or Date Range CALL SCHDateTeamIO (Keyed, Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) IF Keyed = KeyF3 THEN ERASE List1 CmdSCH$ = nulls$ CHDIR HomeDir$ GOTO MenuOptions END IF SchedSw = TRUE ERASE List1 'Pick from ActiveSTAT(*) CALL CountActiveSTATFiles IF STx > 0 AND ProtectSCH = FALSE THEN FileLimit = 150 REDIM List1(1 TO FileLimit) AS List1Type FOR i = 1 TO STx List1(i).ListItem = ActiveSTAT(i) NEXT StatFrame: CALL DrawFrm(8+rowO, 22+colO, 15+rowO, 57+colO, defattr, "Stat Files for this .SCH", "Dbl-click selection or ENTER", 1, 0, 1) QPRINTs 14+rowO, 27+colO, "F10:Reset ESC:None", dimattr COLOR deffor, defbac CALL PickFromList(List1(), STx, 5, 2, 8, 8+rowO, 22+colO, 15+rowO, 57+colO, dimattr, revattr, Pick, RetKey, nulls$, mous, ms$) IF Pick > 0 THEN CmdStat$ = RTRIM$(List1(Pick).ListItem) END IF ERASE List1 'Special Case (F10) to Clear the STAT File List IF RetKey = -68 THEN CALL ClearActiveSTATRec END IF 'Pick Rotation Scheme for Schedule Runs CALL RotationMethIO (Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) IF CmdSP$ = nulls$ THEN CmdSCH$ = nulls$: SchedSw = FALSE: GOTO DisplaySchFiles 'Set DH option GOSUB SkedAskDH CALL StatRecordSetup (Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) CALL StatRecordIO (RetKey, Flds, 3, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) SimTotal = CountGamesInSCH (CmdFavLeague$, CmdFavTeam$, CmdDateL$, CmdDateH$, SubRecLen, VisiOffset, HomeOffset, OptiOffset) CALL SetRestartData IF CmdStat$ > "!" THEN GOSUB OpenStatFiles END IF '------------------------------------------- 'Options E: Display and Select Serial file '------------------------------------------- IF MenuOpt$ = "E" THEN 'Show Series Files and Pick One FileLimit = 150 REDIM List1(1 TO FileLimit) AS List1Type GOSUB GetCurrentDir 'return CurrentDir$ RetKey = -97 ReadDirsE: GOSUB LoadDirsToList1 'returns n 'Directory Tree Frame IF RetKey = -97 THEN j = 0: c1$ = CHR$(193): c2$ = CHR$(194) ELSE j = 1: c1$ = CHR$(208): c2$ = CHR$(210) END IF CALL DrawFrm(2+rowO,48+colO, 10+rowO, 78+colO, defattr, "Dbl-click folder", "F4", 0, j, 0) QPRINTs 5+rowO, 78+colO, c1$, defattr QPRINTs 6+rowO, 78+colO, UpPtr$, defattr QPRINTs 7+rowO, 78+colO, DnPtr$, defattr QPRINTs 8+rowO, 78+colO, c2$, defattr 'Display left frame and instantly return (-97) or pick a directory CALL PickFromList(List1(), n, 7, 1, 28, 2+rowO,48+colO, 10+rowO, 78+colO, dimattr, revattr, Pick, RetKey, nulls$, mous, ms$) IF Pick > 0 THEN xS$ = RTRIM$(List1(Pick).ListItem) IF xS$ < "!" THEN GOTO ReadDirsE IF LEFT$(xS$, 3) = "·Ž " THEN xS$ = MID$(xS$, 4) CHDIR xS$ CurrentDir$ = UCASE$(CURDIR$) IF RIGHT$(CurrentDir$, 1) <> "\" THEN CurrentDir$ = CurrentDir$ + "\" RetKey = -97 GOTO ReadDirsE END IF RetKey = 0 'Files Frame Fil$ = CurrentDir$ + "*.SER" CALL PickAFile (Fil$, FileLimit, List1(), RetKey, Pick, mous, 1) IF RetKey = KeyF4 OR (RetKey = KeyEsc AND mous = TRUE) THEN CALL DrawFrm (2+rowO, 2+colO, 10+rowO, 46+colO, defattr, "Series Files", "[V]iew [E]dit [N]ew ESC:Menu", 0, 0, 0) GOTO ReadDirsE END IF CHDIR HomeDir$ IF RetKey = KeyEsc OR RetKey = KeyF3 OR Pick = 0 THEN GOTO MenuOptions CALL RotationMethIO (Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) IF CmdSP$ = nulls$ THEN GOTO DisplaySchFiles CmdSER$ = RTRIM$(List1(Pick).ListItem) FILPath$ = CurrentDir$ SeriesSw = TRUE ERASE List1 GOSUB SkedAskDH CALL StatRecordSetup (Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) CALL StatRecordIO (RetKey, Flds, 3, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) CmdPath$ = FILPath$ SimTotal = CountGamesInSER 'Parse 1st line of .SER OPEN CmdPath$ + CmdSER$ FOR INPUT AS #2 LEN = 128 LINE INPUT #2, xS$ CALL ParseCommand (xS$, nargs) CALL SetSwitches (nargs) IF CmdStat$ > "!" THEN GOSUB OpenStatFiles END IF '------------------------ 'Schedule/Serial Settings 'Options S and E '------------------------ IF MenuOpt$ = "S" OR MenuOpt$ = "E" THEN CALL MoreOptionsIO (8, Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) GOSUB Normalization ForceCLS = TRUE IF DelFac = 0 AND CmdPauseAftGame$ = "N" _ AND CmdPauseAftDate$ = "N" THEN RegDsply = FALSE ELSE RegDsply = TRUE END IF GOSUB SetAutoMgr END IF '------------------------------------------------ ' Normal ReEntry point for new .sch/.ser lines ' Applies to Options: M, T, S, E '------------------------------------------------ LoadTeamFiles: LL = 1 GOSUB ClearLineupData GOSUB ClearGameData SaveMMGameStatus = MMGame MMGame = FALSE LastPic$ = BackgroundPic$ BackgroundPic$ = CmdPic$ '------------------------------------------------ ' Sched / sEries / Command-line '------------------------------------------------ IF CmdVFil$ > "!" AND CmdHFil$ > "!" THEN 'Load team files from disk DataFil(1) = CmdVFil$ DataFil(2) = CmdHFil$ REDIM DLN(MAXPLAYERS, 2) AS GLOBAL LONG '"Duplicate Last Name" REDIM HBF!(2) REDIM HPF!(2) REDIM ParkBatAdj(2) AS GLOBAL SINGLE REDIM ParkPitAdj(2) AS GLOBAL SINGLE FOR it = 1 TO 2 GOSUB LoadDATFile IF Abort THEN EXIT FOR NEXT IF Abort THEN Abort = FALSE GOTO ReturnToDOS END IF IF CmdParkEffects$ = "Y" THEN GOSUB SetParkEffects 'Mark MM teams REDIM MMTeam(2) FOR it = 1 TO 2 IF MMx THEN IF FoundInMMList(DataFil(it)) THEN MMTeam(it) = TRUE END IF NEXT IF MMTeam(1) OR MMTeam(2) THEN IF SimGameCtr > 0 THEN CALL DrawFrm(19+rowO, 21+colO, 24+rowO, 63+colO, defattr, nulls$, nulls$, 0, 0, 1) xS$ = "The next game is 'Manually-Managed'." xS$ = SubDoubleQuote$ (xS$) QPRINTs 21+rowO, 23+colO, xS$, dimattr xS$ = "Hit 'Q' if you'd like to Quit now." xS$ = SubDoubleQuote$ (xS$) QPRINTs 22+rowO, 23+colO, xS$, dimattr xS$ = WAITKEY$ 'Quit before M-M game option IF UCASE$(xS$) = "Q" THEN IF CmdStat$ > "!" THEN GOSUB SaveStatsToDisk END IF IF MenuOpt$ = "S" THEN CALL SetSCHBookMark CALL UpdSCHRecord1 (" ") END IF GOTO QuickEnd END IF END IF END IF 'Get Starting Pitchers from pre-defined rotation CALL GetNextPitchers 'ipa(tm) <-- N 'AutoLineup FOR it = 1 TO 2 c = 0 IF MMx THEN 'Dont mess with lineups on MM teams IF MMTeam(it) = FALSE THEN IF AutoLineUpSw(it) THEN CALL AutoLineUp (it, c) END IF ELSE IF AutoLineUpSw(it) THEN CALL AutoLineUp (it, c) END IF LUAltered(it) = c NEXT 'DH & "Pitcher Hitting Stats" (if no DH) CALL SetDH 'Insert Platoon players CALL SetPlatoon 'Batting Order adjustment FOR it = 1 TO 2 IF AdjustBO(it) = "Y" OR AdjustBO(it) = "C" THEN IF MMx THEN 'Dont mess with lineups on MM teams IF MMTeam(it) = FALSE THEN IF AdjustBO(it) = "Y" OR _ (AdjustBO(it) = "C" AND LUAltered(it)) THEN CALL AdjustBattingOrder (it) END IF ELSE IF AdjustBO(it) = "Y" OR _ (AdjustBO(it) = "C" AND LUAltered(it)) THEN CALL AdjustBattingOrder (it) END IF END IF NEXT IF MMx THEN 'Checks for Manually Managed option FOR id = 1 TO 2 IF MMTeam(id) THEN MMGame = TRUE PCOPY 2, 1 'Opportunity to change starting pitcher! CALL DrawFrm(4+rowO, 10+colO, 21+rowO, 70+colO, defattr, "Manual Manage Options", nulls$, 1, 0, 1) QPRINTs 6+rowO, 12+colO, SchDate$, dimattr IF SimTotal THEN i = SimGameCtr + 1 x$ = " This is game " + STR$(i) + " of" + STR$(SimTotal) QPRINTs 6+rowO, 28+colO, x$, dimattr END IF 'Display Visitor on top : Home on botton IF id = 1 THEN row = 8+rowO ELSE row = 13+rowO p = ipa(id) xS$ = DataName(p, id) QPRINTs row, 12+colO, "Scheduled to start for YOUR " + RTRIM$(Names(id)) + ":", defattr QPRINTs row + 1, 15+colO, " W L ERA", defattr xF! = DataRBI(p, id) / 100 a$ = SPACE$(38) IF CmdStat$ > "!" AND DaysOffRule = TRUE THEN m = GetDaysOff (p, id) IF m THEN MID$(a$, 22, 1) = LFORMAT$(m, "#") END IF END IF MID$(a$, 1, 20) = FULLNAME$(xS$) MID$(a$, 24, 2) = DataHand(p, id) MID$(a$, 27, 2) = LFORMAT$(DataDef(p, id), "##") MID$(a$, 30, 2) = LFORMAT$(DataSB(p, id), "##") MID$(a$, 33, 5) = FFORMAT$(xF!, "#0.##") QPRINTs row + 2, 15+colO, a$, defattr CALL PitchersWLS (id, p, w, l, s, era!) a$ = SPACE$(38) MID$(a$, 27, 2) = LFORMAT$(w, "##") MID$(a$, 30, 2) = LFORMAT$(l, "##") MID$(a$, 33, 5) = FFORMAT$(era!, "#0.##") QPRINTs row + 3, 15+colO, a$ + " [SIM]", defattr IF row = 8+rowO THEN row = 13+rowO ELSE row = 8+rowO it = 3 - id p = ipa(it) xS$ = DataName(p, it) QPRINTs row, 12+colO, "Starting for " + RTRIM$(Names(it)) + ":", dimattr QPRINTs row + 1, 15+colO, " W L ERA", dimattr xF! = DataRBI(p, it) / 100 a$ = SPACE$(38) IF CmdStat$ > "!" AND DaysOffRule = TRUE THEN m = GetDaysOff (p, it) IF m THEN MID$(a$, 22, 1) = LFORMAT$(m, "#") END IF END IF MID$(a$, 1, 20) = FULLNAME$(xS$) MID$(a$, 24, 2) = DataHand(p, it) MID$(a$, 27, 2) = LFORMAT$(DataDef(p, it), "##") MID$(a$, 30, 2) = LFORMAT$(DataSB(p, it), "##") MID$(a$, 33, 5) = FFORMAT$(xF!, "#0.##") QPRINTs row + 2, 15+colO, a$, dimattr CALL PitchersWLS (it, p, w, l, s, era!) a$ = SPACE$(38) MID$(a$, 27, 2) = LFORMAT$(w, "##") MID$(a$, 30, 2) = LFORMAT$(l, "##") MID$(a$, 33, 5) = FFORMAT$(era!, "#0.##") QPRINTs row + 3, 15+colO, a$ + " [SIM]", dimattr QPRINTs 19+rowO, 12+colO, "Want to change your starting pitcher? [y/N]", defattr LOCATE 19+rowO, 56+colO IF YESorNO$(revfor, revbac, deffor, defbac, "N") = "Y" THEN DO CALL PickTheStarter(id, 4, N) '[N] LOOP WHILE N = 0 'you gotta pick one ipa(id) = N np(id) = 1 iyp(1, id) = N CALL AssignFatigue (id) CALL SetDH 'Sets Pitcher Hitting Stats also END IF 'Display Lineup and accept changes DO CALL Lineup(id, rv) CALL DefSwitchSetup (kc, Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) LOOP WHILE kc = KeyF3 IF FContents$(1) = "Y" THEN PCOPY 2, 1 CALL DefSwitch(4, id) END IF END IF 'END Found in MM List LOCATE 1, 1 CURSOR OFF NEXT 'Check both teams for Manually Managed option 'Opportunity to mess with opponent's lineup tm = 0 IF MMTeam(1) = TRUE AND MMTeam(2) = FALSE THEN tm = 2 IF MMTeam(2) = TRUE AND MMTeam(1) = FALSE THEN tm = 1 IF tm THEN CALL DrawFrm(11+rowO, 21+colO, 15+rowO, 65+colO, defattr, nulls$, nulls$, 0, 0, 0) QPRINTs 13+rowO, 23+colO, " Want to access your opponent's lineup? ", defattr LOCATE 13+rowO, 63+colO IF YESorNO$(7, 0, deffor, defbac, "N") = "Y" THEN 'Display Lineup and accept changes PCOPY 2, 1 DO CALL Lineup(tm, rv) CALL DefSwitchSetup (kc, Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) LOOP WHILE kc = KeyF3 IF FContents$(1) = "Y" THEN PCOPY 2, 1 CALL DefSwitch(4, tm) END IF END IF END IF 'Set switches for RegDsply and ForceCLS IF MMGame = FALSE THEN 'This game isn't an MM game, but we are in an MM Schedule 'WAS IF CmdDel = 0 AND etc. IF CmdPauseAftGame$ = "N" AND CmdPauseAftDate$ = "N" THEN RegDsply = FALSE ELSE RegDsply = TRUE END IF IF SaveMMGameStatus = TRUE THEN 'Must CLS if LAST game was MM SaveMMGameStatus = FALSE ForceCLS = TRUE END IF ELSE 'This game IS an Manually Managed schedule game RegDsply = TRUE ForceCLS = TRUE END IF END IF 'Save original lineups CALL SnapShot 'Prepare background photo (assigned in .DAT) IF (Gfx OR BitmapNRF) AND RegDsply THEN ' x$ = "Back: " + BackgroundPic$ + " Last: " + LastPic$ ' CALL ErrorBox (x$) IF (BackgroundPic$ <> LastPic$) OR MMGame THEN LastPic$ = BackgroundPic$ COLOR fldfor, fldbac CLS IF BackgroundPic$ > "!" THEN GOSUB GetPhotoSpecs GOSUB DefineBitmap END IF END IF GOTO StartUp END IF '--------- MANUAL / TWO-TEAM ---- 'New location Statistics Recording 'Options M and T '--------------------------- IF NOT CmdLine THEN PCOPY 2, 1 CALL StatRecordSetup (Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) CALL StatRecordIO (RetKey, Flds, 3, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) IF RetKey = KeyF3 THEN GOTO MenuOptions ELSE PCOPY 2, 1 END IF IF CmdStat$ > "!" THEN GOSUB OpenStatFiles END IF '-------------------------------- 'Load and sort list of .DAT files 'Options: Manual and Two-team '-------------------------------- REM QPRINTs 11, 42, " Loading file names... ", defattr r1 = ((ConsRows - 20) \ 5) + 1 'replaces 2 r2 = ConsRows - r1 'replaces 22 c1 = (ConsCols - 78) \ 2 'replaces 1 c2 = ConsCols - c1 'replaces 79 CmdSlotGames = 0 FileLimit = 1500 REDIM List1(1 TO FileLimit) AS List1Type GOSUB GetCurrentDir 'return CurrentDir$ tm = 0 RetKey = -97 ReadDirs: GOSUB LoadDirsToList1 'FOLDER Frame (right) IF RetKey = -97 THEN j = 0: c1$ = CHR$(193): c2$ = CHR$(194) ELSE j = 1: c1$ = CHR$(208): c2$ = CHR$(210) END IF IF tm = 0 THEN a$ = " Dbl-click (or Enter) VISITING TEAM " ELSE a$ = " Dbl-click (or Enter) HOME TEAM " END IF CALL DrawFrm(r1, c2-20, r2, c2, defattr, "Dbl-click folder", nulls$, 0, j, 0) QPRINTs MidRow-1, c2, c1$, defattr QPRINTs MidRow , c2, UpPtr$, defattr QPRINTs MidRow+1, c2, DnPtr$, defattr QPRINTs MidRow+2, c2, c2$, defattr 'FILENAME Frame (left) CALL DrawFrm(r1, c1, r2, c2-21, defattr, "[V]iew [E]dit [A]ux PgUp/PgDn", a$, 0, (1-j), 2) 'Change attributes for emphasis attr = CalcAttr(14, 1) 'Yellow on dark blue CALL ReadFromScreen (r2, 1, ConsCols, field$, " ", Valid$) ii = INSTR(field$, "VISIT") IF ii = 0 THEN ii = INSTR(field$, "HOME") IF ii THEN CALL ChangeAttribute (r2, ii, 13, attr) j = 1 - j IF j = 0 THEN c1$ = CHR$(193): c2$ = CHR$(194) ELSE c1$ = CHR$(208): c2$ = CHR$(210) END IF QPRINTs MidRow-1, c2-21, c1$, defattr QPRINTs MidRow , c2-21, UpPtr$, defattr QPRINTs MidRow+1, c2-21, DnPtr$, defattr QPRINTs MidRow+2, c2-21, c2$, defattr 'Fill FOLDER frame and instantly return (-97) or pick a directory CALL PickFromList(List1(), n, r2-r1-1, 1, 17, r1, c2-20, r2, c2, dimattr, revattr, Pick, RetKey, nulls$, mous, ms$) IF Pick > 0 THEN xS$ = RTRIM$(List1(Pick).ListItem) IF xS$ < "!" THEN GOTO ReadDirs IF LEFT$(xS$, 3) = "·Ž " THEN xS$ = MID$(xS$, 4) CHDIR xS$ CurrentDir$ = UCASE$(CURDIR$) IF RIGHT$(CurrentDir$, 1) <> "\" THEN CurrentDir$ = CurrentDir$ + "\" RetKey = -97 GOTO ReadDirs END IF RetKey = 0 'Fill FILENAME Frame Fil$ = CurrentDir$ + "*.DAT" n = 0 CALL LoadFilesToList1 (Fil$, List1(), FileLimit, n) ' [n] TeamsOnFile = n ARRAY SORT List1(1) FOR n, FROM 1 TO 12, ASCEND IF n = 1 THEN IF RTRIM$(List1(1).ListItem) = ".." OR _ RTRIM$(List1(1).ListItem) = "C:\" THEN TeamsOnFile = 0 END IF END IF DO DO CALL PickFromList(List1(), TeamsOnFile, r2-r1-1, 4, 12, r1, c1, r2, c2-21, dimattr, revattr, Pick, RetKey, nulls$, mous, ms$) CALL ExitPickForDAT(List1(), Pick, RetKey) LOOP WHILE RetKey = -99 IF RetKey = KeyF4 OR (mous AND RetKey = KeyEsc AND ms$ <> "—") THEN GOTO ReadDirs IF ms$ = "—" OR RetKey = KeyF3 OR RetKey = KeyEsc OR Pick = 0 THEN CHDIR HomeDir$ GOTO MenuOptions END IF INCR tm DataFil(tm) = RTRIM$(List1(Pick).ListItem) DATPath(tm) = CurrentDir$ IF tm = 1 THEN QPRINTs r2+2, c1+11, SPACE$(28), prmattr QPRINTs r2+2, c1+12, "Visiting Team: " + DataFil(tm) + " ", prmattr CALL ReadFromScreen (r2, 1, ConsCols, field$, " ", Valid$) ii = INSTR(field$, "VISIT") IF ii THEN QPRINTs r2, ii, "HOME TEAM ", defattr CALL ChangeAttribute (r2, ii, 9, attr) ELSE QPRINTs r2+2, c1+39, SPACE$(28), prmattr QPRINTs r2+2, c1+39, " Home Team: " + DataFil(tm), prmattr EXIT DO END IF LOOP CHDIR HomeDir$ '---------------------------------------- 'Load two selected files into team arrays 'Options M and T [manual command line enters here] '---------------------------------------- LoadManual: SavePath$ = CmdPath$ REDIM DLN(MAXPLAYERS, 2) AS GLOBAL LONG REDIM HBF!(2) REDIM HPF!(2) REDIM ParkBatAdj(2) AS GLOBAL SINGLE REDIM ParkPitAdj(2) AS GLOBAL SINGLE FOR it = 1 TO 2 IF DATPath(it) > "!" THEN CmdPath$ = DATPath(it) GOSUB LoadDATFile NEXT IF CmdParkEffects$ = "Y" THEN GOSUB SetParkEffects CmdPath$ = SavePath$ IF NOT CmdLine THEN QPRINTs r2, c1+9, STRING$(48, "Ö"), defattr END IF '--------------------------- 'Pick the starting pitchers: 'Options M and T '--------------------------- PickStarters: COLOR deffor, defbac FOR tm = 1 TO 2 IF MenuOpt$ = "M" THEN 'Manual IF tm = 1 THEN IF CmdVP$ = nulls$ THEN CALL PickTheStarter(tm, 2, N) ELSE N = VAL(CmdVP$) + 9 END IF END IF IF tm = 2 THEN IF CmdHP$ = nulls$ THEN CALL PickTheStarter(tm, 2, N) ELSE N = VAL(CmdHP$) + 9 END IF END IF ELSE PCOPY 2, 1 CALL TwoTeamStarters(tm, N) 'Two team CmdVP$ = nulls$ CmdHP$ = nulls$ END IF IF N = 0 THEN 'Back up - no selection made PCOPY 2, 1 GOTO LoadTeamFiles 'Clear arrays and re-load from disk END IF ipa(tm) = N np(tm) = 1 iyp(1, tm) = N CALL AssignFatigue (tm) NEXT IF NOT CmdLine THEN ERASE List1 'Don't need list of .DAT files any more '---------------------- 'Additional Settings 'Options M and T '---------------------- IF MenuOpt$ = "T" THEN PCOPY 2, 1 'set CmdSlotGames 'set Auto-Lineup for each team 'set CmdDH$ 'set CmdSpot$ row = 5 CALL TwoTeamSetup (row, Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) CALL TwoTeamIO (RetKey, Flds, 1, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) CmdSlotGames = VAL(FContents$(1)) AutoLineUpSw(1) = (FContents$(2) = "Y") AutoLineUpSw(2) = (FContents$(3) = "Y") AdjustBO(1) = FContents$(4) AdjustBO(2) = FContents$(5) CmdDH$ = FContents$(6) CmdSpot$ = FContents$(7) ELSE 'Manual: xS$ = DefaultDHResponse$ IF NOT CmdLine THEN CALL DrawFrm(13+rowO, 22+colO, 15+rowO, 56+colO, defattr, nulls$, nulls$, 1, 0, 0) QPRINTs 14+rowO, 23+colO, " Use Designated Hitter? [y/N] ", dimattr LOCATE 14+rowO, 53+colO CmdDH$ = YESorNO$(revfor, revbac, deffor, defbac, xS$) ELSE IF CmdDH$ = nulls$ THEN CmdDH$ = xS$ END IF COLOR deffor, defbac END IF '---- Original location of Statistics Recording 'Options M and T '---------------------------------------------- CALL SetDH CALL SetPlatoon '--------------------------------- 'Display Lineup and accept changes 'Options M and T '--------------------------------- FOR id = 1 TO 2 IF amgr(id) = 0 THEN IF (AutoLineUpSw(id) = 0) OR Force2TmLineup THEN COLOR 15, 3 'Get a sky-blue background PCOPY 2, 1 DO CALL Lineup(id, rv) CALL DefSwitchSetup (kc, Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) LOOP WHILE kc = KeyF3 IF FContents$(1) = "Y" THEN PCOPY 2, 1 CALL DefSwitch(4, id) END IF LOCATE 1, 1 CURSOR OFF END IF END IF NEXT IF MenuOpt$ = "M" OR MenuOpt$ = "T" THEN CALL SnapShot END IF IF MenuOpt$ = "T" THEN GOSUB SetAutoMgr SoundOn = FALSE PCOPY 2, 1 CALL MoreOptionsIO (6, Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) GOSUB Normalization ForceCLS = TRUE IF DelFac = 0 AND CmdPauseAftGame$ = "N" _ AND CmdPauseAftDate$ = "N" THEN RegDsply = FALSE ELSE RegDsply = TRUE END IF GOTO StartUp END IF '----------------------------------------------------- ' Final Ground Rules - questions to set up Manual Game ' Option M only '----------------------------------------------------- IF NOT CmdLine THEN DelFac = CmdDel IF DelFac < 2 THEN DelFac = 3 PCOPY 2, 1 CALL GroundRulesIO (Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) BackgroundPic$ = RTRIM$(FContents$(8)) Gfx = FALSE IF ConsRows <> 25 AND ConsCols <> 80 THEN IF BackgroundPic$ <> "--NONE--" AND BackgroundPic$ > "!" THEN IF amgr(1) = 0 OR amgr(2) = 0 THEN r = 17 + rowO c = 20 + colO QPRINTs r, c, " One moment please, stretching photograph... ", defattr END IF GOSUB GetPhotoSpecs 'sets Gfx to TRUE END IF END IF END IF GOSUB Normalization ForceCLS = TRUE RegDsply = TRUE GOSUB DefineBitmap IF amgr(1) AND amgr(2) THEN GOTO StartUp 'SetCmdWinData IF CmdLine THEN GOTO StartUp CALL DrawFrm(14+rowO, 7+colO, 22+rowO, 77+colO, defattr, nulls$, nulls$, 1, 0, 1) xS$ = "V" yS$ = "H" NewUI = TRUE r = 15 + rowO c = 9 + colO IF NOT amgr(1) AND NOT amgr(2) THEN QPRINTs r, c, "The computer is not managing either team.", defattr QPRINTs r+1, c, "Are there two players involved here?", defattr QPRINTs r+2, c, "[i.e., do you need to conceal your strategy?] [y/N] ", defattr LOCATE r+2, 61+colO IF YESorNO$(revfor, revbac, deffor, defbac, "N") = "Y" THEN DspSw = FALSE NewUI = FALSE xS$ = "S" yS$ = "5" END IF r = 18 + rowO END IF IF NOT amgr(1) THEN QPRINTs r, c, "Visiting team: Press " + CHR$(34) + xS$ + CHR$(34) + " to pop up Strategy window.", defattr INCR r END IF IF NOT amgr(2) THEN QPRINTs r, c, "Home team : Press " + CHR$(34) + yS$ + CHR$(34) + " to pop up Strategy window.", defattr INCR r END IF INCR r QPRINTs r, c, "Tip: Click on any empty area on the bottom row of screen to pitch.", defattr QPRINTs 22+rowO, 28+colO, " Hit/Click Any Key to BeginÇ", defattr COLOR deffor, defbac LOCATE 1, 1 CURSOR OFF PauseIt '---------------------------------------------------------- ' Game starts here ' Special Re-entry point for /N: (more games on same .sch/.ser card) '---------------------------------------------------------- StartUp: IF RegDsply AND Gfx THEN FOR n = 1 TO 32 CALL EliminateHole(n) NEXT END IF LL = 10 GameIsOver = FALSE Silence = FALSE GameRnd = FRND(10) REDIM SimDaysOff(10 TO TopPitLim, 2) AS GLOBAL LONG ' (We use this array both with and without stat files) IF CmdStat$ > "!" THEN REDIM SimGames(MAXPLAYERS, 2) AS GLOBAL LONG REDIM SimAB(MAXPLAYERS, 2) AS GLOBAL LONG REDIM SimHits(MAXPLAYERS, 2) AS GLOBAL LONG REDIM SimHR(MAXPLAYERS, 2) AS GLOBAL LONG REDIM SimRBI(MAXPLAYERS, 2) AS GLOBAL LONG REDIM SimBStreak(MAXPLAYERS, 2) AS GLOBAL LONG REDIM SimBB(MAXPLAYERS, 2) AS GLOBAL LONG REDIM SimSO(MAXPLAYERS, 2) AS GLOBAL LONG REDIM SimHitsAlw(10 TO TopPitLim, 2) AS GLOBAL LONG REDIM SimERuns(10 TO TopPitLim, 2) AS GLOBAL LONG REDIM SimWins(10 TO TopPitLim, 2) AS GLOBAL LONG REDIM SimLosses(10 TO TopPitLim, 2) AS GLOBAL LONG REDIM SimSaves(10 TO TopPitLim, 2) AS GLOBAL LONG REDIM SimBBAlw(10 TO TopPitLim, 2) AS GLOBAL LONG REDIM SimSO_P(10 TO TopPitLim, 2) AS GLOBAL LONG REDIM SimInn(10 TO TopPitLim, 2) AS GLOBAL SINGLE FOR tm = 1 TO 2 CALL LoadSimData (tm) NEXT END IF LL = 20 IF CmdStat$ > "!" AND STSOpen = FALSE THEN 'Re-Open #3 .STS OPEN CmdWritePath$ + CmdStat$ + ".STS" FOR RANDOM AS #3 LEN = LEN(SSum) n = LOF(3) / LEN(SSum) SEEK #3, n + 1 'position random file to append STSOpen = TRUE END IF IF MMx THEN SoundOn = FALSE DelFac = OrgSimDelFac FOR i = 1 TO 2 IF FoundInMMList(DataFil(i)) THEN amgr(i) = FALSE DelFac = CmdDel IF CmdSound$ <> "N" THEN SoundOn = TRUE END IF NEXT END IF IF RegDsply THEN COLOR fldfor, fldbac ELSE COLOR deffor, defbac DelFac = 0 END IF IF ForceCLS THEN CLS ForceCLS = FALSE CALL Prompt(0) IF RegDsply THEN it = 1: CALL ScoreBrd (TRUE, TRUE) ELSE ' CALL Prompt(0) 'experiment 2007 END IF IF CmdSlotGames THEN GOSUB PrintButtons IF RegDsply AND Gfx THEN CALL ShowGfx CALL UnfreezeAndRefresh END IF REDIM ibp(2) AS GLOBAL LONG inn = 1 AnthemPlayed = FALSE ErasedScbd = FALSE 'If 25x80 mode: 'Draw part of the defense that we may not ever need to draw again. IF RegDsply AND ConsRows = 25 AND ConsCols = 80 AND Gfx = FALSE THEN xS$ = CHR$(249) tr = MidRow + 5 r = tr: c = MidCol - 10: GOSUB PrintDOT r = tr: c = MidCol + 8: GOSUB PrintDOT r = tr+1: c = MidCol - 7: GOSUB PrintDOT r = tr+1: c = MidCol + 5: GOSUB PrintDOT IF CmdStat$ = nulls$ THEN r = tr+2: c = MidCol - 4: GOSUB PrintDOT r = tr+2: c = MidCol + 2: GOSUB PrintDOT END IF END IF 'Record starting positions for both sides in Games-by-Position FOR id = 1 TO 2 x$ = "~Lineup: " + Names(id) CALL AddToScoreCrd(0, 0, "X", x$) FOR p = 1 TO 9 ref = DataRef(p, id) ps = DataPos(p, id) IF ps <> 1 THEN GpPos(ref, id, ps) = 1 END IF 'Record starting lineups in scorecard CALL AddToScoreCrd(id, ref, "0", Pos(ps)) NEXT ref = ipa(id) GpPos(ref, id, 1) = 1 NEXT LL = 30 '---------------------------------- 'Top 1/2 of each inning begins here '---------------------------------- TopOfInning: 'Check if Visiting team wins IF inn > RegInns THEN IF itruns(1) > itruns(2) THEN inn = inn - 1 IF RegDsply AND Gfx THEN CALL UnfreezeAndRefresh END IF GOTO GameOver END IF END IF it = 1 DO WHILE it <= 2 'Switch sides 'Home team wins (no need to play last 1/2 inning) IF inn >= RegInns THEN IF itruns(2) > itruns(1) AND it = 2 THEN IF RegDsply AND Gfx THEN CALL UnfreezeAndRefresh END IF GOTO GameOver END IF END IF CurrentGamePoint = (inn * 10) + it PitcherBatted(it) = FALSE ResetHitter = FALSE SaveState = FALSE GOSUB ResetBatterCounters ANx = 0 innr = 0: innh = 0: inne = 0: innadverr = 0: iout = 0 ir1 = 0: ir2 = 0: ir3 = 0 innLOB = 0 REDIM mpp(9) AS GLOBAL LONG 'Reset which pitcher is responsible IF RegDsply THEN 'for each baserunner IF Gfx THEN GfxWindow NOT %GFX_FREEZE 'unfreeze CALL BatOrd CALL BasPat IF Gfx THEN GfxRefresh 0 'refresh (remain unfrozen) END IF IF inn < 11 THEN innct = inn ELSEIF inn > 10 AND inn < 21 THEN innct = inn - 10 ELSEIF inn > 20 THEN innct = inn - 20 END IF IF inn = 1 OR inn = 11 OR inn = 21 OR inn = 31 THEN IF it = 1 AND NOT ErasedScbd THEN ErasedScbd = TRUE REDIM iScoreBd(2, 10) AS GLOBAL LONG END IF ELSE ErasedScbd = FALSE END IF id = 3 - it 'Toggles defensive team from 1 to 2 or 2 to 1 ip = ipa(id) 'pointer to defensive team's current pitcher IF inn = 1 THEN IF iout = 0 THEN IF NUMBERON = 0 THEN CALL AddToScoreCrd (it, ip, "A", "[Starter] ") END IF END IF END IF 'Do we HAVE to have a new pitcher? (Did we pinch-hit/run for pitcher in the last 1/2 inning?) InvalidPit = FALSE NeedNewPitcher = FALSE i = 1 k = 0 ivp = 0 DO 'Scan defense for pitcher and his reference number IF DataPos(i, id) = 1 THEN INCR k 'Was he the last pitcher? LastRealPitcher$ = DataName(iyp(np(id), id), id) IF LastRealPitcher$ <> DataName(i, id) THEN IF amgr(id) = TRUE THEN 'Can the new guy pitch anyway? 'i.e. is DataName(i, id) found among the pitchers? SearchName$ = DataName(i, id) N = SearchDAT (10, LastPiAd(id), id, SearchName$, 0) IF N > 0 THEN 'Pitcher pinch-hitting for pitcher 'Always leave him in CALL Bullpen(N, id, N, 0) NeedNewPitcher = FALSE ivp = 0 ELSE 'No, he can't pitch ivp = i END IF ELSE ivp = i END IF InvalidPit = TRUE END IF END IF INCR i LOOP UNTIL i > 9 IF k > 1 THEN x$ = "More than one pitcher in batting order! " CALL ErrorBox (x$) END IF LL = 40 IF InvalidPit THEN IF ivp THEN NeedNewPitcher = TRUE COLOR deffor, defbac 'Found an invalid pitcher in slot number "ivp" IF amgr(id) = FALSE THEN CALL GetScreen(Scr1$, 10+rowO, 2+colO, 15+rowO, 78+colO) IF Gfx THEN CALL GraphHole (32, 10+rowO, 2+colO, 15+rowO, 78+colO) CALL DrawFrm(10+rowO, 2+colO, 15+rowO, 78+colO, defattr, nulls$, nulls$, 0, 0, 0) QPRINTs 11+rowO, 4+colO, "You have pinch hit/run for your pitcher.", defattr 'List positions he can play nn = 1 p$ = "" FOR nn = 1 TO 4 m = DataPosi(ivp, id, nn) IF m > 0 THEN IF nn = 1 THEN p$ = " [" ELSE p$ = p$ + "/" p$ = p$ + Pos(m) END IF NEXT IF LEN(p$) THEN p$ = p$ + "]" CALL CountAvPitchers(id, AvP, LastGuy) IF AvP > 0 THEN x$ = "Do you want " + LASTNAME$(DataName(ivp, id)) + p$ + " to remain in the game? [y/N] " QPRINTs 12+rowO, 4+colO, x$, defattr LOCATE 12+rowO, 4+colO+LEN(x$) xS$ = YESorNO$(revfor, revbac, deffor, defbac, "N") ELSE x$ = LASTNAME$(DataName(ivp, id)) + " will remain in the game. " QPRINTs 12+rowO, 4+colO, x$, defattr xS$ = "Y" SLEEP 2500 END IF ELSE xS$ = "N" 'SBS Manager END IF IF xS$ = "Y" THEN 'Does name in pitcher's slot correspond to an actual pitcher? 'If so, this is a pitcher pinch-hitting for another pitcher. SearchName$ = DataName(ivp, id) N = SearchDAT (10, LastPiAd(id), id, SearchName$, 0) IF N THEN 'Pitcher pinch-hitting for pitcher NeedNewPitcher = FALSE QPRINTs 13+rowO, 4+colO, "This player will be the new pitcher.", defattr SLEEP 2500 CALL Bullpen(N, id, N, 0) ELSE 'Non-pitcher pinch-hitting for pitcher DO QPRINTs 13+rowO, 4+colO, "At which position? ", defattr QPRINTs 14+rowO, 4+colO, "Enter a position: C 1B 2B SS 3B LF CF RF ", defattr yS$ = MYINPUT$(FALSE, KeyEscape, CustomEscKey, KeyAccept, kc, revfor, revbac, 14+rowO, 49+colO, 2, "XR", 0, 0, nulls$, msx, msy) '(we don't really want to support the mouse on this one) COLOR deffor, defbac yS$ = UCASE$(yS$) IF yS$ = " C" THEN yS$ = "C " IF yS$ = " P" THEN yS$ = "P " j = 1 DO UNTIL j > 9 IF Pos(j) = yS$ AND yS$ <> "P " THEN EXIT DO INCR j LOOP LOOP WHILE j > 9 'We want the pinch-hitter to stay in and play 'defensive position "j" 'What slot is THAT in the line-up? k = 1 DO UNTIL k > 9 'Scan defense for defensive position j IF DataPos(k, id) = j THEN EXIT DO INCR k LOOP 'Well, the guy in slot "k" is playing position "j" yS$ = "** " + FLASTNAME$(ivp, id) + " stays in at " + Pos(j) CALL AddToScoreCrd(0, 0, "X", yS$) yS$ = "** for " + FLASTNAME$(k, id) CALL AddToScoreCrd(0, 0, "X", yS$) IF k < 10 THEN SWAP DataPos(ivp, id), DataPos(k, id) END IF END IF IF amgr(id) = FALSE THEN IF WarmUpRule AND NeedNewPitcher THEN 'Check if anybody's warm N = 0 FOR i = 10 TO LastPiAd(id) IF WarmUpStatus(i, id) > 0 AND _ iused(i, id) = 0 AND _ i <> iyp(np(id), id) THEN N = -1 'Debug: ' x$ = "Last Real Pitcher=" + STR$( iyp(np(id),id) ) + "|" ' x$ = x$ + "i=" + STR$(i) + "|" ' x$ = x$ + "WarmUpStatus(i, id)=" + STR$( WarmUpStatus(i,id) ) + "|" ' x$ = x$ + "iused(i, id)=" + STR$( iused(i, id) ) + "|" ' x$ = x$ + DataName(i, id) ' CALL ErrorBox (x$) EXIT FOR END IF NEXT IF N = 0 THEN 'Emergency - this shouldn't happen, but just in case... 'Happens if pitcher is replaced by clone-pitcher who is then replaced before clone-pitcher 'actually pitches. 'I.E. Pinch-hit or pinch-run for pitcher w/clone-pitcher and then replace clone-pitcher 'before 1/2 inning ends FOR i = 10 TO LastPiAd(id) IF iused(i, id) = 0 THEN WarmUpStatus(i, id) = 1 NEXT END IF END IF CALL PutScreen(Scr1$, 10+rowO, 2+colO, 15+rowO, 78+colO) IF Gfx THEN CALL EliminateHole(32) GfxRefresh 0 END IF END IF 'Must select a pitcher IF NeedNewPitcher THEN CALL ClearInpBuffer N = 0 DO CALL Bullpen(N, id, 0, 0) IF N = 0 AND amgr(id) = TRUE THEN 'AutoManager ran out of pitchers! x$ = "AutoManager is out of pitchers!" CALL ErrorBox (x$) END IF LOOP UNTIL N IF Gfx THEN GfxRefresh 0 'refresh (remain unfrozen) 'Option for player to double-switch IF amgr(id) = FALSE AND dh = 0 THEN HotBull = TRUE END IF END IF LineUpChangeDef = TRUE GpPos(N, id, 1) = 1 CALL AddToScoreCrd (it, N, "A", "[Relief] ") IF amgr(id) = FALSE THEN COLOR fldfor, fldbac IF NOT Gfx THEN CLS CALL ScoreBrd (TRUE, TRUE) CALL BatOrd 'Reset color to field CALL Prompt(0) ELSE 'TEST IF RegDsply THEN CALL BatOrd END IF END IF END IF 'InvalidPitcher 'Draw the Defense ip = ipa(id) IF RegDsply THEN CALL Defens(60) 'still unfrozen IF Gfx THEN CALL EliminateHole(6) 'reset stat holes CALL EliminateHole(7) GfxRefresh 0 'refresh ELSE IF ConsRows > 27 AND ConsCols > 83 THEN 'non-graphics xS$ = SPACE$(41) QPRINTs 9, 2, xS$, fldattr QPRINTs 10, 2, xS$, fldattr QPRINTs 11, 2, xS$, fldattr QPRINTs 9, ConsCols - 41, xS$, fldattr QPRINTs 10, ConsCols - 41, xS$, fldattr QPRINTs 11, ConsCols - 41, xS$, fldattr END IF END IF 'Display Year/League Normalization IF CmdEra$ > "!" THEN IF CmdEra$ <> "N" THEN GOSUB PrintERA END IF END IF END IF 'Play National Anthem if you haven't already IF inn = 1 AND it = 1 THEN IF RegDsply THEN CALL ScoreBrd (TRUE, TRUE) 'Messes up first line of graphic box IF Gfx THEN GfxRefresh 0 GfxWindow %GFX_FREEZE END IF DrawSBFrame = FALSE GenerateAllSB = FALSE IF NOT AnthemPlayed THEN IF DelFac THEN IF SoundOn THEN AddToAnnouncer it, "Our National Anthem..." ELSE AddToAnnouncer it, "We're set for the first pitch..." CALL PostAnnouncer (FALSE) SLEEP 1500 END IF CALL PostAnnouncer (FALSE) END IF IF DelFac > 0 AND SoundOn THEN 'Save screen area and print message IF Gfx THEN CALL GraphHole(30, ConsRows-2, 24+colO, ConsRows-2, 59+colO) CALL GetScreen(Scr1$, ConsRows-2, 24+colO, ConsRows-2, 59+colO) QPRINTs ConsRows-2, 24+colO, "Click or hit any key to continue...", errattr IF CANADA(Names(1)) AND CANADA(Names(2)) THEN 'Play O-Canada MCISendString "open type midiaudio", BYVAL 0, 0, 0 MCISendString PlayCAN, BYVAL 0, 0, 0 x$ = WAITKEY$ MCISendString STOPCAN, BYVAL 0, 0, 0 MCISendString "CLOSE type midiaudio", BYVAL 0, 0, 0 ELSEIF CANADA(Names(1)) AND NOT CANADA(Names(2)) THEN 'Play O-Canada MCISendString "open type midiaudio", BYVAL 0, 0, 0 MCISendString PlayCAN, BYVAL 0, 0, 0 x$ = WAITKEY$ MCISendString StopCAN, BYVAL 0, 0, 0 MCISendString "CLOSE type midiaudio", BYVAL 0, 0, 0 'Play SSB MCISendString "open type midiaudio", BYVAL 0, 0, 0 MCISendString PlayUSA, BYVAL 0, 0, 0 x$ = WAITKEY$ MCISendString StopUSA, BYVAL 0, 0, 0 MCISendString "CLOSE type midiaudio", BYVAL 0, 0, 0 ELSEIF NOT CANADA(Names(1)) AND CANADA(Names(2)) THEN 'Play SSB MCISendString "open type midiaudio", BYVAL 0, 0, 0 MCISendString PlayUSA, BYVAL 0, 0, 0 x$ = WAITKEY$ MCISendString StopUSA, BYVAL 0, 0, 0 MCISendString "CLOSE type midiaudio", BYVAL 0, 0, 0 'Play O-Canada MCISendString "open type midiaudio", BYVAL 0, 0, 0 MCISendString PlayCAN, BYVAL 0, 0, 0 x$ = WAITKEY$ MCISendString StopCAN, BYVAL 0, 0, 0 MCISendString "CLOSE type midiaudio", BYVAL 0, 0, 0 ELSE 'Play SSB MCISendString "open type midiaudio", BYVAL 0, 0, 0 MCISendString PlayUSA, BYVAL 0, 0, 0 x$ = WAITKEY$ MCISendString StopUSA, BYVAL 0, 0, 0 MCISendString "CLOSE type midiaudio", BYVAL 0, 0, 0 END IF 'Restore screen area CALL PutScreen(Scr1$, ConsRows-2, 24+colO, ConsRows-2, 59+colO) IF Gfx THEN CALL EliminateHole(30) CALL UnfreezeAndRefresh END IF END IF END IF AnthemPlayed = TRUE IF SoundOn AND DelFac > 0 THEN SLEEP 1000: L = PlayWav("4540.wav") 'Play Ball! END IF END IF IF InvalidPit AND RegDsply AND DelFac > 0 THEN ANx = 0 CALL AddToAnnouncer (id, "Now pitching for '" + RTRIM$(Names(id)) + ":") CALL Msg ("29", "0", "0", "13", ip, id, man2, team2) CALL PostAnnouncer (FALSE) SLEEP DelFac * 1800 END IF 'Display note if a def. player is out of position IF RegDsply AND DelFac > 0 THEN CALL DefCheck (OutOfPositionMsg) LL = 50 NextHitter: IF DelFac = 0 THEN SoundOn = FALSE 'New location: 3/27/00 'Check for sudden victory for home team IF inn >= RegInns AND itruns(2) > itruns(1) AND it = 2 THEN GOTO GameOver IF iout > 2 THEN IF ir1 THEN innLOB = innLOB + 1 IF ir2 THEN innLOB = innLOB + 1 IF ir3 THEN innLOB = innLOB + 1 GameLOB(it) = GameLOB(it) + innLOB IF RegDsply AND DelFac > 0 THEN IF Gfx THEN CALL GraphHole(5, 7+rowO, 30+colO, 19+rowO, 52+colO) CALL GetScreen(Scr3$, 7+rowO, 30+colO, 19+rowO, 52+colO) '7 30 19 53 CALL DrawFrm(7+rowO, 30+colO, 19+rowO, 52+colO, defattr, "Inning Summary", nulls$, 0, 0, 0) CALL Innsum (9+rowO, 34+colO) SLEEP 2500 CALL PutScreen(Scr3$, 7+rowO, 30+colO, 19+rowO, 52+colO) '7 30 19 53 IF Gfx THEN CALL EliminateHole(5) CALL UnfreezeAndRefresh END IF END IF GOTO SwitchSides END IF 'Bump up current hitter pointer INCR ibp(it) IF ibp(it) = 10 THEN ibp(it) = 1 IF it = 1 THEN k = 3 ELSE k = ConsCols - 16 IF RegDsply AND DelFac > 0 THEN 'change color attr in batting order tr = ConsRows - 12 leng = 15 CALL ChangeAttribute (ibp(it) + tr, k, leng, scdattr) 'grey on black 'Restore last guy to regular color attribute IF ibp(it) = 1 THEN CALL ChangeAttribute (ConsRows-3, k, leng, revattr) 'black on grey ELSE CALL ChangeAttribute (ibp(it) + tr - 1, k, leng, revattr) END IF END IF ib = ibp(it) IF SaveState = FALSE THEN Tight = FALSE ExtraTalk = FALSE IGone = FALSE Errorx = FALSE DPsw = FALSE OutFErr = FALSE OneBaseError = FALSE ThrowError = FALSE RunsBeforePlay = itruns(it) LL = 60 AnnounceHitter: GOSUB PrintStats IF RegDsply = FALSE THEN GOTO ResetPlaySwitches 'Announce hitter, pause for keyboard input 'Throw in some box score history BLN$ = LASTNAME$(DataName(ib, it)) IF NOT ExtraTalk THEN ANx = 0 ref = DataRef(ib, it) 'hitter's reference number for box 'Do not change "ref" after this point! IF DelFac > 0 OR amgr(1) = 0 OR amgr(2) = 0 THEN IF ResetHitter THEN 'Back from SB or POut CALL AddToAnnouncer(it, BLN$ + " steps back in...") GOTO DisplayScoreBrd ELSE CALL Msg ("01", "0", "0", "00", ib, it, man2, team2) END IF IF ExtraTalk THEN GOTO DisplayScoreBrd IF mab(ref, it) > 0 THEN IF mhits(ref, it) = 0 AND mab(ref, it) > 2 THEN CALL AddToAnnouncer(it, BLN$ + "'s hitless in" + STR$(mab(ref, it)) + " tries.") ELSE xS$ = BLN$ + "'s" + STR$(mhits(ref, it)) + " for" + STR$(mab(ref, it)) IF mrbi(ref, it) = 1 THEN xS$ = xS$ + " with an RBI." ELSEIF mrbi(ref, it) > 1 THEN xS$ = xS$ + " with" + STR$(mrbi(ref, it)) + " RBI's!" ELSE xS$ = xS$ + "." END IF AddToAnnouncer it, xS$ END IF IF mhr(ref, it) = 1 THEN IF RND < .5 THEN xS$ = "And a Home Run!" ELSE xS$ = "Including a Homer!" AddToAnnouncer it, xS$ ELSEIF mhr(ref, it) > 1 THEN xS$ = "And" + STR$(mhr(ref, it)) + " Home Runs!" AddToAnnouncer it, xS$ END IF ELSEIF CmdStat$ > "!" THEN 'a stat file exists IF SimBStreak(ref, it) > 3 THEN xS$ = STR$(SimBStreak(ref, it)) CALL AddToAnnouncer (it, "He's got a" + xS$ + "-game Hitting Streak.") END IF END IF END IF LL = 80 DisplayScoreBrd: CALL PostAnnouncer (FALSE) CALL ScoreBrd (DrawSBFrame, GenerateALLSB) 'Usually does not erase announcer IF DelFac THEN IF ExtraTalk THEN SLEEP 500 'a little extra time to read stuff END IF ANx = 0 GOSUB BatterOnScreen IF Gfx THEN CALL UnfreezeAndRefresh END IF LL = 90 ResetPlaySwitches: 'RegDsply either way ref = DataRef(ib, it) 'hitter's reference number 'don't change after this point! OldColorScheme = ColorScheme WhoAtPos = 0 OrgWhoAtPos = 0 ref2 = 0 ExtraTalk = FALSE RunAnnounced = FALSE Boxx = FALSE Help = FALSE ScoreCard = FALSE ResetHitter = FALSE IWalk = FALSE BullD = FALSE BullO = FALSE Subx = FALSE SwPos = FALSE PH = FALSE PRun = FALSE IF SaveState = FALSE THEN POut = FALSE PAround = FALSE Bunt = FALSE Steal = FALSE HitAndRun = FALSE END IF SavPOut = POut SavPAround = PAround SavBunt = Bunt SavSteal = Steal SavHitAndRun = HitAndRun LL = 100 ScanInput: ViewHome = FALSE ViewVisi = FALSE 'Check if "O" has been pressed (for Options) IF amgr(1) AND amgr(2) THEN 'Don't know which display we're on a$ = INKEY$ IF LEN(a$) = 0 THEN IF DelFac THEN SLEEP DelFac * 1000 GOTO AutoManage END IF IF LEN(a$) = 4 THEN msx = MOUSEX msy = MOUSEY IF msy = ConsRows THEN a$ = CHR$(SCREEN(msy, msx)) CALL FlashField (msy, msx, 1, 2, 100, 0) ELSE a$ = nulls$ END IF ELSE a$ = UCASE$(a$) msx = 0 msy = 0 END IF 'We have a key pressed. 'Both teams are auto-managed. 'We do not know what the "delay" is. OldDelFac = DelFac IF a$ = "O" AND CmdNoOpt$ <> "Y" THEN CALL OptionSetup (row, Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) CALL GetScreen(Scr1$, 7+rowO, 22+colO, Flds+8+rowO,54+colO) IF Gfx AND RegDsply THEN CALL GraphHole(30, 7+rowO, 22+colO, Flds+8+rowO, 54+colO) CALL DrawFrm(7+rowO, 22+colO, Flds+8+rowO, 54+colO, defattr, "Options", "ESC (or close) to Exit", 0, 0, 1) CALL OptionWindow (Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) IF Gfx AND RegDsply THEN CALL EliminateHole(30) CALL PutScreen(Scr1$, 7+rowO, 22+colO, Flds+8+rowO,54+colO) IF Gfx AND RegDsply THEN CALL UnfreezeAndRefresh LOCATE 1, 1 CURSOR OFF 'hide the cursor somewhere ELSEIF a$ = "R" THEN IF WLx > 0 THEN IF Gfx AND RegDsply THEN CALL HideGfx QPush COLOR deffor, defbac CLS CALL ShowStandings (TRUE) QPop IF Gfx AND RegDsply THEN CALL ShowGfx END IF ELSEIF a$ = "B" THEN CALL Box IF Gfx AND RegDsply THEN CALL HideGfx QPush CALL ListFile(CmdWritePath$ + "~BOX.PRN") QPop IF Gfx AND RegDsply THEN CALL ShowGfx ELSEIF a$ = "C" THEN QPush GOSUB ShowScoreCard QPop IF Gfx AND RegDsply THEN CALL UnfreezeAndRefresh ELSEIF a$ = "Q" AND CmdNoOpt$ <> "Y" THEN GOSUB CheckForQuit ELSEIF a$ = "T" THEN 'Toggle IF DelFac = 0 THEN IF RegDsply = TRUE AND (CmdPauseAftGame$ = "Y" OR CmdPauseAftDate$ = "Y") THEN 'Can't switch to Standings Mode if PauseAfterGame=Y CALL PopMsg(18+rowO, 12+colO, "Can't switch to Standings Mode if either 'PauseAfter' = Y", errattr, 0, kc) ELSE RegDsply = NOT RegDsply IF RegDsply = FALSE THEN 'Switch to Standings IF BitmapNRF THEN Gfx = TRUE IF Gfx THEN CALL HideGfx COLOR deffor, defbac CLS CALL ShowStandings (FALSE) CALL Prompt(0) ELSE 'Switch to Field 'Prepare background photo (assigned in .DAT) IF Gfx THEN IF MenuOpt$ = "S" OR MenuOpt$ = "E" OR MenuOpt$ = "T" THEN COLOR fldfor, fldbac CLS ' QPRINTs 12+rowO, 28+colO, "Generating Background...", defattr IF BackgroundPic$ > "!" THEN GOSUB GetPhotoSpecs GOSUB DefineBitmap END IF END IF 'Redraw entire screen GOSUB RebuildFieldScreen END IF END IF END IF END IF 'We changed from zero-delay to delay in "O" IF (DelFac > 0 AND OldDelFac = 0) OR _ (RegDsply = FALSE AND CmdPauseAftGame$ = "Y") OR _ (RegDsply = FALSE AND CmdPauseAftDate$ = "Y") THEN RegDsply = TRUE GOSUB RebuildFieldScreen END IF 'Allow change of field color scheme IF ColorScheme <> OldColorScheme THEN OldColorScheme = ColorScheme CALL SetColors(ColorScheme) IF RegDsply THEN GOSUB RebuildFieldScreen END IF 'Allow change of background photo IF RegDsply = TRUE AND CmdChangePhoto$ = "Y" THEN GOSUB ChangePhotoManually ' IF amgr(1) AND amgr(2) THEN ' CALL Prompt(0) 'experiment 2007 ' IF DelFac THEN SLEEP DelFac * 800 ' GOTO AutoManage ' ELSE ' CALL Prompt(0) ' END IF IF DelFac THEN SLEEP DelFac * 800 GOTO AutoManage END IF ' IF NOT amgr(1) OR NOT amgr(2) THEN 'experiment 2007 ' CALL ChangeAttribute(ConsRows, 2, 3, prmattr) ' END IF CALL ChangeAttribute(ConsRows, 2, 3, prmattr) 'Function to clear keyboard and mouse buffer here CALL ClearInpBuffer VisiPtr = 1 HomePtr = 1 VisiPopped = FALSE HomePopped = FALSE HomeReady = (NOT amgr(1) AND amgr(2)) VisiReady = (NOT amgr(2) AND amgr(1)) StatLine = FALSE DO UNTIL (VisiReady AND HomeReady) IF Gfx THEN CALL UnfreezeAndRefresh END IF IF HomePopped = FALSE AND VisiPopped = FALSE AND StatLine = FALSE THEN SLEEP 70 CALL FlashField (ConsRows, 2, 3, 4, 100, 0) END IF IF StatLine = TRUE THEN StatLine = FALSE ELSE a$ = WAITKEY$ END IF IF LEN(a$) = 4 THEN msx = MOUSEX msy = MOUSEY IF msy = ConsRows THEN a$ = CHR$(SCREEN(msy, msx)) CALL FlashField (msy, msx, 1, 2, 100, 0) ELSE a$ = nulls$ 'Batting order box borders 'Left b1r1 = ConsRows - 12 b1c1 = 2 b1r2 = b1r1 + 10 b1c2 = 18 'Right b2r1 = ConsRows - 12 b2c1 = ConsCols - 17 b2r2 = b2r1 + 10 b2c2 = ConsCols - 1 'Is click inside a lineup box? 'Figure out which player IF Inbox(b1r1, b1c1, b1r2, b1c2, msy, msx, 0) THEN StatLine = TRUE p = msy - b1r1 tm = 1 CALL FlashField (msy, 3, 15, 2, 100, 0) ELSEIF Inbox(b2r1, b2c1, b2r2, b2c2, msy, msx, 0) THEN StatLine = TRUE p = msy - b1r1 tm = 2 CALL FlashField (msy, b2c1+1, 15, 2, 100, 0) END IF IF StatLine THEN sr1 = 8 + rowO sc1 = 9 + colO sr2 = 14 + rowO sc2 = 72 + colO IF CmdStat$ > "!" THEN sr2 = sr2 + 7 'Save screen area CALL GetScreen(Scr4$, sr1, sc1, sr2+1, sc2+2) IF Gfx THEN CALL GraphHole(30, sr1, sc1, sr2+1, sc2+2) 'Build and display stat line CALL DrawFrm(sr1, sc1, sr2, sc2, defattr, DataName(p,tm), "", 1, 0, 0) QPRINTs sr1+2, sc1+26, ".DAT File", defattr x$ = " Avg G AB Hit 2B 3B HR RBI BB SO S SB CS" QPRINTs sr1+3, sc1+2, x$, defattr IF DataAB(p, tm) = 0 THEN BAF! = 0 ELSE BAF! = DataHits(p, tm) / DataAB(p, tm) END IF a$ = SPACE$(58) MID$(a$, 1, 4) = FFORMAT$(BAF!, ".###") MID$(a$, 6, 4) = LFORMAT$(DataGames(p, tm), "####") MID$(a$, 11, 5) = LFORMAT$(DataAB(p, tm), "#####") MID$(a$, 17, 4) = LFORMAT$(DataHits(p, tm), "####") MID$(a$, 22, 4) = LFORMAT$(Data2B(p, tm), "####") MID$(a$, 27, 3) = LFORMAT$(Data3B(p, tm), "###") MID$(a$, 31, 3) = LFORMAT$(DataHR(p, tm), "###") MID$(a$, 35, 4) = LFORMAT$(DataRBI(p, tm), "####") MID$(a$, 40, 4) = LFORMAT$(DataBB(p, tm), "####") MID$(a$, 45, 4) = LFORMAT$(DataSO(p, tm), "####") MID$(a$, 50, 1) = LFORMAT$(DataSpeed(p, tm), "#") MID$(a$, 52, 3) = LFORMAT$(DataSB(p, tm), "###") MID$(a$, 56, 3) = LFORMAT$(DataCS(p, tm), "###") QPRINTs sr1+4, sc1+2, a$, dimattr 'Sim Data IF CmdStat$ > "!" THEN rf = DataRef(p, tm) Find$ = League(tm) + PADRIGHT$(Names(tm), 12) + PADRIGHT$(NameRef(rf, tm), 16) TotalRecs = BSum(0).BGameCtr FA = 0 CALL BinarySearchB (BSum(), 1, 29, 1, TotalRecs, Find$, FA, mini) IF FA THEN QPRINTs sr1+6, sc1+26, "Sim Stats", defattr x$ = " Avg G AB Hit 2B 3B HR RBI BB SO SB CS" QPRINTs sr1+7, sc1+2, x$, defattr SiAB = BSum(FA).BABs + mab(rf, tm) SiH = BSum(FA).BHits + mhits(rf, tm) IF SiAB > 0 THEN BASF! = SiH / SiAB IF BASF! > .999 THEN BASF! = .999 ELSE BASF! = 0 END IF a$ = SPACE$(58) MID$(a$, 1, 4) = FFORMAT$(BASF!, ".###") MID$(a$, 6, 4) = LFORMAT$(BSum(FA).BGames + 1, "####") MID$(a$, 11, 5) = LFORMAT$(SiAB, "#####") MID$(a$, 17, 4) = LFORMAT$(SiH, "####") MID$(a$, 22, 4) = LFORMAT$(BSum(FA).B2Bs + m2b(rf, tm), "####") MID$(a$, 27, 3) = LFORMAT$(BSum(FA).B3Bs + m3b(rf, tm), "###") MID$(a$, 31, 3) = LFORMAT$(BSum(FA).BHRs + mhr(rf, tm), "###") MID$(a$, 35, 4) = LFORMAT$(BSum(FA).BRBIs + mrbi(rf, tm), "####") MID$(a$, 40, 4) = LFORMAT$(BSum(FA).BBBs + mbb(rf, tm), "####") MID$(a$, 45, 4) = LFORMAT$(BSum(FA).BKs + mso(rf, tm), "####") MID$(a$, 52, 3) = LFORMAT$(BSum(FA).BSBs + msb(rf, tm), "###") MID$(a$, 56, 3) = LFORMAT$(BSum(FA).BCSs + mcs(rf, tm), "###") QPRINTs sr1+8, sc1+2, a$, dimattr 'Expanded individual batting statistics TB = BSum(FA).BHits + BSum(FA).B2Bs + 2 * BSum(FA).B3Bs + 3 * BSum(FA).BHRs IF BSum(FA).BABs > 0 THEN OnBase! = (BSum(FA).BBBs + BSum(FA).BHB + BSum(FA).BHits) / _ (BSum(FA).BBBs + BSum(FA).BHB + BSum(FA).BABs) ELSE OnBase! = 0.0 END IF IF BSum(FA).BABs > 0 THEN Slug! = TB / BSum(FA).BABs ELSE Slug! = 0.0 END IF IF BSum(FA).BABs > 0 THEN HRPct! = BSum(FA).BHRs / BSum(FA).BABs * 100 ELSE HRPct! = 0.0 END IF Prod! = OnBase! + Slug! IF (BSum(FA).BCSs + BSum(FA).BABs - BSum(FA).BHits) > 0 THEN TotAvg! = (TB + BSum(FA).BSBs + BSum(FA).BBBs + BSum(FA).BHB) / _ (BSum(FA).BCSs + BSum(FA).BABs - BSum(FA).BHits) ELSE TotAvg! = 0.0 END IF rc27! = RunsCreated27!((BSum(FA).BABs), (BSum(FA).BHits), (BSum(FA).B2Bs),_ (BSum(FA).B3Bs), (BSum(FA).BHRs), (BSum(FA).BBBs), (BSum(FA).BHB), _ (BSum(FA).BSacB), (BSum(FA).BSacF), (BSum(FA).BSBs), _ (BSum(FA).BCSs), (BSum(FA).BGDP)) x$ = " TB SH SF HB GIDP OB SLG HR% OPS TAvg RC/27" QPRINTs sr1+10, sc1+2, x$, defattr a$ = SPACE$(60) MID$(a$, 1, 5) = LFORMAT$(TB, "#####") MID$(a$, 7, 4) = LFORMAT$(BSum(FA).BSacB, "####") MID$(a$, 12, 4) = LFORMAT$(BSum(FA).BSacF, "####") MID$(a$, 17, 4) = LFORMAT$(BSum(FA).BHB, "####") MID$(a$, 22, 4) = LFORMAT$(BSum(FA).BGDP, "####") MID$(a$, 27, 5) = FFORMAT$(OnBase!, "#.###") MID$(a$, 33, 5) = FFORMAT$(Slug!, "#.###") MID$(a$, 39, 4) = FFORMAT$(HRPct!, "#0.#") MID$(a$, 44, 5) = FFORMAT$(Prod!, "#.###") MID$(a$, 50, 5) = FFORMAT$(TotAvg!, "#.###") MID$(a$, 56, 5) = FFORMAT$(rc27!, "##.##") QPRINTs sr1+11, sc1+2, a$, dimattr END IF END IF a$ = WAITKEY$ 'Clean up mess CALL PutScreen(Scr4$, sr1, sc1, sr2+1, sc2+2) IF Gfx THEN CALL EliminateHole(30) ITERATE DO END IF 'Click was inside batting order box END IF 'Click was not on last row ELSE 'No click 'Keyboard input a$ = UCASE$(a$) msx = 0 msy = 0 END IF IF a$ = "B" THEN Boxx = TRUE: EXIT DO IF a$ = "D" AND VisiPopped = FALSE THEN Help = TRUE: EXIT DO IF a$ = "C" THEN ScoreCard = TRUE: EXIT DO 'Force specific outcomes for testing purposes: 'Ground ball: ' IF a$ = "G" THEN ' COLOR fldfor, fldbac ' fr7 = 100 ' fr7 = 201 'shallow fly ' CALL OutOrError ' fr7 = 0 ' GOTO WRAPUPTHISAB ' END IF 'Wild Pitch: ' IF a$ = "T" THEN COLOR fldfor, fldbac: GOTO WildPitch 'Home Run: ' IF a$ = "H" THEN ' fr7 = 404 ' a$ = CHR$(13) ' END IF 'Single: ' IF a$ = "1" THEN ' fr7 = 401 ' a$ = CHR$(13) ' END IF IF a$ = "Q" AND CmdNoOpt$ <> "Y" THEN IF VisiPopped THEN 'check UI? CALL PutScreen(Scr1$, 10+rowO, 8+colO, 21+rowO, 40+colO) VisiPopped = FALSE END IF IF HomePopped THEN CALL PutScreen(Scr2$, 10+rowO, 42+colO, 21+rowO, 74+colO) HomePopped = FALSE END IF GOSUB CheckForQuit GOTO AnnounceHitter END IF IF a$ = CHR$(13) OR a$ = CHR$(32) OR a$ = CHR$(17) OR a$ = CHR$(196) _ OR a$ = CHR$(217) THEN IF VisiPopped = FALSE AND HomePopped = FALSE THEN EXIT DO END IF END IF IF a$ = "O" AND CmdNoOpt$ <> "Y" THEN IF VisiPopped = FALSE AND HomePopped = FALSE THEN CALL OptionSetup (row, Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) CALL GetScreen(Scr3$, 7+rowO, 22+colO, Flds+8+rowO, 54+colO) IF Gfx THEN CALL GraphHole(30, 7+rowO, 22+colO, Flds+8+rowO, 54+colO) CALL DrawFrm(7+rowO, 22+colO, Flds+8+rowO, 54+colO, defattr, "Options", "ESC to Exit", 0, 0, 1) CALL OptionWindow(Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) CALL PutScreen(Scr3$, 7+rowO, 22+colO, Flds+8+rowO, 54+colO) IF Gfx THEN CALL EliminateHole(30) CALL UnfreezeAndRefresh END IF CALL Prompt(0) IF amgr(1) AND amgr(2) THEN GenerateAllSB = TRUE EXIT DO END IF 'Allow change of field color scheme IF ColorScheme <> OldColorScheme THEN OldColorScheme = ColorScheme CALL SetColors(ColorScheme) IF RegDsply THEN GOSUB RebuildFieldScreen END IF 'Allow change of background photo IF RegDsply = TRUE AND CmdChangePhoto$ = "Y" THEN GOSUB ChangePhotoManually VisiReady = FALSE: HomeReady = FALSE IF amgr(1) = FALSE AND amgr(2) = TRUE THEN HomeReady = TRUE IF amgr(2) = FALSE AND amgr(1) = TRUE THEN VisiReady = TRUE END IF END IF IF amgr(1) THEN GOTO ScanHome IF NewUI THEN IF a$ = "V" THEN IF it = 1 THEN VLastRow = 22 ELSE VLastRow = 23 CALL GetScreen(Scr1$, 10+rowO, 8+colO, VLastRow+rowO, 40+colO) IF Gfx THEN CALL GraphHole(17, 10+rowO, 8+colO, VLastRow+rowO, 40+colO) CALL VisitorOptions(Pick) CALL PutScreen(Scr1$, 10+rowO, 8+colO, VLastRow+rowO, 40+colO) IF Gfx THEN CALL EliminateHole(17) CALL UnfreezeAndRefresh END IF IF amgr(2) THEN VisiReady = TRUE IF Pick > 0 AND Pick < 6 THEN VisiReady = TRUE HomeReady = TRUE END IF GOTO ScanAgain END IF ELSE IF a$ = "S" AND NOT VisiPopped THEN IF it = 1 THEN VLastRow = 23 ELSE VLastRow = 24 CALL GetScreen(Scr1$, 10+rowO, 13+colO, VLastRow+rowO, 36+colO) IF Gfx THEN CALL GraphHole(17, 10+rowO, 13+colO, VLastRow+rowO, 36+colO) IF it = 1 THEN CALL DrawFrm(10+rowO, 13+colO, VLastRow+rowO, 36+colO, defattr, "Offense", " W\X A-D ", 0, 0, 0) ELSE CALL DrawFrm(10+rowO, 13+colO, VLastRow+rowO, 36+colO, defattr, "Defense", " W\X A-D ", 0, 0, 0) END IF CALL PopWindow(10+rowO, 13+colO, VLastRow+rowO, 36+colO, it) VisiPopped = TRUE END IF IF VisiPopped THEN IF a$ = "W" THEN CALL MovePtrVisi("U", 11+rowO, 14+colO) IF a$ = "X" THEN CALL MovePtrVisi("D", 11+rowO, 14+colO) IF a$ = "A" THEN CALL SetVisiTorF("T", DspSw) IF a$ = "D" THEN CALL SetVisiTorF("F", DspSw) IF ASC(a$) = 27 AND amgr(2) THEN VisiReady = TRUE END IF IF VisiReady AND VisiPopped THEN CALL PutScreen(Scr1$, 10+rowO, 13+colO, VLastRow+rowO, 36+colO) VisiPopped = FALSE IF Gfx THEN CALL EliminateHole(17) CALL UnfreezeAndRefresh END IF END IF END IF LL = 110 ScanHome: IF amgr(2) THEN GOTO ScanAgain IF NewUI THEN IF a$ = "H" THEN IF it = 1 THEN HLastRow = 22 ELSE HLastRow = 21 CALL GetScreen(Scr2$, 10+rowO, 42+colO, HLastRow+rowO, 74+colO) IF Gfx THEN CALL GraphHole(18, 10+rowO, 42+colO, HLastRow+rowO, 74+colO) CALL HomeOptions(Pick) CALL PutScreen(Scr2$, 10+rowO, 42+colO, HLastRow+rowO, 74+colO) IF Gfx THEN CALL EliminateHole(18) CALL UnfreezeAndRefresh END IF IF amgr(1) THEN HomeReady = TRUE IF Pick > 0 AND Pick < 6 THEN VisiReady = TRUE HomeReady = TRUE END IF GOTO ScanAgain END IF ELSE IF a$ = "5" AND NOT HomePopped THEN IF it = 1 THEN HLastRow = 24 ELSE HLastRow = 23 CALL GetScreen(Scr2$, 10+rowO, 44+colO, HLastRow+rowO, 67+colO) IF Gfx THEN CALL GraphHole(18, 10+rowO, 44+colO, HLastRow+rowO, 67+colO) IF it = 1 THEN CALL DrawFrm(10+rowO, 44+colO, HLastRow+rowO, 67+colO, defattr, "Defense", " 8|2 4-6 ", 0, 0, 1) ELSE CALL DrawFrm(10+rowO, 44+colO, HLastRow+rowO, 67+colO, defattr, "Offense", " 8|2 4-6 ", 0, 0, 1) END IF CALL PopWindow(10+rowO, 44+colO, HLastRow+rowO, 67+colO, 3 - it) HomePopped = TRUE END IF IF HomePopped THEN IF a$ = "8" THEN CALL MovePtrHome("U", 11+rowO, 45+colO) IF a$ = "2" THEN CALL MovePtrHome("D", 11+rowO, 45+colO) IF a$ = "4" THEN CALL SetHomeTorF("T", DspSw) IF a$ = "6" THEN CALL SetHomeTorF("F", DspSw) IF ASC(a$) = 27 AND amgr(1) THEN HomeReady = TRUE END IF IF HomeReady AND HomePopped THEN CALL PutScreen(Scr2$, 10+rowO, 44+colO, HLastRow+rowO, 67+colO) HomePopped = FALSE IF Gfx THEN CALL EliminateHole(18) CALL UnfreezeAndRefresh END IF END IF END IF ScanAgain: LOOP 'Clean up any loose ends IF Boxx OR Help OR ScoreCard THEN 'Handle different UI's IF NewUI THEN IF VisiPopped THEN CALL PutScreen(Scr1$, 10+rowO, 8+colO, VLastRow+rowO, 40+colO) IF HomePopped THEN CALL PutScreen(Scr2$, 10+rowO, 42+colO, HLastRow+rowO, 74+colO) ELSE IF VisiPopped THEN CALL PutScreen(Scr1$, 10+rowO, 13+colO, VLastRow+rowO, 36+colO) IF HomePopped THEN CALL PutScreen(Scr2$, 10+rowO, 44+colO, HLastRow+rowO, 67+colO) END IF IF Gfx THEN IF HoleStatus(17) THEN CALL EliminateHole(17) IF HoleStatus(18) THEN CALL EliminateHole(18) END IF END IF IF NOT amgr(1) OR NOT amgr(2) THEN CALL ChangeAttribute(ConsRows, 2, 3, prmattr) END IF LL = 120 AutoManage: 'Never allow a Delay in the Standings Display IF RegDsply = FALSE THEN DelFac = 0 END IF 'Check automatic manager to set proper switches mo = 0 md = 0 runner = 0 IF SaveState = TRUE THEN SaveState = FALSE ELSE IF amgr(1) OR amgr(2) THEN CALL Manage(mo, md, runner) END IF 'Because of "throw to first" multiple switces can be on at once 'This is supposed to activate ONLY the LAST one turned on IF Bunt = TRUE AND SavBunt = FALSE THEN Steal = FALSE HitAndRun = FALSE END IF IF Steal = TRUE AND SavSteal = FALSE THEN HitAndRun = FALSE Bunt = FALSE END IF IF HitAndRun = TRUE AND SavHitAndRun = FALSE THEN Steal = FALSE Bunt = FALSE END IF 'Generate some random numbers for future reference fr2 = FRND(2) fr3 = FRND(3) fr4 = FRND(4) fr5 = FRND(5) fr6 = FRND(6) ' ** PULL THE INFIELD IN (Tight) ** IF Tight AND RegDsply AND DelFac > 0 THEN CALL Msg ("20", "0", "0", "01", 0, id, 0, 0) CALL PostAnnouncer (TRUE) SLEEP DelFac * 800 ANx = 0 END IF ' ** PITCH AROUND ** IF PAround AND RegDsply AND DelFac > 0 THEN AddtoAnnouncer it, "They'll pitch carefully to this guy..." CALL PostAnnouncer (TRUE) SLEEP DelFac * 800 ANx = 0 END IF ' ELSEIF TightAtCorners THEN ' AddtoAnnouncer id, "Infield tight at the corners" ' CALL ScoreBrd ' SLEEP DelFac * 1000 ' ANx = 0 ' ** HELP SCREEN ** IF Help THEN QPush IF Gfx AND RegDsply THEN CALL HideGfx CALL ShowDoc IF Gfx AND RegDsply THEN CALL ShowGfx QPop GOTO AnnounceHitter END IF ' ** SCORE CARD ** IF ScoreCard THEN QPush GOSUB ShowScoreCard QPop IF Gfx AND RegDsply THEN CALL UnfreezeAndRefresh GOTO AnnounceHitter END IF ' ** BOX SCORE ** IF Boxx THEN CALL Box IF Gfx AND RegDsply THEN CALL HideGfx QPush CALL ListFile (CmdWritePath$ +"~BOX.PRN") QPop IF Gfx AND RegDsply THEN CALL ShowGfx itag = 1 GOTO AnnounceHitter END IF ' ** BULLPEN ** IF BullO THEN tm = it GOSUB DisplayPitchCount 'corrupts n, m CALL ClearInpBuffer CALL Bullpen(0, it, 0, -1) IF Gfx AND RegDsply THEN CALL UnfreezeAndRefresh GOTO AnnounceHitter END IF IF BullD THEN IF amgr(id) = 0 THEN tm = id GOSUB DisplayPitchCount CALL ClearInpBuffer END IF ipsv = ip CALL Bullpen(md, id, 0, 0) IF Gfx AND RegDsply AND DelFac > 0 THEN CALL UnfreezeAndRefresh END IF IF md = 0 THEN Bull = FALSE ELSE HotBull = TRUE DidDoubleSwitch = FALSE CALL AddToScoreCrd (it, ip, "A", "[Relief] ") 'Consider Double-Switch IF amgr(id) AND BlockDoubleSwitch = FALSE THEN IF dh = FALSE THEN DoIt = 2 IF inn = 9 AND iout = 0 THEN IF ExpectedPitchCount(ip, id) < 22 THEN '1.4 innings DoIt = FALSE END IF ELSEIF ExpectedPitchCount(ip, id) > 32 THEN '2 innings DoIt = TRUE END IF IF DoIt = 2 THEN IF RND < .50 THEN 'was .75 4.01 DoIt = TRUE ELSE DoIt = FALSE END IF END IF IF DoIt THEN CALL DoubleSwitch (DidDoubleSwitch, inplayer, outplayer) END IF END IF IF DidDoubleSwitch THEN zzzDSW = zzzDSW + 1 IF RegDsply THEN CALL Msg ("26", "0", "0", "01", ipsv, id, 0, 0) CALL Msg ("26", "0", "0", "02", ip, id, 0, 0) CALL PostAnnouncer (FALSE) CALL Defens(0) CALL BatOrd CALL BasPat IF Gfx THEN CALL UnfreezeAndRefresh END IF SLEEP DelFac * 1300 ANx = 0 IF DidDoubleSwitch THEN CALL Msg ("20", "0", "0", "04", 0, id, 0, 0) CALL Msg ("20", "0", "0", "05", inplayer, id, outplayer, id) CALL PostAnnouncer (TRUE) SLEEP DelFac * 1300 ANx = 0 END IF END IF LineUpChangeDef = TRUE GpPos(ip, id, 1) = 1 END IF GOTO AnnounceHitter END IF ' ** PINCH RUNNER ** IF PRun THEN CALL PinchRun(mo, runner) IF RegDsply THEN CALL BatOrd CALL BasPat END IF IF mo = 0 THEN GOTO AnnounceHitter IF Gfx AND RegDsply THEN CALL UnfreezeAndRefresh END IF '(runner, it) is new player in lineup '(mo, it) is player now out IF DelFac THEN CALL Msg ("27", "0", "0", "03", 0, it, 0, 0) CALL Msg ("27", "0", "0", "04", runner, it, mo, it) ExtraTalk = TRUE END IF 'Mark to check Defense-by-Position next inning LineUpChangeOff = TRUE 'Record this guy in slot "12" - pinch runner category r = DataRef(runner, it) GpPos(r, it, 12) = 1 INCR zzzprun IF DataPos(runner, it) = 1 THEN 'new guy is in pitcher's slot IF WarmUpRule = TRUE AND amgr(it) = 0 THEN 'Is the pinch-runner for the pitcher also a pitcher? SearchName$ = DataName(ib, it) N = SearchDAT (10, LastPiAd(it), it, SearchName$, 0) 'If so, warm up the pinch-running pitcher IF N THEN WarmUpStatus(N, it) = 1 ipa(it) = N '????? ELSE GOSUB GoBullPenIfNoWarm END IF END IF END IF GOTO AnnounceHitter END IF ' ** PINCH HITTER ** IF PH AND PHinProgress = FALSE THEN CALL PinchHit(mo) IF RegDsply THEN CALL BatOrd END IF IF mo = 0 THEN GOTO AnnounceHitter IF Gfx AND RegDsply THEN CALL UnfreezeAndRefresh END IF '(ib, it) is new player in lineup '(mo, it) is player now out IF DelFac THEN CALL Msg ("27", "0", "0", "01", 0, it, 0, 0) CALL Msg ("27", "0", "0", "02", ib, it, mo, it) ExtraTalk = TRUE END IF PHinProgress = TRUE 'Mark to check Defense-by-Position next inning LineUpChangeOff = TRUE 'Record this guy in slot "11" - pinch hitter category r = DataRef(ib, it) GpPos(r, it, 11) = 1 IF DataPos(ib, it) = 1 THEN 'somebody is hitting in pitcher's slot IF WarmUpRule = TRUE AND amgr(it) = 0 THEN 'Is the pinch-hitter for the pitcher also a pitcher? SearchName$ = DataName(ib, it) N = SearchDAT (10, LastPiAd(it), it, SearchName$, 0) 'If so, warm up the pinch-hitting pitcher IF N THEN WarmUpStatus(N, it) = 1 ipa(it) = N '????? ELSE GOSUB GoBullPenIfNoWarm END IF END IF END IF GOTO AnnounceHitter END IF ' ** DEFENSIVE SUBSTITITION ** IF Subx THEN QPush CALL Lineup(id, rv) QPop LineUpChangeDef = TRUE 'Rebuild entire screen after a CLS IF Gfx THEN CALL UnfreezeAndRefresh END IF CALL ScoreBrd (TRUE, TRUE) CALL BatOrd CALL Prompt(0) GOSUB PrintEra GOSUB PrintButtons GOSUB PrintStats CALL Defens(0) CALL BasPat IF rv <> 0 THEN CALL Msg ("28", "0", "0", "01", 0, id, 0, 0) ExtraTalk = TRUE END IF GOTO AnnounceHitter END IF ' ** VIEW LINEUP ** IF ViewHome OR ViewVisi THEN IF ViewHome THEN N = 2 ELSE N = 1 IF Gfx THEN CALL GraphHole(30, 1+rowO, 2+colO, 24+rowO, 79+colO) QPush CALL DrawFrm(1+rowO, 2+colO, 23+rowO, 77+colO, defattr, "'" + RTRIM$(Names(N)) + " Lineup", LPtr$ + " " + RPtr$, 1, 0, 1) QPRINTs 16+rowO, 77+colO, "µ", defattr QPRINTs 17+rowO, 77+colO, UpPtr$, defattr QPRINTs 18+rowO, 77+colO, DnPtr$, defattr QPRINTs 19+rowO, 77+colO, "¶", defattr CALL BuildTeamWin (N, 1, MAXPLAYERS, TRUE, pend) RowOff = 0: ColOff = 0 DO CALL ShowVirtWin (1, 10, RowOff, ColOff, 3+rowO, 4+colO, 10, 20, 72) QPRINTs 13+rowO, 3+colO, STRING$(26, "Ž") + " Pitchers and Bench " + STRING$(28, "Ž"), defattr CALL ShowVirtWin (11, 9, RowOff, ColOff, 14+rowO, 4+colO, 0, 20, 72) CALL GetScrollKey (kc, RowOff, ColOff) LOOP UNTIL kc = 13 OR kc = 27 ERASE VirtualWin QPop IF Gfx THEN CALL EliminateHole(30) CALL UnfreezeAndRefresh END IF GOTO AnnounceHitter END IF ' ** SWAP DEFENSIVE POSITIONS ** IF SwPos THEN QPush CALL DefSwitch(3, id) QPop IF Gfx THEN CALL UnfreezeAndRefresh END IF LineUpChangeDef = TRUE CALL BatOrd CALL Defens(0) CALL BasPat GOTO AnnounceHitter END IF 'ACTION -- we're actually throwing a pitch at this point, 'or throwing to first or issuing a free pass 'If a line-up change was made last inning, record it here. '(PinchHitter or PinchRunner who stayed in game, bullpen, 'defensive substitution or position swap). 'The manager has had an opportunity to replace the pinch-player 'if desired, who then would not be recorded in the GpPos. IF LineUpChangeDef THEN FOR p = 1 TO 9 r = DataRef(p, id) ps = DataPos(p, id) IF ps <> 1 THEN IF GpPos(r, id, ps) = 0 THEN GpPos(r, id, ps) = 1 END IF NEXT LineUpChangeDef = FALSE END IF '1st pitch of half-inning - scan defense IF CurrentGamePoint <> SaveGamePoint THEN IF LineUpChangeOff THEN FOR p = 1 TO 9 r = DataRef(p, id) ps = DataPos(p, id) IF ps <> 1 THEN IF GpPos(r, id, ps) = 0 THEN GpPos(r, id, ps) = 1 END IF NEXT IF PHinProgress = FALSE THEN LineUpChangeOff = FALSE END IF SaveGamePoint = CurrentGamePoint END IF IF DelFac > 0 AND RegDsply THEN ANx = 0 IF RND < .5 THEN 'The sign CALL Msg ("32", "0", "1", "00", ip, id, man2, team2) END IF i = NUMBERON IF RND < .5 THEN 'Check runners IF i = 1 THEN CALL Msg ("32", "0", "2", "01", ip, id, man2, team2) ELSEIF i > 1 THEN CALL Msg ("32", "0", "2", "02", ip, id, man2, team2) END IF END IF IF RND < .5 THEN 'Stretch/windup IF i THEN t$ = "01" ELSE t$ = "02" CALL Msg ("32", "0", "3", t$, ip, id, man2, team2) END IF 'Pitch IF ANx > 0 THEN t$ = "01" ELSE t$ = "02" CALL Msg ("32", "0", "4", t$, ip, id, man2, team2) CALL PostAnnouncer(TRUE) SLEEP (DelFac / 2) * 1000 ANx = 0 END IF LL = 130 ' ** INTENTIONAL WALK ** IF IWalk THEN CALL WalkRoutine INCR mpbf(ip, id) GOSUB ResetBatterCounters GOTO WrapUpThisAB END IF '** Throw to First / Pick-Off (new location) xF! = RND IF ir1 <> 0 AND ir2 = 0 THEN '.0012 RunsAhead = itruns(id) - itruns(it) IF ABS(RunsAhead) < 3 THEN IF DataSpeed(ir1, it) > 4 THEN IF xF! < .0005 * DataSpeed(ir1, it) THEN GOTO PickOff IF xF! < .0250 * DataSpeed(ir1, it) THEN GOTO HoldRunner END IF END IF END IF ' ** PITCH OUT IF NUMBERON THEN IF POut THEN IF BatPOut + WildPitchCount = 3 THEN CALL WalkRoutine INCR mpbf(ip, id) GOSUB ResetBatterCounters GOTO WrapUpThisAB ELSE AddToAnnouncer id, "Pitch Out..." INCR BatPOut IF NOT Steal AND NOT Bunt AND NOT HitAndRun THEN IF SoundOn THEN CALL WavPopMitt AddToAnnouncer it, "Runner not going..." CALL ResetBatter 'Same hitter still up GOTO WrapUpThisAB END IF END IF END IF END IF 'If POut is TRUE, then the only way to get here is if 'it's a STEAL, BUNT, or HITANDRUN ' ** BUNT/SQUEEZE ** ' "Batters Faced" maintained inside BuntRoutine IF Bunt THEN 'you could bunt a pitchout? CALL BuntRoutine GOSUB ResetBatterCounters GOTO WrapUpThisAB END IF ' ** STEAL IN PROGRESS IF Steal THEN 'Who is lead runner? LR = 0 IF ir3 = 0 THEN IF ir2 = 0 THEN IF ir1 > 0 THEN LR = ir1 ELSE LR = ir2 END IF ELSE LR = ir3 END IF 'Sum up attemps by player and team IF LR THEN INCR StealAttemptsTeam(it) runref = DataRef(LR, it) INCR StealAttemptsPlayer(runref, it) END IF 'Couldn't get a jump... IF RND < .12 AND LR > 0 THEN IF DelFac THEN CALL Msg ("31", "0", "0", "14", ir1, it, man2, team2) IF POut THEN 'Abort play... IF SoundOn THEN CALL WavPopMitt CALL ResetBatter GOTO WrapUpThisAB END IF 'Continue with play,,, ELSE 'Runner takes off... IF SoundOn THEN CALL WavPopMitt CALL StealRoutine GOTO WrapUpThisAB END IF END IF ' ** HIT-AND-RUN IF HitAndRun THEN IF POut THEN CALL StealRoutine GOTO WrapUpThisAB END IF 'Find the percentage of strike-outs hsoF! = DataSO(ib, it) / (DataAB(ib,it) + 1.09 * DataBB(ib,it)) bfF! = BattersFacedByPit! (DataAB(ip,id), DataHits(ip,id), DataBB(ip,id), DataSO(ip,id)) psoF! = DataSO(ip, id) / bfF! x! = hsoF! * (psoF! / psbaseF(id)) bpkF! = x! / (x! + ( (1-hsoF!)*(1-psoF!)/(1-psbaseF(id)) ) ) xF! = RND IF xF! < bpkF! THEN 'Strike Out plus steal attempt CALL StrikeOutRoutine INCR mpbf(ip, id) 'Bump up "Batters Faced" IF iout < 3 THEN fr7 = 0 CALL StealRoutine 'fr7 = 90 (from StealRoutine) signals runner was caught stealing IF fr7 = 90 THEN Result$ = Result$ + " DP" INCR dp(id) fr7 = 0 END IF 'StealRoutine (above) resets hitter so we've got to undo that 'because we're done with this batter! ResetHitter = FALSE INCR ibp(it) INCR mab(ref, it) IF UCASE$(DataHand(ip, id)) = "L" THEN INCR mabLHP(ref, it) ELSE INCR mabRHP(ref, it) END IF END IF GOTO WrapUpThisAB 'Swing-and-a-miss and steal attempt - same batter ELSEIF xF! < bpkF! + .15 THEN IF SoundOn THEN CALL WavWhiff AddToAnnouncer it, "Swing and a miss...." CALL StealRoutine 'Resets Hitter GOTO WrapUpThisAB END IF END IF ' ** Wild Pitch / Passed Ball ** IF ir1 OR ir2 OR ir3 THEN xF! = RND yF! = DataBB(ip,id) / BattersFacedByPit! (DataAB(ip,id), DataHits(ip,id), DataBB(ip,id), DataSO(ip,id)) wp! = .017 * (yF! / pwbaseF(id)) IF ir3 THEN wp! = wp! / 2 IF xF! < wp! THEN GOTO WildPitch 'was .01 .008 nn = WHOATGUY(2) defperF! = DEFPCT!(nn) zF! = (1.0 - defperF!) * .07 'was .1 IF xF! < wp! + zF! THEN GOTO PassedBall END IF ' ** HR Tease / Foul Ball ** IF DelFac THEN IF RND < DataHR(ib, it) / (DataAB(ib, it) * 10) THEN 'Decide which foul line IF DataHand(ib, it) = "R" THEN WhoAtPos = 7 ELSEIF DataHand(ib, it) = "L" THEN WhoAtPos = 9 ELSE 'Switch hitter IF UCASE$(DataHand(ip, id)) = "L" THEN WhoAtPos = 7 ELSE WhoAtPos = 9 END IF END IF 'Occasionally hit to opposite field IF RND < .15 THEN IF WhoAtPos = 7 THEN WhoAtPos = 9 ELSE WhoAtPos = 7 END IF END IF IF SoundOn THEN CALL WavBigFly wag = WHOATGUY(WhoAtPos) CALL Msg ("09", "0", "1", "01", wag, id, man2, team2) IF RND < .1 THEN t$ = "02" ELSE t$ = "01" CALL Msg ("09", "0", "2", t$, wag, id, man2, team2) AddToAnnouncer it, "Foul ball!" CALL ResetBatter GOTO WrapUpThisAB END IF END IF 'Execute play IF WarmUpRule THEN IF amgr(id) = 0 THEN 'Decrement Defense's pitchers warmup status FOR i = 10 TO TopPitLim IF WarmUpStatus(i, id) > 0 THEN DECR WarmUpStatus(i, id) IF WarmUpStatus(i, id) = 0 AND SimDaysOff(i, id) < 0 THEN '2/18/07 SimDaysOff(i, id) = 0 - SimDaysOff(i, id) END IF END IF NEXT END IF IF amgr(it) = 0 THEN 'Decrement Offense's pitchers warmup status (to a point) FOR i = 10 TO TopPitLim IF WarmUpStatus(i, it) > 2 THEN DECR WarmUpStatus(i, it) NEXT END IF END IF INCR mpbf(ip, id) 'Bump up "Batters Faced" CALL Engine GOSUB ResetBatterCounters 'Erase Batter's name from batters box IF DelFac > 0 AND RegDsply = TRUE THEN CALL BatterName(BLN$, "", TRUE) IF Gfx THEN CALL UnfreezeAndRefresh END IF END IF LL = 140 WrapUpThisAB: 'Scorecard reporting IF ResetHitter = FALSE THEN IF PHinProgress THEN xS$ = "8" ELSE xS$ = " " CALL AddToScoreCrd(it, ref, xS$, Result$) 'The following extra line reports 'runners thrown out during play, etc. IF ref2 THEN RunsBeforePlay = itruns(it) 'Causes runs to zero-out - we just reported runs this play above CALL AddToScoreCrd(it, ref2, Code2$, Result2$) ref2 = 0 END IF PHinProgress = FALSE END IF INCR mab(ref, it) IF UCASE$(DataHand(ip, id)) = "L" THEN INCR mabLHP(ref, it) ELSE INCR mabRHP(ref, it) END IF IF RegDsply THEN CALL PostAnnouncer (TRUE) 'flashes defense CALL ScoreBrd (DrawSBFrame, GenerateAllSB) DrawSBFrame = FALSE GenerateAllSB = FALSE CALL BasPat IF Gfx THEN CALL UnfreezeAndRefresh END IF END IF IF DelFac THEN SLEEP DelFac * 800 'Allow user to read the messages, etc. END IF IF IGone = TRUE AND DelFac > 0 THEN QPush CALL Gone QPop END IF HotBull = FALSE GOTO NextHitter WildPitch: IF DelFac THEN CALL Msg ("29", "0", "0", "08", 0, id, 0, 0) IF NUMBERON > 1 THEN x$ = "05" ELSE x$ = "04" CALL Msg ("31", "0", "0", x$, 0, id, 0, 0) IF SoundOn THEN 'Just a bit outside... IF RND < .33 THEN SLEEP 1000 L = PlayWav("15533.wav") END IF END IF END IF Errorx = TRUE 'So RBI will not be credited in Advanc CALL Advanc(1, 1, 1) Errorx = FALSE CALL AddToScoreCrd(it, 0, "5", "WP") WildPit(id) = WildPit(id) + PADZEROS$(LTRIM$(STR$(ip)), 2) zzzwp = zzzwp + 1 INCR WildPitchCount 'Did we just walk him also? IF WildPitchCount + BatPOut > 3 THEN CALL WalkRoutine INCR mpbf(ip, id) GOSUB ResetBatterCounters 'We are done with this batter GOTO WrapUpThisAB ELSE CALL ResetBatter GOTO WrapUpThisAB END IF PassedBall: IF DelFac THEN AddToAnnouncer id, "The pitch gets by the catcher..." AddToAnnouncer id, "That will be a passed ball!" IF NUMBERON > 1 THEN x$ = "05" ELSE x$ = "04" CALL Msg ("31", "0", "0", x$, 0, it, 0, 0) END IF Errorx = TRUE 'So RBI will not be credited in Advanc CALL Advanc(1, 1, 1) Errorx = FALSE CALL AddToScoreCrd(it, 0, "5", "PB") i = WHOATGUY(2) PassedB(id) = PassedB(id) + PADZEROS$(LTRIM$(STR$(DataRef(i, id))), 2) zzzpb = zzzpb + 1 CALL ResetBatter GOTO WrapUpThisAB PickOff: LL = 150 IF DelFac THEN AddToAnnouncer id, "Throw to first..." CALL Msg ("31", "0", "0", "07", ir1, it, 0, 0) CALL Msg ("40", "0", "0", "00", 0, it, 0, 0) END IF i = ir1 ir1 = 0 CALL AddToScoreCrd(it, DataRef(i, it), "1", "1-3 PkOff") INCR iout INCR mpo(ip, id) INCR Assists(ip, id, 1) INCR PutOuts(DataRef(WHOATGUY(3), id), id, 3) CALL ResetBatter GOTO WrapUpThisAB HoldRunner: IF DelFac THEN AddToAnnouncer id, "Throw to first..." AddToAnnouncer it, "The runner back..." END IF CALL ResetBatter SaveState = TRUE GOTO WrapUpThisAB SwitchSides: 'End of 1/2 inning INCR it LOOP 'Start top of NEW inning INCR inn GOTO TopOfInning '--------------------- 'Game is over. '--------------------- GAMEOVER: IF dh THEN Atotpitchers = Atotpitchers + np(1) + np(2) AGames = AGames + 2 ELSE Ntotpitchers = Ntotpitchers + np(1) + np(2) NGames = NGames + 2 END IF IF CmdDeBug$ = "Y" THEN FOR i = 1 TO 2 zzzSumR = zzzSumR + TeamSpeed(i) zzzSumN = zzzSumN + 1 NEXT FOR p = 1 TO 9 FOR i = 1 TO MAXPLAYERS FOR j = 1 TO 2 k = Assists(i,j,p) IF k THEN SumAssists(p) = SumAssists(p) + k l = PutOuts(i,j,p) IF l THEN SumPutOuts(p) = SumPutOuts(p) + l NEXT NEXT NEXT END IF LL = 160 GameIsOver = TRUE zzzdp = zzzdp + dp(1) + dp(2) 'Mark last pitchers as used (for DaysOff logic) i = iyp(np(1), 1) j = iyp(np(2), 2) iused(i, 1) = TRUE iused(j, 2) = TRUE 'pit per game zzzpitpergame = zzzpitpergame + (PitchersPerGame(1) + PitchersPerGame(2)) / 2 zzzgames = zzzgames + 1 IF itruns(2) > itruns(1) THEN iwin = 2 ELSE iwin = 1 ' Did anyone earn a "save"? ' If the Last Pitcher on the winning team is not the winning pitcher, ' then give a save to the last pitcher - maybe lastpit = iyp(np(iwin), iwin) IF lastpit <> WPpit THEN i = mpo(lastpit, iwin) 'outs records by last pitcher IF (lastpit = QualSave1IP AND iwin = QualSave1ID) THEN SPteam = iwin SPpit = lastpit END IF IF (lastpit = QualSave2IP AND iwin = QualSave2ID) AND i > 2 THEN SPteam = iwin SPpit = lastpit END IF IF i > 8 THEN SPteam = iwin SPpit = lastpit END IF END IF 'Enforce 5 inning rule for starting pitchers IF iyp(1, iwin) = WPpit THEN IF mpo(WPpit, iwin) < 15 THEN WPpit = iyp(2, iwin) END IF END IF 'Record Exceptional Performances ExSw = FALSE GMx = 0 FOR it = 1 TO 2 ref = 10 DO IF mpk(ref, it) >= HiLvlSOs THEN xS$ = STR$(mpk(ref, it)) + " K's" GOSUB BuildHiLiteMsg GOSUB SaveHiLite END IF ref = ref + 1 IF ref > LastPiAd(it) THEN EXIT DO LOOP UNTIL ref > TopPitLim NEXT FOR it = 1 TO 2 ref = 1 DO IF mhits(ref, it) >= HiLvlHits THEN xS$ = STR$(mhits(ref, it)) + " hits" GOSUB BuildHiLiteMsg GOSUB SaveHiLite END IF IF mrbi(ref, it) >= HiLvlRBIs THEN xS$ = STR$(mrbi(ref, it)) + " RBI's" GOSUB BuildHiLiteMsg GOSUB SaveHiLite END IF IF mhr(ref, it) > 0 AND m3b(ref, it) > 0 AND m2b(ref, it) > 0 THEN IF mhits (ref, it) > (mhr(ref, it) + m3b(ref, it) + m2b(ref, it)) THEN xS$ = " hit for cycle" GOSUB BuildHiLiteMsg GOSUB SaveHiLite END IF END IF IF mhr(ref, it) >= HiLvlHRs THEN xS$ = STR$(mhr(ref, it)) + " HR's" GOSUB BuildHiLiteMsg GOSUB SaveHiLite END IF IF msb(ref, it) >= HiLvlSBs THEN xS$ = STR$(msb(ref, it)) + " SB's" GOSUB BuildHiLiteMsg GOSUB SaveHiLite END IF IF ref = 9 THEN ref = LastPiAd(it) ref = ref + 1 LOOP WHILE ref <= MAXPLAYERS NEXT FOR it = 1 TO 2 IF ithits(it) <= HiLvlPHits THEN id = 3 - it IF ithits(it) = 0 THEN zS$ = "No" ELSE zS$ = LTRIM$(STR$(ithits(it))) IF np(id) = 1 THEN Message$ = FULLNAME$(NameRef(iyp(1, id), id)) + ", " + zS$ + "-Hitter" GOSUB SaveHiLite ELSEIF ithits(it) = 0 THEN Message$ = RTRIM$(Names(id)) + ", multi-pit. " + zS$ + "-Hitter" GOSUB SaveHiLite END IF END IF NEXT 'Former position of the dump star file IF (MenuOpt$ = "T" OR MenuOpt$ = "E") AND DelFac > 0 THEN PauseSw = TRUE END IF 'Former position of showstandings IF CmdPauseAftGame$ = "Y" THEN PauseSw = TRUE IF CmdPauseAftDate$ = "Y" THEN IF LastGameThisDate = TRUE THEN LastGameThisDate = FALSE PauseSw = TRUE END IF END IF 'Record-keeping IF CmdStat$ > "!" THEN GOSUB UpdateStats 'appends to .STS (#3) leaves #3 open 'updates bat and pit in memory IF MenuOpt$ = "M" OR MMGame OR QuitPending OR PauseSw THEN GOSUB SaveStatsToDisk 'opens and closes #4 for both bat & pit Silence = TRUE END IF END IF 'Append LineScore to CmdLinF$ file IF CmdLinF$ > "!" THEN IF LEFT$(CmdLinF$, 3) = "LPT" THEN OPEN CmdLinF$ FOR OUTPUT AS #6 LEN = 80 ELSE OPEN CmdWritePath$ + CmdLinF$ FOR APPEND AS #6 LEN = 80 END IF PRINT #6, DATE$; " "; TIME$; PRINT #6, " #"; SimGameCtr + 1; PRINT #6, STRING$(41, "-"); IF LEN(SCHDate$) THEN PRINT #6, " "; SCHDate$ ELSE PRINT #6, STRING$(10, "-"); " " END IF xS$ = LINESCORE$(1) PRINT #6, SPACE$(LEN(xS$) - 9) + " R H E" PRINT #6, xS$ xS$ = LINESCORE$(2) PRINT #6, xS$ CLOSE #6 END IF 'Build box-score and append it to CmdStar$ file IF ExSw AND CmdStar$ > "!" THEN IF DelFac THEN QPush CALL DrawFrm(11, 16, 13 + GMx, 66, defattr, nulls$, nulls$, 1, 0, 0) FOR i = 1 TO GMx QPRINTs 11 + i, 18, GMMessage(i), dimattr NEXT QPRINTs 12 + GMx, 18, "The Box Score will be saved in " + CmdStar$, dimattr SLEEP 1500 QPop IF Gfx THEN CALL UnfreezeAndRefresh END IF END IF 'ForceCLS = TRUE CALL Box n = 1 xS$ = CmdStar$ GOSUB AppendBox REDIM GMMessage(5) AS GLOBAL STRING END IF 'Build box-score and append it to CmdBoxF$ file IF CmdBoxF$ > "!" THEN CALL Box n = 0 xS$ = CmdBoxF$ GOSUB AppendBox END IF 'Append Score Card to CmdScrF$ file IF CmdScrF$ > "!" THEN REDIM List1(1 TO 300) AS List1Type CALL LoadScoreCardToList1 (List1(), j) ' j returns items in list IF LEFT$(CmdScrF$, 3) = "LPT" THEN xS$ = CmdScrF$ ELSE xS$ = CmdWritePath$ + CmdScrF$ END IF CALL DumpList(List1(), j, xS$, TRUE) ERASE List1 END IF 'Record win or loss for "Standings" - updates WLRec(), WLx, etc. 'IF League(1) = "A" THEN x$ = "a" ELSE x$ = League(1) CALL SearchStandingsTable (League(1), Div(1), Names(1), j) 'IF League(2) = "A" THEN x$ = "a" ELSE x$ = League(2) CALL SearchStandingsTable (League(2), Div(2), Names(2), k) IF itruns(2) > itruns(1) THEN WLRec(k).WLWins = WLRec(k).WLWins + 1 WLRec(j).WLLoss = WLRec(j).WLLoss + 1 ELSE WLRec(j).WLWins = WLRec(j).WLWins + 1 WLRec(k).WLLoss = WLRec(k).WLLoss + 1 END IF 'TEST - Count Total Shutouts IF itruns(1) = 0 OR itruns(2) = 0 THEN INCR zzzshutouts END IF IF RegDsply = FALSE THEN IF CmdSch$ < "!" THEN 'no .sch file so must be .ser or two-team or CMD-line IF SimGameCtr MOD RefreshStandings = 0 THEN IF CmdAutoExit$ <> "Y" THEN CALL ShowStandings (FALSE) END IF ELSE '.sch file IF MMx THEN CALL ShowStandings (FALSE) ELSEIF SaveSCHDate$ <> SCHDate$ THEN IF CmdAutoExit$ <> "Y" THEN CALL ShowStandings (FALSE) SaveSCHDate$ = SCHDate$ END IF END IF END IF 'Temporarily Pause the action under the following conditions IF PauseSw THEN GOTO ManualPromptLoop IF MMGame THEN GOTO ManualPromptLoop IF QuitPending THEN GOTO ManualPromptLoop '-------------------------------------------------------------- 'If there's more games to play on the schedule or two-team sim, 'Go back to "LoadTeamFiles", (unless this is a double-header 'in which case you get next pitchers and go to "Startup"). 'Go to "MultiPromptLoop" if done. '-------------------------------------------------------------- 'SIMULATION: T/S/E/Command-Line MultiGames: LL = 170 IF CmdSlotGames > 0 THEN SlotGameCtr = SlotGameCtr + 1 'counts /n: games in this "slot" SimGameCtr = SimGameCtr + 1 'total number of games 'More Games in this Slot? IF SlotGameCtr < CmdSlotGames THEN 'Double Header?: T/S/E/Command-Line IF MMGame THEN GOTO LoadTeamFiles ELSE CALL RestFrSnapShot 'restores Dat arrays from RefOrgSave array GOSUB ClearGameData CALL GetNextPitchers 'ipa(*) IF AutoLineUpSw(1) THEN CALL AutoLineUp (1, c1) IF AutoLineUpSw(2) THEN CALL AutoLineUp (2, c2) IF NOT dh THEN CALL PutPitHitStatsInBO CALL SetPlatoon 'Will over-ride a fixed lineup IF AdjustBO(1) = "Y" OR _ (AdjustBO(1) = "C" AND c1) THEN CALL AdjustBattingOrder (1) IF AdjustBO(2) = "Y" OR _ (AdjustBO(2) = "C" AND c2) THEN CALL AdjustBattingOrder (2) 'Rebuild RefOrg for box score purposes REDIM RefOrg(MAXPLAYERS, 2) AS GLOBAL RefOrgType FOR tm = 1 TO 2 FOR i = 1 TO MAXPLAYERS RefOrg(i, tm).RefNo = DataRef(i, tm) RefOrg(i, tm).RefPos = DataPos(i, tm) NEXT NEXT CALL SetRefByBO 'Builds RefByBO array GOTO StartUp END IF 'We need to read the next .SER record ELSEIF SeriesSw THEN IF NOT EOF(2) THEN SlotGameCtr = 0 DO LINE INPUT #2, xS$ L = LEN(xS$) LOOP WHILE xS$ = SPACE$(L) AND NOT EOF(2) IF xS$ <> SPACE$(L) THEN CALL ParseCommand (xS$, nargs) CALL SetSwitches (nargs) GOTO LoadTeamFiles 'Load new .dat files, etc. ELSE CLOSE #2 'testing GOTO MultiPromptLoop END IF ELSE CLOSE #2 ' LOCATE 1, 50 ' PRINT "AL:"; ATotpitchers / Agames; ' LOCATE 1, 68 ' PRINT "NL:"; NTotpitchers / Ngames; ' x$ = WAITKEY$ GOTO MultiPromptLoop 'no more cards to read - we are done END IF 'We need to look at the next "slot" in the .SCH record ELSEIF SchedSw THEN SlotGameCtr = 0 CmdVFil$ = nulls$: CmdHFil$ = nulls$ DO WHILE SchSlotPtr < SchGamesPerRecord SchSlotPtr = SchSlotPtr + 1 IF MMx THEN CALL SetSCHBookMark 'experiment CALL ReadSCHSlot IF CmdVFil$ > "!" AND CmdHFil$ > "!" AND FilterOK = TRUE THEN GOSUB SetAutoMgr GOTO LoadTeamFiles END IF LOOP 'The Date has changed so, 'We need to read the next .SCH date record: S/Command-line DO GET #2 ,, SchBuffer$ IF EOF(2) THEN EXIT DO IF MID$(SchBuffer$, 1, 1) = "D" THEN ITERATE DO SCHDate$ = MID$(SchBuffer$, 3, 8) SchSlotPtr = 0 DO WHILE SchSlotPtr < SchGamesPerRecord SchSlotPtr = SchSlotPtr + 1 IF MMx THEN CALL SetSCHBookMark 'experiment CALL ReadSCHSlot IF CmdVFil$ > "!" AND CmdHFil$ > "!" AND FilterOK = TRUE THEN GOSUB SetAutoMgr GOTO LoadTeamFiles END IF LOOP LOOP CALL SetSCHBookMark CALL UpdSCHRecord1 ("DEL") IF EOF(2) THEN CLOSE #2 GOTO MultiPromptLoop 'No more cards to read - we are done ELSE 'No more games left: GOTO MultiPromptLoop 'T/Command-Line w/no .sch END IF END IF '-------------------------------------------------- 'End of Manual Game (or manually managed .sch game) '-------------------------------------------------- 'MANUAL single-game mode closing ' (never go here without closing and saving STB and STP) ManualPromptLoop: r = MidRow c = MidCol - 19 IF PauseSw OR MMGame THEN n = r+4 ELSE n = r+3 IF HoleStatus(32) THEN CALL EliminateHole(32) IF Gfx THEN CALL GraphHole(32, r-1, c-5, n, c+44) CALL DrawFrm(r-1, c-5, n, c+44, defattr, nulls$, nulls$, 0, 0, 0) QPRINTs r, c+10, "That's the ballgame!", dimattr QPRINTs r+1, c+10, "WINNER: '" + Names(iwin), defattr QPRINTs r+2, c, "Select an Option from the Menu Bar below.", dimattr IF PauseSw OR MMGame THEN QPRINTs r+3, c, "Hit ENTER to continue your simulation.", dimattr END IF CALL Prompt(1) IF CmdStat$ > "!" THEN CLOSE #3 'Close .STS STSOpen = FALSE 'bat & pit (#4) already saved & closed END IF 'Wait until a menu key is pressed... DO i = 0 DO IF Gfx AND RegDsply THEN CALL UnfreezeAndRefresh END IF zS$ = WAITKEY$ IF LEN(zS$) = 4 THEN msx = MOUSEX msy = MOUSEY IF msy = ConsRows THEN zS$ = CHR$(SCREEN(msy, msx)) CALL FlashField (msy, msx, 1, 2, 100, 0) ELSE zS$ = nulls$ END IF ELSE zS$ = UCASE$(zS$) msx = 0 msy = 0 END IF i = INSTR("BCNRSDQ " + CHR$(27) + CHR$(13), zS$) LOOP UNTIL i SELECT CASE zS$ CASE "B" IF Gfx AND RegDsply THEN CALL HideGfx QPush CALL Box CALL ListFile (CmdWritePath$ + "~BOX.PRN") COLOR deffor, defbac QPop IF Gfx AND RegDsply THEN CALL ShowGfx CASE "C" QPush GOSUB ShowScoreCard QPop CASE "N", CHR$(27), CHR$(13), CHR$(32) IF PauseSw THEN PauseSw = FALSE ForceCLS = TRUE GOTO MultiGames END IF IF MMGame OR QuitPending THEN '.SCH Files only CALL Button(17+rowO, 20+colO, errattr, " Want to continue the Simulation? [Y/n] ", 0) LOCATE 17+rowO, 60+colO IF YESorNO$(revfor, revbac, deffor, defbac, "Y") = "N" THEN SlotGameCtr = SlotGameCtr + 1 'counts /n: games in this slot SimGameCtr = SimGameCtr + 1 'total number of games CALL SetSCHBookMark CALL UpdSCHRecord1 (" ") 'Start over with a "clean slate" GOSUB ResetData GOTO MenuOptions 'closes all files ELSE QuitPending = FALSE ForceCLS = TRUE GOTO MultiGames END IF END IF 'Normal manual mode IF STSOpen THEN CLOSE #3 STSOpen = FALSE END IF QPush CALL SameTeamsSetup (kc, Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) IF kc = KeyF3 THEN QPop ELSE IF FContents$(1) = "Y" THEN CALL RestFrSnapShot GOSUB ClearGameData RANDOMIZE TIMER REDIM amgr(2) AS GLOBAL LONG QPop IF Gfx THEN CALL EliminateHole(32) IF Gfx THEN CALL HideGfx PCOPY 2, 1 GOTO PickStarters ELSE GOSUB ResetData QPop GOTO MenuOptions END IF END IF CASE "R" IF Gfx AND RegDsply THEN CALL HideGfx QPush COLOR deffor, defbac CLS CALL ShowStandings (TRUE) CALL Prompt(1) QPop IF Gfx AND RegDsply THEN CALL ShowGfx CASE "S" QPush IF CmdStat$ > "!" THEN CALL StatsIO (Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) ELSE CALL Button(18+rowO, 15+colO, errattr, " You didn't specify a statistics file during setup. ", 0) SLEEP 2000 END IF QPop CASE "D" QPush CALL ShowDoc QPop CASE "Q" IF MMGame OR QuitPending OR PauseSw THEN SlotGameCtr = SlotGameCtr + 1 'counts /n: games in this "slot" SimGameCtr = SimGameCtr + 1 'total number of games IF SchedSw THEN CALL SetSCHBookMark CALL UpdSCHRecord1 (" ") END IF END IF GOTO ReturnToDOS END SELECT LOOP '---------------------------------------------- 'Simulation Ends 'Go back to MenuOptions if you want to continue '---------------------------------------------- ' Two-Team / Schedule / Series/ Command-line closing MultiPromptLoop: 'DrawSBFrame = TRUE ForceCLS = TRUE 'Debug screen. Use command line switch /debug to get here. IF CmdDeBug$ = "Y" THEN CLS LOCATE 2, 45 PRINT "SB Attempts by Succ.Rate"; LOCATE 3, 45 PRINT "< 40%", zz0; LOCATE 4, 45 PRINT "40-50:",zz1; LOCATE 5, 45 PRINT "50-60:",zz2; LOCATE 6, 45 PRINT "60-70:",zz3; LOCATE 7, 45 PRINT "70-80:",zz4; LOCATE 8, 45 PRINT "80-90:",zz5; LOCATE 9, 45 PRINT "90-99:",zz6; j = 0 k = 0 LOCATE 2, 2 PRINT "Pos ERR Chances %Err %Chances"; FOR i = 1 TO 9 LOCATE 2+i, 2 Chances = SumErrors(i) + SumPutouts(i) + SumAssists(i) PRINT i; ":"; SumErrors(i); Chances; j = j + SumErrors(i) k = k + Chances NEXT LOCATE 12, 2 PRINT "Tot:"; j; k; FOR i = 1 TO 9 LOCATE 2+i, 23 PRINT FFORMAT$(SumErrors(i) / j * 100, "###.#"); Chances = SumErrors(i) + SumPutouts(i) + SumAssists(i) PRINT FFORMAT$(Chances / k * 100, "###.#"); NEXT LOCATE 16, 2 PRINT "SB:"; zzzsb; LOCATE 17, 2 PRINT "CS:"; zzzcs; LOCATE 18, 2 PRINT "Catcher Throw. Errs:"; zzzcer; LOCATE 19, 2 PRINT "DP:"; zzzdp; LOCATE 20, 2 PRINT "WP:"; zzzwp; LOCATE 21, 2 PRINT "PB:"; zzzpb; LOCATE 22, 2 PRINT "PRun:"; zzzprun; LOCATE 23, 2 PRINT "Dbl-Sw:"; zzzDSW; LOCATE 3, 68 PRINT "SacOK:"; zzsacok; LOCATE 4, 68 PRINT "SacFail:"; zzsacfa; LOCATE 5, 68 PRINT "I-Walk1:"; zzziwalk1; LOCATE 6, 68 PRINT "I-Walk2:"; zzziwalk2; LOCATE 7, 68 PRINT "I-Walk3:"; zzziwalk3; LOCATE 8, 68 PRINT "P-Hit:"; zzzPH; LOCATE 9, 68 PRINT "St-Att-P:"; zzsabp; LOCATE 10, 68 PRINT "St-Suc-P:"; zzssbp; LOCATE 16, 30 PRINT "AvgTeamSpeed:"; zzzSumR / zzzSumN; LOCATE 17, 30 PRINT "Walk Adj:"; zzzWalkAdj; LOCATE 18, 30 PRINT "No Walk Adj:"; zzzNoWalkAdj; LOCATE 19, 30 PRINT "PitchOut:"; zzzPO; LOCATE 20, 30 PRINT "No PitchOut:"; zzzNoPO; LOCATE 21, 30 PRINT "Tot shutouts:"; zzzshutouts; LOCATE 22, 30 PRINT "Pit-p-Game(DAT):"; zzzpitpergame / zzzgames; LOCATE 15, 65 PRINT "Start. Pit. Removal"; FOR i = 1 TO 8 LOCATE i+15, 64 PRINT i; RemoveReason(i); NEXT IF ConsCols > 99 THEN LOCATE 16, 75: PRINT "Bombed early"; LOCATE 17, 75: PRINT "Bombed (7+)"; LOCATE 18, 75: PRINT "Bombed other"; LOCATE 19, 75: PRINT "Pitch Count"; LOCATE 20, 75: PRINT "C.G. Reduction"; LOCATE 21, 75: PRINT "PH - Gen Reliever"; LOCATE 22, 75: PRINT "PH - Closer"; LOCATE 23, 75: PRINT "PH (All)"; END IF x$ = WAITKEY$ CLS END IF IF RegDsply THEN COLOR deffor, defbac IF HoleStatus(32) THEN CALL EliminateHole(32) IF Gfx THEN CALL GraphHole(32, 11+rowO, 16+colO, 14+rowO, 65+colO) CALL DrawFrm(11+rowO, 16+colO, 14+rowO, 65+colO, defattr, nulls$, nulls$, 1, 0, 0) QPRINTs 12+rowO, 21+colO, "Your" + STR$(SimGameCtr) + " game simulation is complete! ", dimattr QPRINTs 13+rowO, 21+colO, "Select an Option from the list below.", dimattr ELSE IF CmdAutoExit$ <> "Y" THEN QPRINTs 19+rowO, 21+colO, "Your" + STR$(SimGameCtr) + " game simulation is complete! ", defattr IF Gfx THEN CALL HideGfx CALL ShowStandings (FALSE) END IF END IF IF CmdAutoExit$ <> "Y" THEN CALL Prompt(1) IF CmdStat$ > "!" THEN CLOSE #3 'closes .STS STSOpen = FALSE GOSUB SaveStatsToDisk 'opens #4 - dumps pit & bat -- closes #4 END IF IF CmdAutoExit$ = "Y" THEN GOTO QuickEnd DO i = 0 DO IF Gfx AND RegDsply THEN CALL UnfreezeAndRefresh END IF zS$ = WAITKEY$ IF LEN(zS$) = 4 THEN msx = MOUSEX msy = MOUSEY IF msy = ConsRows THEN zS$ = CHR$(SCREEN(msy, msx)) CALL FlashField (msy, msx, 1, 2, 100, 0) ELSE zS$ = nulls$ END IF ELSE zS$ = UCASE$(zS$) msx = 0 msy = 0 END IF i = INSTR("BCNRSDQ " + CHR$(27), zS$) LOOP UNTIL i SELECT CASE zS$ CASE "B" IF Gfx THEN CALL HideGfx QPush CALL Box CALL ListFile (CmdWritePath$ + "~BOX.PRN") COLOR deffor, defbac QPop IF Gfx AND RegDsply THEN CALL ShowGfx CASE "C" QPush GOSUB ShowScoreCard QPop CASE "N", CHR$(27), CHR$(32) 'Reset vital information and go back to menu GOSUB ResetData GOTO MenuOptions CASE "R" IF Gfx AND RegDsply THEN CALL HideGfx QPush COLOR deffor, defbac CLS CALL ShowStandings (TRUE) CALL Prompt(1) QPop IF Gfx AND RegDsply THEN CALL ShowGfx CASE "S" QPush IF CmdStat$ > "!" THEN CALL StatsIO (Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) ELSE CALL Button(18+rowO, 15+colO, errattr, " You didn't specify a statistics file during setup. ", 0) SLEEP 2000 END IF QPop CASE "D" QPush CALL ShowDoc QPop CASE "Q" GOTO LastChance END SELECT LOOP ReturnToDOS: IF CmdStat$ > "!" THEN GOSUB SaveStatsToDisk END IF 'One Last Chance to return to main menu if this is a schedule situation LastChance: CALL Button(17+rowO, 25+colO, defattr, " Return to Main Menu? [y/N] ", 0) LOCATE 17+rowO, 53+colO IF YESorNO$(revfor, revbac, deffor, defbac, "N") = "Y" THEN GOSUB ResetData GOTO MenuOptions END IF QuickEnd: CLOSE IF Gfx = FALSE THEN COLOR 7, 0 END IF EXIT FUNCTION ' ********************* GOSUBS begin here ************************** SetAutoMgr: amgr(1) = TRUE amgr(2) = TRUE RETURN AppendBox: OPEN CmdWritePath$ + "~BOX.PRN" FOR INPUT AS #40 IF LEFT$(xS$, 3) = "LPT" THEN OPEN xS$ FOR OUTPUT AS #20 LEN = 80 ELSE OPEN CmdWritePath$ + xS$ FOR APPEND AS #20 END IF PRINT #20, DATE$; " "; TIME$; PRINT #20, " #"; SimGameCtr + 1; PRINT #20, STRING$(42, "-"); IF LEN(SCHDate$) THEN PRINT #20, " "; SCHDate$ ELSE PRINT #20, STRING$(10, "-"); " " END IF IF n = 1 THEN FOR i = 1 TO GMx: PRINT #20, GMMessage(i): NEXT DO UNTIL EOF(40) LINE INPUT #40, field$ IF LEFT$(field$, 1) = "~" THEN field$ = MID$(field$, 2) PRINT #20, field$ LOOP CLOSE #20 CLOSE #40 RETURN BuildHiLiteMsg: IF ref <= MAXPLAYERS THEN Message$ = FULLNAME$(NameRef(ref, it)) + "," + xS$ RETURN SaveHiLite: IF HLx < 400 THEN ExSw = TRUE HLx = HLx + 1 HLRec(HLx).HLGameNo = SimGameCtr + 1 HLRec(HLx).HLMessage = Message$ END IF IF CmdStat$ > "!" THEN 'Save the Hi-Lite Message to a file .STH OPEN CmdWritePath$ + CmdStat$ + ".STH" FOR APPEND AS #6 LEN = 128 PRINT #6, PADRIGHT$(LTRIM$(STR$(SimGameCtr + 1)), 6) + Message$ CLOSE #6 END IF IF GMx < 5 THEN GMx = GMx + 1 GMMessage(GMx) = Message$ END IF RETURN DisplayPitchCount: n = nPitch(tm) m = (n / ExpectedPitchCount(ipa(tm), tm)) * 100 x$ = "Current pitcher's pitch-count:" + STR$(n) + " (" + LTRIM$(STR$(m)) + "%)" CALL PopMsg(12+rowO, 22+colO, x$, errattr, 0, kc) RETURN UpdateStats: 'Game Summary File SSum.VLeague = League(1) SSum.VDiv = Div(1) SSum.VNam = Names(1) SSum.VRuns = itruns(1) SSum.VHits = ithits(1) SSum.VErrs = iterrs(1) SSum.VLOB = GameLOB(1) SSum.VDPs = dp(1) SSum.HLeague = League(2) SSum.HDiv = Div(2) SSum.HNam = Names(2) SSum.HRuns = itruns(2) SSum.HHits = ithits(2) SSum.HErrs = iterrs(2) SSum.HLOB = GameLOB(2) SSum.HDPs = dp(2) SSum.WP = DataName(WPpit, WPteam) SSum.LP = DataName(LPpit, LPteam) IF SPpit > 0 AND SPpit <= TopPitLim AND SPteam > 0 THEN SSum.SP = DataName(SPpit, SPteam) ELSE SSum.SP = nulls$ END IF PUT #3,, SSum 'Batting/Fielding/Base-Running FOR it = 1 TO 2 'List each person (ref #) to appear in this spot "s" in the batting order 'Does not catch pitchers when DH active REDIM NameList$(MAXPLAYERS) Lx = 0 FOR s = 1 TO 9 L = LEN(RefByBO(s, it)) FOR p = 1 TO L - 1 STEP 2 ref = VAL(MID$(RefByBO(s, it), p, 2)) GOSUB UpdateBSum NEXT NEXT IF dh THEN FOR N = 1 TO np(it) ref = iyp(N, it) GOSUB UpdateBSum NEXT END IF NEXT 'Pitching FOR it = 1 TO 2 FOR N = 1 TO np(it) p = iyp(N, it) 'Did we already do pitcher "p"? 'It's possible a pitcher can enter a game more than once... i = 1 Found = FALSE DO WHILE i < N IF p = iyp(i, it) THEN Found = TRUE EXIT DO END IF INCR i LOOP IF Found THEN ITERATE FOR Find$ = League(it) + PADRIGHT$(Names(it), 12) + PADRIGHT$(NameRef(p, it), 16) TotalRecs = PSum(0).PGameCtr CALL BinarySearchP (PSum(), 1, 29, 1, TotalRecs, Find$, FoundAt, mini) IF FoundAt = 0 THEN IF TotalRecs >= DimmedPit THEN DimmedPit = DimmedPit + 540 'was 1020 REDIM PRESERVE PSum(0 TO DimmedPit) AS GLOBAL PitSummary END IF 'Adjust PSum() - Make a space for a new record FOR zz = TotalRecs + 1 TO mini + 1 STEP -1 PSum(zz) = PSum(zz - 1) NEXT 'Update TotalRecs PSum(0).PGameCtr = TotalRecs + 1 'Insert Default Record in slot mini PSum(mini).PLeague = League(it) PSum(mini).PTmNam = Names(it) PSum(mini).PNam = NameRef(p, it) PSum(mini).PThrows = UCASE$(HandRef(p, it)) PSum(mini).PGameCtr = 0 PSum(mini).PGames = 0 PSum(mini).PStarts = 0 PSum(mini).PCGs = 0 PSum(mini).PShOs = 0 PSum(mini).PInns = 0 PSum(mini).P3rds = 0 PSum(mini).PRuns = 0 PSum(mini).PERuns = 0 PSum(mini).PHits = 0 PSum(mini).P2Bs = 0 PSum(mini).P3Bs = 0 PSum(mini).PHRs = 0 PSum(mini).PBBs = 0 PSum(mini).PSOs = 0 PSum(mini).PHB = 0 PSum(mini).PWin = 0 PSum(mini).PLoss = 0 PSum(mini).PSave = 0 PSum(mini).PBS = 0 PSum(mini).PBF = 0 PSum(mini).PDaysOff = 0 PSum(mini).PJDate = 0 PSum(mini).PStreak = 0 FoundAt = mini END IF 'Update Memory "Record" PSum(FoundAt).PGameCtr = SimGameCtr PSum(FoundAt).PGames = PSum(FoundAt).PGames + 1 PSum(FoundAt).PInns = PSum(FoundAt).PInns + INT(mpo(p, it) / 3) PSum(FoundAt).P3rds = PSum(FoundAt).P3rds + mpo(p, it) MOD 3 PSum(FoundAt).PRuns = PSum(FoundAt).PRuns + mpr(p, it) PSum(FoundAt).PERuns = PSum(FoundAt).PERuns + mper(p, it) PSum(FoundAt).PHits = PSum(FoundAt).PHits + mph(p, it) PSum(FoundAt).P2Bs = PSum(FoundAt).P2Bs + mp2b(p, it) PSum(FoundAt).P3Bs = PSum(FoundAt).P3Bs + mp3b(p, it) PSum(FoundAt).PHRs = PSum(FoundAt).PHRs + mphr(p, it) PSum(FoundAt).PBBs = PSum(FoundAt).PBBs + mpw(p, it) PSum(FoundAt).PSOs = PSum(FoundAt).PSOs + mpk(p, it) PSum(FoundAt).PHB = PSum(FoundAt).PHB + mphb(p, it) PSum(FoundAt).PBS = PSum(FoundAt).PBS + mpBS(p, it) PSum(FoundAt).PBF = PSum(FoundAt).PBF + mpbf(p, it) 'Pitching "Streak" INCR PSum(FoundAt).PStreak 'Record W/L/S IF WPteam = it AND WPpit = p THEN PSum(FoundAt).PWin = PSum(FoundAt).PWin + 1 ELSEIF LPteam = it AND LPpit = p THEN PSum(FoundAt).PLoss = PSum(FoundAt).PLoss + 1 ELSEIF SPteam = it AND SPpit = p THEN PSum(FoundAt).PSave = PSum(FoundAt).PSave + 1 END IF 'Set "DaysOff" counter and Starts for used pitchers 'Save old DaysOff prv = PSum(FoundAt).PDaysOff 'Calculate new DaysOff innp! = mpo(p, it) / 3.0 IF N = 1 THEN PSum(FoundAt).PStarts = PSum(FoundAt).PStarts + 1 now = INT(SQR(3 * innp! / 4) + 1) ELSE i = INT(SQR(4 * innp!) - 1.4) IF i < 0 THEN i = 0 now = i END IF 'On used pitchers, DaysOff cannot go down, but can go up IF now <= prv THEN PSum(FoundAt).PDaysOff = prv ELSE PSum(FoundAt).PDaysOff = now END IF 'Penalty for pitching 3 games in a row IF PSum(FoundAt).PStreak = 3 THEN INCR PSum(FoundAt).PDaysOff END IF 'Set Julian Date for Schedules IF CmdSch$ > "!" THEN PSum(FoundAt).PJDate = JDATE(SchDate$) END IF 'Complete Games/Shutouts IF np(it) = 1 THEN 'there was only ONE pitcher so he gets a CG PSum(FoundAt).PCGs = PSum(FoundAt).PCGs + 1 IF mpr(p, it) = 0 THEN 'Shutout too PSum(FoundAt).PShOs = PSum(FoundAt).PShOs + 1 END IF END IF NEXT 'For UN-used pitchers, decrement "DaysOff" counter, zero PStreak counter FOR p = 10 TO LastPiAd(it) IF iused(p, it) = FALSE THEN Find$ = League(it) + PADRIGHT$(Names(it), 12) + PADRIGHT$(NameRef(p, it), 16) TotalRecs = PSum(0).PGameCtr CALL BinarySearchP (PSum(), 1, 29, 1, TotalRecs, Find$, FoundAt, mini) IF FoundAt THEN PSum(FoundAt).PStreak = 0 IF PSum(FoundAt).PDaysOff > 0 THEN IF CmdSch$ > "!" THEN nn = JDATE(SchDate$) m = nn - PSum(FoundAt).PJDate IF m < 0 THEN m = m + 365 IF m > 5 THEN m = 5 PSum(FoundAt).PDaysOff = MAX(PSum(FoundAt).PDaysOff - m, 0) PSum(FoundAt).PJDate = nn ELSE DECR PSum(FoundAt).PDaysOff END IF END IF END IF END IF NEXT NEXT 'Fielding FOR it = 1 TO 2 REDIM NameList$(MAXPLAYERS) Lx = 0 FOR ref = 1 TO MAXPLAYERS FOR ps = 1 TO 12 'Ignore pitchers in lineup so you don't update them twice IF ref > 9 OR ps <> 1 THEN IF GpPos(ref, it, ps) > 0 THEN GOSUB UpdateFSum END IF NEXT NEXT NEXT RETURN UpdateBSum: Find$ = League(it) + PADRIGHT$(Names(it), 12) + PADRIGHT$(NameRef(ref, it), 16) TotalRecs = BSum(0).BGameCtr CALL BinarySearchB (BSum(), 1, 29, 1, TotalRecs, Find$, FoundAt, mini) IF FoundAt = 0 THEN IF TotalRecs >= DimmedBat THEN DimmedBat = DimmedBat + 1020 REDIM PRESERVE BSum(0 TO DimmedBat) AS GLOBAL BatSummary END IF 'Adjust BSum() - Make space for new record FOR zz = TotalRecs + 1 TO mini + 1 STEP -1 BSum(zz) = BSum(zz - 1) NEXT 'Update TotalRecs in the array BSum(0).BGameCtr = TotalRecs + 1 'Insert Default Record in slot mini BSum(mini).BLeague = League(it) BSum(mini).BTmNam = Names(it) BSum(mini).BNam = NameRef(ref, it) IF HandRef(ref, it) = "r" THEN BSum(mini).BBats = "L" ELSEIF HandRef(ref, it) = "l" THEN BSum(mini).BBats = "R" ELSE BSum(mini).BBats = HandRef(ref, it) END IF BSum(mini).BGameCtr = 0 BSum(mini).BGames = 0 BSum(mini).BABs = 0 BSum(mini).BABsRHP = 0 BSum(mini).BABsLHP = 0 BSum(mini).BRuns = 0 BSum(mini).BHits = 0 BSum(mini).BHitsRHP = 0 BSum(mini).BHitsLHP = 0 BSum(mini).BRBIs = 0 BSum(mini).B2Bs = 0 BSum(mini).B2BsRHP = 0 BSum(mini).B2BsLHP = 0 BSum(mini).B3Bs = 0 BSum(mini).B3BsRHP = 0 BSum(mini).B3BsLHP = 0 BSum(mini).BHRs = 0 BSum(mini).BHRsRHP = 0 BSum(mini).BHRsLHP = 0 BSum(mini).BSBs = 0 BSum(mini).BCSs = 0 BSum(mini).BBBs = 0 BSum(mini).BBBsRHP = 0 BSum(mini).BBBsLHP = 0 BSum(mini).BKs = 0 BSum(mini).BKsRHP = 0 BSum(mini).BKsLHP = 0 BSum(mini).BHB = 0 BSum(mini).BGDP = 0 BSum(mini).BSacF = 0 BSum(mini).BSacB = 0 BSum(mini).BErrs = 0 BSum(mini).BStreak = 0 FoundAt = mini END IF 'Update Memory "Record" BSum(FoundAt).BGameCtr = SimGameCtr 'Increment Games (if player has more than one ref number, only update games once) 'Search NameList$ to see if we've already done his name Found = FALSE i = 1 DO IF NameRef(ref, it) = NameList$(i) THEN Found = TRUE EXIT DO END IF INCR i LOOP UNTIL i > Lx IF NOT Found THEN INCR Lx NameList$(Lx) = NameRef(ref, it) BSum(FoundAt).BGames = BSum(FoundAt).BGames + 1 END IF BSum(FoundAt).BABs = BSum(FoundAt).BABs + mab(ref, it) BSum(FoundAt).BABsRHP = BSum(FoundAt).BABsRHP + mabRHP(ref, it) BSum(FoundAt).BABsLHP = BSum(FoundAt).BABsLHP + mabLHP(ref, it) BSum(FoundAt).BRuns = BSum(FoundAt).BRuns + mruns(ref, it) BSum(FoundAt).BHits = BSum(FoundAt).BHits + mhits(ref, it) BSum(FoundAt).BHitsRHP = BSum(FoundAt).BHitsRHP + mhitsRHP(ref, it) BSum(FoundAt).BHitsLHP = BSum(FoundAt).BHitsLHP + mhitsLHP(ref, it) BSum(FoundAt).BRBIs = BSum(FoundAt).BRBIs + mrbi(ref, it) BSum(FoundAt).B2Bs = BSum(FoundAt).B2Bs + m2b(ref, it) BSum(FoundAt).B2BsRHP = BSum(FoundAt).B2BsRHP + m2bRHP(ref, it) BSum(FoundAt).B2BsLHP = BSum(FoundAt).B2BsLHP + m2bLHP(ref, it) BSum(FoundAt).B3Bs = BSum(FoundAt).B3Bs + m3b(ref, it) BSum(FoundAt).B3BsRHP = BSum(FoundAt).B3BsRHP + m3bRHP(ref, it) BSum(FoundAt).B3BsLHP = BSum(FoundAt).B3BsLHP + m3bLHP(ref, it) BSum(FoundAt).BHRs = BSum(FoundAt).BHRs + mhr(ref, it) BSum(FoundAt).BHRsRHP = BSum(FoundAt).BHRsRHP + mhrRHP(ref, it) BSum(FoundAt).BHRsLHP = BSum(FoundAt).BHRsLHP + mhrLHP(ref, it) BSum(FoundAt).BSBs = BSum(FoundAt).BSBs + msb(ref, it) BSum(FoundAt).BCSs = BSum(FoundAt).BCSs + mcs(ref, it) BSum(FoundAt).BBBs = BSum(FoundAt).BBBs + mbb(ref, it) BSum(FoundAt).BBBsRHP = BSum(FoundAt).BBBsRHP + mbbRHP(ref, it) BSum(FoundAt).BBBsLHP = BSum(FoundAt).BBBsLHP + mbbLHP(ref, it) BSum(FoundAt).BKs = BSum(FoundAt).BKs + mso(ref, it) BSum(FoundAt).BKsRHP = BSum(FoundAt).BKsRHP + msoRHP(ref, it) BSum(FoundAt).BKsLHP = BSum(FoundAt).BKsLHP + msoLHP(ref, it) BSum(FoundAt).BErrs = BSum(FoundAt).BErrs + merr(ref, it) BSum(FoundAt).BHB = BSum(FoundAt).BHB + mhb(ref, it) BSum(FoundAt).BGDP = BSum(FoundAt).BGDP + mGDP(ref, it) BSum(FoundAt).BSacF = BSum(FoundAt).BSacF + mSacF(ref, it) BSum(FoundAt).BSacB = BSum(FoundAt).BSacB + mSacB(ref, it) IF mhits(ref, it) > 0 THEN BSum(FoundAt).BStreak = BSum(FoundAt).BStreak + 1 ELSE IF mab(ref, it) > 0 THEN i = BSum(FoundAt).BStreak IF i >= HiLvlBStr THEN xS$ = STR$(i) + "-game streak ends" GOSUB BuildHiLiteMsg GOSUB SaveHiLite END IF BSum(FoundAt).BStreak = 0 END IF END IF RETURN 'TYPE FldSummary ' FLeague AS STRING * 1 ' FTmNam AS STRING * 12 ' FNam AS STRING * 16 ' FThrows AS STRING * 1 ' FCount AS INTEGER ' FGamesByPos (1 TO 12) AS LONG ' 11=PH 12=PR ' FErrsByPos (1 TO 10) AS LONG ' 20 ' FPutOutsByPos(1 TO 10) AS LONG ' 20 ' FAssistsByPos(1 TO 10) AS LONG ' 20 'END TYPE UpdateFSum: 'Feed this ref, it, ps Find$ = League(it) + PADRIGHT$(Names(it), 12) + PADRIGHT$(NameRef(ref, it), 16) TotalRecs = FSum(0).FCount CALL BinarySearchF (FSum(), 1, 29, 1, TotalRecs, Find$, FoundAt, mini) IF FoundAt = 0 THEN IF TotalRecs >= DimmedFld THEN DimmedFld = DimmedFld + 1020 '540 REDIM PRESERVE FSum(0 TO DimmedFld) AS GLOBAL FldSummary END IF 'Adjust FSum() - Make space for new record FOR zz = TotalRecs + 1 TO mini + 1 STEP -1 FSum(zz) = FSum(zz - 1) NEXT 'Update TotalRecs in the array FSum(0).FCount = TotalRecs + 1 'Insert Default Record in slot mini FSum(mini).FLeague = League(it) FSum(mini).FTmNam = Names(it) FSum(mini).FNam = NameRef(ref, it) FSum(mini).FThrows = UCASE$(HandRef(ref, it)) FSum(mini).FCount = 0 FOR i = 1 TO 12 FSum(mini).FGamesByPos(i) = 0 NEXT FOR i = 1 TO 10 FSum(mini).FErrsByPos(i) = 0 FSum(mini).FPutOutsByPos(i) = 0 FSum(mini).FAssistsByPos(i) = 0 NEXT FoundAt = mini END IF 'Update Memory "Record" INCR FSum(FoundAt).FGamesByPos(ps) FSum(FoundAt).FErrsByPos(ps) = FSum(FoundAt).FErrsByPos(ps) + _ GpPos(ref, it, ps) - 1 IF ps < 11 THEN 'Only update "count" once per player - he may have two "ref" numbers, multiple "ps" 'Search NameList$ to see if we've already done his name Found = FALSE i = 1 DO IF NameRef(ref, it) = NameList$(i) THEN Found = TRUE EXIT DO END IF INCR i LOOP UNTIL i > Lx IF NOT Found THEN INCR Lx NameList$(Lx) = NameRef(ref, it) INCR FSum(FoundAt).FCount END IF 'Old way ' IF OncePerPlayer = TRUE THEN ' INCR FSum(FoundAt).FCount ' OncePerPlayer = FALSE ' END IF FSum(FoundAt).FPutOutsByPos(ps) = FSum(FoundAt).FPutOutsByPos(ps) + _ PutOuts(ref, it, ps) FSum(FoundAt).FAssistsByPos(ps) = FSum(FoundAt).FAssistsByPos(ps) + _ Assists(ref, it, ps) END IF RETURN SaveStatsToDisk: IF Silence = FALSE THEN CALL PopMsg(17+rowO, 29+colO, "Saving stats to disk...", defattr, 1, kc) OPEN CmdWritePath$ + CmdStat$ + ".STB" FOR RANDOM AS #4 LEN=LEN(BSum(0)) Recs = BSum(0).BGameCtr BSum(0).BGames = SimGameCtr FOR n = 0 TO Recs PUT #4,, BSum(n) NEXT CLOSE #4 OPEN CmdWritePath$ + CmdStat$ + ".STP" FOR RANDOM AS #4 LEN=LEN(PSum(0)) Recs = PSum(0).PGameCtr FOR n = 0 TO Recs PUT #4,, PSum(n) NEXT CLOSE #4 OPEN CmdWritePath$ + CmdStat$ + ".STF" FOR RANDOM AS #4 LEN=LEN(FSum(0)) Recs = FSum(0).FCount FOR n = 0 TO Recs PUT #4,, FSum(n) NEXT CLOSE #4 RETURN Normalization: 'this part could be anywhere after CmdEra$ is set: p4baseNorm! = 0 IF LEN(CmdEra$) = 5 THEN arg$ = CmdEra$ GOSUB SearchLAvg 'return FoundSw, ndx for "Norm" year IF FoundSw THEN p4baseNorm! = LAvg(ndx).LAvgHR p3baseNorm! = LAvg(ndx).LAvg3B p2baseNorm! = LAvg(ndx).LAvg2B p1baseNorm! = LAvg(ndx).LAvg1B pwbaseNorm! = LAvg(ndx).LAvgBB prbaseNorm! = LAvg(ndx).LAvgRG LgTotInns(3) = LAvg(ndx).Innings LgTotHits(3) = LAvg(ndx).Hits LgTot2B(3) = LAvg(ndx).Doubles LgTot3B(3) = LAvg(ndx).Triples LgTotHR(3) = LAvg(ndx).HR LgTotBB(3) = LAvg(ndx).BB RunsPerGame(3) = LAvg(ndx).LAvgRG END IF END IF RETURN '************ This is the GOSUB that reads in the .DAT files. ************ LoadDATFile: 'Requires "it" LastPiAd(it) = 0 DHDATOvr(it) = 0 Gender(it) = 0 'Default is male TeamAttr(it) = 0 IF INSTR(DataFil(it), ".") = 0 THEN DataFil(it) = DataFil(it) + ".DAT" IF LEN(DIR$(CmdPath$ + DataFil(it))) = 0 THEN MyBeep x$ = "Team Data-File: " + CmdPath$ + DataFil(it) + " not found!|" x$ = x$ + "Hit any key to Abort." CALL ErrorBox(x$) Abort = TRUE RETURN END IF OPEN CmdPath$ + DataFil(it) FOR INPUT AS #1 LEN = 128 z = 0 i = 0 DO WHILE NOT EOF(1) LDF1: LINE INPUT #1, rec$ L = LEN(rec$) 'Ignore blank lines IF L = 0 THEN IF EOF(1) THEN EXIT DO ELSE GOTO LDF1 END IF END IF 'Ignore semicolon lines IF LEFT$(rec$, 1) = ";" THEN IF EOF(1) THEN EXIT DO ELSE GOTO LDF1 END IF END IF IF MID$(rec$, 1, 2) = "##" THEN EXIT DO IF L < 100 THEN rec$ = rec$ + SPACE$(100 - L) ' Check for Header record IF MID$(rec$, 1, 1) = "*" AND i = 0 THEN League(it) = UCASE$(MID$(rec$, 2, 1)) Div(it) = UCASE$(MID$(rec$, 10, 1)) Century(it) = MID$(rec$, 11, 2) Year(it) = MID$(rec$, 11, 4) Names(it) = MID$(rec$, 13, 12) arg$ = MID$(rec$, 11, 4) + League(it) GOSUB SearchLAvg 'return FoundSw, ndx - points to DEF if necessary IF FoundSw THEN pwbaseF(it) = LAvg(ndx).LAvgBB pkbaseF(it) = LAvg(ndx).LAvgSO psbaseF(it) = LAvg(ndx).LAvgS2 p1baseF(it) = LAvg(ndx).LAvg1B p2baseF(it) = LAvg(ndx).LAvg2B p3baseF(it) = LAvg(ndx).LAvg3B p4baseF(it) = LAvg(ndx).LAvgHR TeamsInLeague(it) = LAvg(ndx).LTeams RunsPerGame(it) = LAvg(ndx).LAvgRG LeagueRating(it) = LAvg(ndx).Rating LgTotInns(it) = LAvg(ndx).Innings LgTotHits(it) = LAvg(ndx).Hits LgTot2B(it) = LAvg(ndx).Doubles LgTot3B(it) = LAvg(ndx).Triples LgTotHR(it) = LAvg(ndx).HR LgTotBB(it) = LAvg(ndx).BB ' LOCATE 8, 37 ' PRINT arg$; " = "; LAvg(ndx).LAvgYr; LAvg(ndx).LAvgLg; ' SLEEP 10000 ELSE 'Load Default Case - No .CFG data found pwbaseF(it) = .0815 pkbaseF(it) = .230 psbaseF(it) = .140 p1baseF(it) = .1575 p2baseF(it) = .0385 p3baseF(it) = .0053 p4baseF(it) = .019 TeamsInLeague(it) = 0 RunsPerGame(it) = 5.0 LeagueRating(it) = 100 LgTotInns(it) = 23107 LgTotHits(it) = 23624 LgTot2B(it) = 4622 LgTot3B(it) = 516 LgTotHR(it) = 2997 LgTotBB(it) = 9847 ' LOCATE 8, 37 ' PRINT arg$; " = SYS "; ' SLEEP 9000 END IF ' Percentage of hits which are singles, doubles, etc. for this league bF! = p1baseF(it) + p2baseF(it) + p3baseF(it) + p4baseF(it) phit1bF(it) = p1baseF(it) / bF! phit2bF(it) = p2baseF(it) / bF! phit3bF(it) = p3baseF(it) / bF! phit4bF(it) = p4baseF(it) / bF! 'Check Column headers for clues to interpret data x$ = UCASE$(MID$(rec$, 65, 3)) y$ = UCASE$(MID$(rec$, 68, 3)) IF INSTR(x$, "SB") AND INSTR(y$, "CS") THEN StBSw(it) = -1 ELSEIF INSTR(x$, "SB") THEN StBSw(it) = 1 ELSE StBSw(it) = 0 END IF ERRSw(it) = (UCASE$(MID$(rec$, 62, 2)) = "ER") 'Errors instead of Def. Percentage END IF 'Second occurence of "*" is ignored (*Pitchers) 'Third occurence of "*" is start of bench (*Bench) 'Fourth occurence of "*" is start of optional information IF MID$(rec$, 1, 1) = "*" THEN IF i > 9 THEN 'was 11 for 3 pitchers IF LastPiAd(it) = 0 THEN LastPiAd(it) = i ELSE x$ = UCASE$(RTRIM$(MID$(rec$, 2))) IF LEN(x$) THEN n = PARSECOUNT(x$) FOR nn = 1 TO n p$ = RTRIM$(LTRIM$(PARSE$(x$, nn))) pp$ = LEFT$(p$, 3) IF pp$ = "PE=" THEN j = INSTR(p$, "/") IF j THEN HBF!(it) = VAL(MID$(p$, 4, j-4)) / 100 HPF!(it) = VAL(MID$(p$, j+1)) / 100 ELSE HBF!(it) = VAL(MID$(p$, 4)) / 100 HPF!(it) = HBF!(it) END IF 'Test de-magnification (20% - use .8) HBF!(it) = 1.00 + (HBF!(it) - 1) * .8 HPF!(it) = 1.00 + (HPF!(it) - 1) * .8 IF HBF!(it) < .20 THEN HBF!(it) = .2 IF HBF!(it) > 5. THEN HBF!(it) = 5.0 IF HPF!(it) < .20 THEN HPF!(it) = .2 IF HPF!(it) > 5. THEN HPF!(it) = 5.0 IF it = 2 THEN CurrParkBF! = HBF!(2) CurrParkPF! = HPF!(2) END IF END IF IF it = 2 THEN IF pp$ = "PH=" THEN z$ = MID$(p$, 4) IF LEN(DIR$(z$)) > 0 THEN BackgroundPic$ = z$ END IF END IF IF LEFT$(p$, 4) = "DH=Y" THEN DHDATOvr(it) = -1 END IF IF LEFT$(p$, 4) = "DH=N" THEN DHDATOvr(it) = 1 END IF IF LEFT$(p$, 5) = "GEN=F" THEN Gender(it) = -1 END IF IF LEFT$(p$, 4) = "COL=" THEN z$ = MID$(p$, 5) j = 0 DO IF ColorDescTable$(j) = z$ THEN EXIT DO INCR j LOOP WHILE j < 16 IF j < 16 THEN 'Foreground color is always 15(bright) unless background is similar 'IF j = 7 OR j = 15 THEN m = 0 ELSE m = 15 SELECT CASE j CASE 7, 10, 11, 14, 15 m = 0 CASE ELSE m = 15 END SELECT TeamAttr(it) = CALCATTR(m, j) END IF IF it = 2 THEN IF TeamAttr(1) = TeamAttr(2) THEN TeamAttr(1) = CALCATTR(0, 7) 'black on grey END IF END IF END IF IF LEFT$(p$, 5) = "LOGO=" THEN z$ = MID$(p$, 6) IF LEN(DIR$(z$)) > 0 THEN TeamLogo(it) = z$ END IF NEXT END IF END IF END IF END IF 'Regular data line: IF MID$(rec$, 1, 1) <> "*" AND i < MAXPLAYERS THEN INCR i DataRef(i, it) = i DataPlat(i, it) = MID$(rec$, 5, 1) DataPos(i, it) = VAL(MID$(rec$, 7, 2)) 'In case somebody puts a pitcher on the bench, change the position! IF LastPiAd(it) > 0 AND DataPos(i, it) = 1 THEN DataPos(i, it) = 9 xS$ = MID$(rec$, 10, 18) IF LEN(FIRSTNAME$(xS$)) THEN DataName(i, it) = LASTNAME$(xS$) + ", " + FIRSTNAME$(xS$) ELSE DataName(i, it) = LASTNAME$(xS$) END IF DataAB(i, it) = VAL(MID$(rec$, 28, 3)) IF DataAB(i, it) = 0 THEN DataAB(i, it) = 1 DataHits(i, it) = VAL(MID$(rec$, 32, 3)) Data2B(i, it) = VAL(MID$(rec$, 36, 3)) Data3B(i, it) = VAL(MID$(rec$, 40, 3)) DataHR(i, it) = VAL(MID$(rec$, 44, 3)) DataBB(i, it) = VAL(MID$(rec$, 48, 3)) DataHP(i, it) = MID$(rec$, 51, 1) DataSO(i, it) = VAL(MID$(rec$, 52, 3)) DataRBI(i, it) = VAL(MID$(rec$, 56, 3)) DataHand(i, it) = MID$(rec$, 60, 1) DataDef(i, it) = VAL(MID$(rec$, 62, 3)) '/Wins DataSB(i, it) = VAL(MID$(rec$, 65, 3)) '/Losses (old speed) DataCS(i, it) = VAL(MID$(rec$, 68, 3)) '/Saves DataGames(i, it)= VAL(MID$(rec$, 72, 3)) DataCode(i, it) = MID$(rec$, 81, 1) 'Pit. Hit. Code FOR n = 1 TO 4 '/n=1 Starts DataGbyP(i, it, n) = VAL(MID$(rec$, 70 + (n * 6), 3)) IF DataGbyP(i, it, n) > 0 THEN cS$ = MID$(rec$, 74 + (n * 6), 1) IF UCASE$(cS$) = "D" THEN DataPosi(i, it, n) = 10 ELSE DataPosi(i, it, n) = VAL(cS$) END IF ELSE DataPosi(i, it, n) = 0 END IF NEXT 'Get rid of any games listed as pitcher FOR n = 1 TO 4 IF DataPosi(i, it, n) = 1 THEN nn = n DO WHILE nn < 4 DataPosi(i, it, nn) = DataPosi(i, it, nn+1) DataGbyP(i, it, nn) = DataGbyP(i, it, nn+1) INCR nn LOOP DataPosi(i, it, 4) = 0 DataGbyP(i, it, 4) = 0 END IF NEXT 'Batting stats for pitchers IF i > 9 AND i <= TopPitLim THEN IF LastPiAd(it) = 0 AND DataPos(i, it) = 1 THEN DataPBatAB(i, it) = VAL(MID$(rec$, 83, 3)) 'AB DataPBatHi(i, it) = VAL(MID$(rec$, 87, 3)) 'Hits DataPBatHR(i, it) = VAL(MID$(rec$, 91, 2)) 'HR DataPBatBB(i, it) = VAL(MID$(rec$, 94, 3)) 'BB DataPBatSO(i, it) = VAL(MID$(rec$, 98, 3)) 'SO END IF END IF 'Reference attributes NameRef(i, it) = DataName(i, it) OrgPos(i, it) = DataPos(i, it) HandRef(i, it) = DataHand(i, it) END IF LOOP CLOSE #1 Last = i 'Scan pitchers to determine MgrStyle and Data format pHRind(it) = FALSE NewStyle(it) = FALSE NewStyleWithSaves(it) = FALSE PitchersPerGame(it) = 2.5 l = 0: m = 0: n = 0 FOR i = 10 TO LastPiAd(it) IF DataHR(i, it) THEN pHRind(it) = TRUE l = l + DataGames(i, it) 'games m = m + DataGbyP(i, it, 1) 'starts n = n + DataCS(i, it) 'saves NEXT IF l > 0 AND m > 0 THEN NewStyle(it) = TRUE IF n > 0 THEN NewStyleWithSaves(it) = TRUE PitchersPerGame(it) = l / m 'x$ = "Team" + STR$(it) + " - PitchersPerGame:" + STR$(PitchersPerGame(it)) 'CALL ErrorBox (x$) END IF 'Scan hitters for speed rating (Sum CS for non-pitchers) m = 0 FOR i = 1 TO 9 IF DataPos(i, it) > 1 THEN m = m + DataCS(i, it) NEXT l = 0 'sum speed-ratings p = 0 'player counter FOR i = 1 TO Last IF DataPos(i, it) > 1 THEN 'Calculate a speed-rating xF! = DataHits(i, it) + DataBB(i, it) - Data2B(i, it) - Data3B(i, it) - DataHR(i, it) IF xF! < 1 THEN xF! = 1 IF StBSw(it) <> 0 THEN 'Header is "SB & CS" or "SB" IF m > 0 THEN n = DataCS(i, it) ELSE n = DataSB(i, it) * .27 END IF 'SB% SpS1! = ((DataSB(i, it) + 3)/(DataSB(i, it) + n + 7) - 0.4) * 20 'Attempts SpS2! = SQR( (DataSB(i, it) + n) / xF! ) / 0.07 'Triples SpS3! = Data3B(i, it) / (DataAB(i, it) - DataHR(i, it) - DataSO(i, it) ) / 0.02 * 10 'Some old-timer seasons have so many triples is makes everyone a speed demon... IF SpS3! > 11. THEN SpS3! = 11. 'Weighted-average with triples 40% less important than 'the other two factors DataSpeed(i, it) = (SpS1! * 10 + SpS2! * 10 + SpS3! * 6) / 26 IF DataSpeed(i, it) > 9 THEN DataSpeed(i, it) = 9 IF DataSpeed(i, it) < 1 THEN DataSpeed(i, it) = 1 ELSE 'Header is presumably "S" DataSpeed(i, it) = VAL(MID$(rec$, 66, 2)) DataSB(i, it) = 0 DataCS(i, it) = 0 IF DataSpeed(i, it) < 1 THEN DataSpeed(i, it) = 1 END IF l = l + DataSpeed(i, it) INCR p END IF NEXT TeamSpeed(it) = l / p IF TeamSpeed(it) < 1.0 THEN TeamSpeed(it) = 1.0 '2.5 'LOCATE 10, 20 'print " "; 'locate 10, 20 'print "team speed "; DataFil(it); TeamSpeed(it); 'PauseIt 'Scan for Duplicate Last Names and record them in the DLN array FOR i = 1 TO Last - 1 xS$ = LASTNAME$(NameRef(i, it)) FOR j = (i + 1) TO Last yS$ = LASTNAME$(NameRef(j, it)) IF xS$ = yS$ THEN DLN(i, it) = TRUE DLN(j, it) = TRUE END IF NEXT NEXT 'See if any pitchers are also on the bench or in lineup in the .DAT DupNameTeam(it) = FALSE FOR i = 10 TO LastPiAd(it) SearchName$ = DataName(i, it) c3 = SearchDAT(1, 9, it, SearchName$, 0) IF c3 THEN DupNameTeam(it) = TRUE: EXIT FOR c4 = SearchDAT(LastPiAd(it) + 1, Last, it, SearchName$, 0) IF c4 THEN DupNameTeam(it) = TRUE: EXIT FOR NEXT 'Is there a pitcher's slot (or DH) in the starting lineup? m = FALSE FOR i = 1 TO 9 IF DataPos(i, it) = 1 OR DataPos(i, it) = 10 THEN m = TRUE : EXIT FOR NEXT IF m = FALSE THEN MyBeep x$ = "Team Data-File: " + CmdPath$ + DataFil(it) + "|" x$ = x$ + "No pitcher or DH in Lineup|" x$ = x$ + "This is a problem. Please correct the .DAT file.|" x$ = x$ + "(Make sure a '1' is in column 8 in the pitcher's batting|" x$ = x$ + "slot if a DH is not used in your default line-up.)" CALL ErrorBox(x$) END IF RETURN SearchLAvg: ' LAvg must be DIMed ' In: arg$ ' Out: ndx, FoundSw ' Don't use "i" in here! FoundSw = FALSE ndx = 1 DO UNTIL ndx > LAvgNdx OR ndx > 300 xS$ = LAvg(ndx).LAvgYr + LAvg(ndx).LAvgLg IF arg$ = xS$ THEN FoundSw = TRUE: RETURN ndx = ndx + 1 LOOP ' "YYYYL" not found in table. Does "DEF L" exist in table? newarg$ = "DEF " + MID$(arg$, 5, 1) ndx = 1 DO UNTIL ndx > LAvgNdx OR ndx > 300 xS$ = LAvg(ndx).LAvgYr + LAvg(ndx).LAvgLg IF newarg$ = xS$ THEN FoundSw = TRUE: RETURN ndx = ndx + 1 LOOP RETURN ShowScoreCard: REDIM List1(1 TO 300) AS List1Type CALL LoadScoreCardToList1 (List1(), j) 'j returns items in list rr = ConsRows - 9 re = ConsRows - 2 c1 = (ConsCols - 78) \ 2 '68 c2 = ConsCols - c1 IF Gfx THEN CALL GraphHole(30, 6, c1, re, c2) CALL DrawFrm(6, c1, re, c2, defattr, "Score Card", "ESC PgUp PgDown [P]rint [F]ile", 0, 0, 1) QPRINTs MidRow, c2, "µ", defattr QPRINTs MidRow+1, c2, UpPtr$, defattr QPRINTs MidRow+2, c2, DnPtr$, defattr QPRINTs MidRow+3, c2, "¶", defattr RetKey = -98 'Display List only IF CmdScrF$ < "!" THEN xS$ = "SCORECRD.LOG" ELSE xS$ = CmdScrF$ ' 32, 6, c1, re, c2, dimattr, revattr, Pick, RetKey, xS$, mous, ms$) CALL PickFromList(List1(), j, rr, 2, 37, 6, c1, re, c2, dimattr, revattr, Pick, RetKey, xS$, mous, ms$) IF Gfx THEN CALL EliminateHole(30) ERASE List1 RETURN OpenStatFiles: REDIM NameList$(MAXPLAYERS) 'If CmdStat$ already exists, check for current format IF LEN(DIR$(CmdWritePath$ + CmdStat$ + ".STP")) THEN CALL CheckForValidFile (CmdWritePath$ + CmdStat$ + ".STP", 126, Valid1) ELSE Valid1 = TRUE END IF IF LEN(DIR$(CmdWritePath$ + CmdStat$ + ".STB")) THEN CALL CheckForValidFile (CmdWritePath$ + CmdStat$ + ".STB", 162, Valid2) ELSE Valid2 = TRUE END IF IF NOT Valid1 OR NOT Valid2 THEN MyBeep x$ = " Hmmm. The stat file you selected appears to have been | generated from " x$ = x$ + "an older version of SBS and cannot be used | with this version. " x$ = x$ + "Returning to the main menu." CALL ErrorBox(x$) ' CALL DrawFrm(10, 7, 17, 73, defattr, nulls$, "Any Key to Continue", 1, 0, 0) ' LOCATE 12, 9 ' PRINT "Hmmm. The stat file you selected appears to have been generated from "; ' LOCATE 13, 9 ' PRINT "an older version of SBS and cannot be used. "; ' LOCATE 15, 9 ' PRINT "You will be returned to the main menu in 5 seconds."; ' SLEEP 5000 CmdStat$ = nulls$ CLOSE GOTO MenuOptions END IF 'Game Summary File OPEN CmdWritePath$ + CmdStat$ + ".STS" FOR RANDOM AS #3 LEN = LEN(SSum) n = LOF(3) / LEN(SSum) SEEK #3, n + 1 'position random file to append STSOpen = TRUE 'Batter File (memory) 'Does the Batter Array exist on disk? IF LEN(DIR$(CmdWritePath$ + CmdStat$ + ".STB")) THEN 'Read directly back into array if possible OPEN CmdWritePath$ + CmdStat$ + ".STB" FOR RANDOM AS #4 LEN=LEN(BatSummary) Recs = LOF(4) / LEN(BatSummary) n = (Recs \ 1020) + 1 DimmedBat = 1020 * n REDIM BSum(0 TO DimmedBat) AS GLOBAL BatSummary FOR n = 0 TO Recs - 1 GET #4,, BSum(n) NEXT CLOSE #4 ELSE REDIM BSum(0 TO 1020) AS GLOBAL BatSummary DimmedBat = 1020 'Initialize new array - Store record count in 0th record BSum(0).BGameCtr = 1 'Create record #1 BSum(1).BLeague = STRING$(1, "Z") BSum(1).BTmNam = STRING$(12,"Z") BSum(1).BNam = STRING$(16,"Z") END IF 'Pitchers (memory) 'Does the Pitcher Array exist on disk? IF LEN(DIR$(CmdWritePath$ + CmdStat$ + ".STP")) THEN OPEN CmdWritePath$ + CmdStat$ + ".STP" FOR RANDOM AS #4 LEN=LEN(PitSummary) Recs = LOF(4) / LEN(PitSummary) n = (Recs \ 540) + 1 DimmedPit = 540 * n REDIM PSum(0 TO DimmedPit) AS GLOBAL PitSummary FOR n = 0 TO Recs - 1 GET #4,, PSum(n) NEXT CLOSE #4 ELSE 'Initialize new array - Store record count in 0th record REDIM PSum(0 TO 540) AS GLOBAL PitSummary DimmedPit = 540 PSum(0).PGameCtr = 1 'Create 1st record in PSum Array PSum(1).PLeague = STRING$(1, "Z") PSum(1).PTmNam = STRING$(12,"Z") PSum(1).PNam = STRING$(16,"Z") END IF 'Fielding File (memory) 'Does the Field Array exist on disk? IF LEN(DIR$(CmdWritePath$ + CmdStat$ + ".STF")) THEN 'Read directly back into array if possible OPEN CmdWritePath$ + CmdStat$ + ".STF" FOR RANDOM AS #4 LEN=LEN(FldSummary) Recs = LOF(4) / LEN(FldSummary) n = (Recs \ 1020) + 1 DimmedFld = 1020 * n REDIM FSum(0 TO DimmedFld) AS GLOBAL FldSummary FOR n = 0 TO Recs - 1 GET #4,, FSum(n) NEXT CLOSE #4 ELSE 'Initialize new array - Store record count in 0th record REDIM FSum(0 TO 1020) AS GLOBAL FldSummary DimmedFld = 1020 FSum(0).FCount = 1 'Create record #1 FSum(1).FLeague = STRING$(1, "Z") FSum(1).FTmNam = STRING$(12,"Z") FSum(1).FNam = STRING$(16,"Z") END IF RETURN SkedAskDH: CALL DrawFrm(14+rowO, 12+colO, 17+rowO, 66+colO, defattr, nulls$, nulls$, 1, 0, 1) DO 'This only loops on invalid input and redisplays the default every time QPRINTs 15+rowO, 14+colO, " Use Designated Hitter? ", dimattr QPRINTs 16+rowO, 14+colO, " [H]ome Team Rules [A]lways [E]ither [N]ever ", dimattr xS$ = DefaultDHResponse$ yS$ = MYINPUT$(FALSE, KeyEscape, CustomEscKey, KeyAccept, kc, revfor, revbac, 15+rowO, 39+colO, 1, "X?", 0, 0, xS$, msx, msy) IF msx > 0 AND msy > 0 THEN yS$ = CHR$(SCREEN(msy, msx)) IF yS$ = CloseButton$ THEN yS$ = DefaultDHResponse$ END IF END IF LOOP UNTIL INSTR("HAEYN", yS$) CmdDH$ = yS$ RETURN CheckForQuit: IF SchedSw THEN IF RegDsply = 0 THEN QuitPending = TRUE CALL Button(2+rowO, 33+colO, errattr, " Quit Pending ", 0) ELSE xS$ = " Hit 'Q' again to CANCEL this game NOW; any other to finish this game. " xS$ = SubDoubleQuote$ (xS$) CALL PopMsg(18+rowO, 5+colO, xS$, errattr, 0, kc) IF kc = 81 OR kc = 113 THEN 'Q IF CmdStat$ > "!" THEN GOSUB SaveStatsToDisk END IF CALL SetSCHBookMark CALL UpdSCHRecord1 (" ") GOTO QuickEnd END IF QuitPending = TRUE END IF RETURN END IF 'Not involved with a .SCH xS$ = " Hit 'Q' again to Quit; 'N' for Main Menu; otherwise continue " xS$ = SubDoubleQuote$ (xS$) CALL PopMsg(18+rowO, 9+colO, xS$, errattr, 0, kc) xS$ = UCASE$(CHR$(kc)) IF xS$ = "Q" OR xS$ = "N" THEN IF CmdStat$ > "!" THEN GOSUB SaveStatsToDisk END IF IF xS$ = "N" THEN GOSUB ResetData GOTO MenuOptions ELSE GOTO QuickEnd END IF END IF RETURN ResetData: CLOSE 'CLOSE any OPEN files SaveSCHDate$ = "qwertyui" STSOpen = FALSE SchedSw = FALSE SeriesSw = FALSE QuitPending = FALSE PauseSw = FALSE MMGame = FALSE CmdSlotGames = 0 SlotGameCtr = 0 SimGameCtr = 0 SimTotal = 0 CmdLine = 0 CmdVFil$ = nulls$ CmdHFil$ = nulls$ CmdStat$ = nulls$ CmdBoxF$ = nulls$ CmdScrF$ = nulls$ CmdLinF$ = nulls$ CmdSCH$ = nulls$ CmdSER$ = nulls$ CmdFavTeam$ = nulls$ CmdFavLeague$ = nulls$ CmdDateL$ = nulls$ CmdDateH$ = nulls$ SCHDate$ = nulls$ CmdPauseAftGame$ = "N" CmdPauseAftDate$ = "N" CmdEra$ = nulls$ CmdVP$ = nulls$ CmdHP$ = nulls$ CmdVAutoLU$ = nulls$ CmdHAutoLU$ = nulls$ CmdVAdjustBO$ = nulls$ CmdHAdjustBO$ = nulls$ CmdVAutoMgr$ = nulls$ CmdHAutoMgr$ = nulls$ CmdVSpot$ = nulls$ CmdHSpot$ = nulls$ BackgroundPic$ = CmdPic$ 'Erase WL-results array REDIM WLRec(1 TO 300) AS GLOBAL WLType REDIM HLRec(400) AS GLOBAL HiLiteType REDIM AutoLineUpSw(2) AS GLOBAL LONG WLx = 0 HLx = 0 MMx = 0 RETURN PrintDOT: QPRINTs r, c, xS$, fldattr RETURN ClearLineupData: 'Redefine the arrays which clears them: 'Always do this just before loading files from disk 'REDIM GLOBAL ARRAYS REDIM SCRec(300) AS GLOBAL ScoreCardType REDIM DataGbyP(MAXPLAYERS, 2, 4) AS GLOBAL LONG REDIM DataPosi(MAXPLAYERS, 2, 4) AS GLOBAL LONG REDIM DataName(51, 2) AS GLOBAL STRING REDIM DataPlat(51, 2) AS GLOBAL STRING REDIM DataHand(51, 2) AS GLOBAL STRING REDIM DataCode(51, 2) AS GLOBAL STRING REDIM DataHP (51, 2) AS GLOBAL STRING REDIM NameRef(51, 2) AS GLOBAL STRING REDIM HandRef(51, 2) AS GLOBAL STRING REDIM RefByBO(9, 2) AS GLOBAL STRING REDIM Century(2) AS GLOBAL STRING REDIM Names(2) AS GLOBAL STRING REDIM League(2) AS GLOBAL STRING REDIM TeamLogo(2) AS GLOBAL STRING REDIM Year(2) AS GLOBAL STRING REDIM Div(2) AS GLOBAL STRING REDIM DataRef(51, 2) AS GLOBAL LONG REDIM DataPos(51, 2) AS GLOBAL LONG REDIM DataAB(51, 2) AS GLOBAL LONG REDIM DataHits(51, 2) AS GLOBAL LONG REDIM Data2B(51, 2) AS GLOBAL LONG REDIM Data3B(51, 2) AS GLOBAL LONG REDIM DataHR(51, 2) AS GLOBAL LONG REDIM DataBB(51, 2) AS GLOBAL LONG REDIM DataSO(51, 2) AS GLOBAL LONG REDIM DataRBI(51, 2) AS GLOBAL LONG REDIM DataDef(51, 2) AS GLOBAL LONG REDIM DataSpeed(51, 2) AS GLOBAL LONG REDIM DataSB(51, 2) AS GLOBAL LONG REDIM DataCS(51, 2) AS GLOBAL LONG REDIM DataGames(51, 2) AS GLOBAL LONG REDIM OrgPos(51, 2) AS GLOBAL LONG REDIM DataPBatAB(10 TO TopPitLim, 2) AS GLOBAL LONG REDIM DataPBatHi(10 TO TopPitLim, 2) AS GLOBAL LONG REDIM DataPBatHR(10 TO TopPitLim, 2) AS GLOBAL LONG REDIM DataPBatBB(10 TO TopPitLim, 2) AS GLOBAL LONG REDIM DataPBatSO(10 TO TopPitLim, 2) AS GLOBAL LONG RETURN ClearGameData: 'REDIM GLOBAL ARRAYS i = 10 j = TopPitLim REDIM mpo(i TO j, 2) AS GLOBAL LONG REDIM mpk(i TO j, 2) AS GLOBAL LONG REDIM mph(i TO j, 2) AS GLOBAL LONG REDIM mpw(i TO j, 2) AS GLOBAL LONG REDIM mpr(i TO j, 2) AS GLOBAL LONG REDIM mpbf(i TO j, 2) AS GLOBAL LONG REDIM mper(i TO j, 2) AS GLOBAL LONG REDIM mp2b(i TO j, 2) AS GLOBAL LONG REDIM mp3b(i TO j, 2) AS GLOBAL LONG REDIM mphr(i TO j, 2) AS GLOBAL LONG REDIM mphb(i TO j, 2) AS GLOBAL LONG REDIM mpBS(i TO j, 2) AS GLOBAL LONG REDIM WarmUpStatus(i TO j, 2) AS GLOBAL LONG 'REDIM OTHER GLOBAL ARRAYS REDIM iused(51, 2) AS GLOBAL LONG REDIM mab(51, 2) AS GLOBAL LONG REDIM mabRHP(51, 2) AS GLOBAL LONG REDIM mabLHP(51, 2) AS GLOBAL LONG REDIM mruns(51, 2) AS GLOBAL LONG REDIM mhits(51, 2) AS GLOBAL LONG REDIM mhitsRHP(51, 2) AS GLOBAL LONG REDIM mhitsLHP(51, 2) AS GLOBAL LONG REDIM mrbi(51, 2) AS GLOBAL LONG REDIM mhr(51, 2) AS GLOBAL LONG REDIM mhrRHP(51, 2) AS GLOBAL LONG REDIM mhrLHP(51, 2) AS GLOBAL LONG REDIM m3b(51, 2) AS GLOBAL LONG REDIM m3bRHP(51, 2) AS GLOBAL LONG REDIM m3bLHP(51, 2) AS GLOBAL LONG REDIM m2b(51, 2) AS GLOBAL LONG REDIM m2bRHP(51, 2) AS GLOBAL LONG REDIM m2bLHP(51, 2) AS GLOBAL LONG REDIM mbb(51, 2) AS GLOBAL LONG REDIM mbbRHP(51, 2) AS GLOBAL LONG REDIM mbbLHP(51, 2) AS GLOBAL LONG REDIM mhb(51, 2) AS GLOBAL LONG REDIM merr(51, 2) AS GLOBAL LONG REDIM mso(51, 2) AS GLOBAL LONG REDIM msoRHP(51, 2) AS GLOBAL LONG REDIM msoLHP(51, 2) AS GLOBAL LONG REDIM msb(51, 2) AS GLOBAL LONG REDIM mcs(51, 2) AS GLOBAL LONG REDIM mGDP(51, 2) AS GLOBAL LONG REDIM mSacF(51, 2) AS GLOBAL LONG REDIM mSacB(51, 2) AS GLOBAL LONG REDIM StealAttemptsPlayer(51, 2) AS GLOBAL LONG REDIM iScore(2, 30) AS GLOBAL LONG REDIM itruns(2) AS GLOBAL LONG REDIM ithits(2) AS GLOBAL LONG REDIM iterrs(2) AS GLOBAL LONG REDIM ipa(2) AS GLOBAL LONG REDIM np(2) AS GLOBAL LONG REDIM iyp(15, 2) AS GLOBAL LONG REDIM ibp(2) AS GLOBAL LONG REDIM dp(2) AS GLOBAL LONG REDIM GameLOB(2) AS GLOBAL LONG REDIM CloserIn(2) AS GLOBAL LONG REDIM PitcherBatted(2) AS GLOBAL LONG REDIM WildPit(2) AS GLOBAL LONG REDIM PassedB(2) AS GLOBAL LONG REDIM HitByPit(2) AS GLOBAL LONG REDIM nPitch(2) AS GLOBAL LONG REDIM StealAttemptsTeam(2) AS GLOBAL LONG REDIM GpPos(1 TO 51, 1 TO 2, 1 TO 12) AS GLOBAL BYTE REDIM PutOuts(1 TO 51, 1 TO 2, 1 TO 10) AS GLOBAL BYTE REDIM Assists(1 TO 51, 1 TO 2, 1 TO 10) AS GLOBAL BYTE 'DO NOT RESET: amgr, LastPiAd, DHDATOvr, Gender, TeamAttr WPteam = 0: WPpit = 0: LPteam = 0: LPpit = 0: SPteam = 0: SPpit = 0 QualSave1IP = 0: QualSave1ID = 0: QualSave2IP = 0: QualSave2ID = 0 iwin = 0 inn = 0 SCx = 0 LineupChangeOff = FALSE IGone = FALSE SaveState = FALSE RETURN ResetBatterCounters: BatPOut = 0 WildPitchCount = 0 RETURN PokeBackground: COLOR 15, 3 CLS RETURN GetCurrentDir: 'Return "CurrentDir$" IF CmdPath$ > "!" THEN CurrentDir$ = CmdPath$ ELSE CurrentDir$ = UCASE$(CURDIR$) END IF IF RIGHT$(CurrentDir$, 1) <> "\" THEN CurrentDir$ = CurrentDir$ + "\" RETURN LoadDirsToList1: 'Return List1(), n 'uses i, ii, f$ 'Erase first part of List1 FOR i = 1 TO 20 List1(i).ListItem = " " NEXT IF RIGHT$(CURDIR$, 1) <> "\" THEN ' Not Root Directory List1(1).ListItem = ".." List1(2).ListItem = CurrentDir$ i = 2 ELSE ' Root Directory List1(1).ListItem = CurrentDir$ i = 1 END IF ii = i f$ = UCASE$(DIR$(CurrentDir$, %directorymask)) DO UNTIL LEN(f$) = 0 IF (GETATTR (f$) AND %directorymask) THEN INCR i List1(i).ListItem = "·Ž " + f$ END IF f$ = UCASE$(DIR$) LOOP n = i IF n > ii THEN ARRAY SORT List1(ii+1) FOR n-ii, FROM 1 TO 12, ASCEND RETURN PrintButtons: ii = SimGameCtr + 1 IF SchedSw OR SeriesSw THEN IF SimTotal THEN IF RegDsply THEN x$ = " Game:" + STR$(ii) + " of" + STR$(SimTotal) + " " L = LEN(x$) IF Gfx THEN CALL GraphHole (1, 7, 2, 7, 1+L) QPRINTs 7, 2, x$, defattr IF SchedSw THEN IF Gfx THEN CALL GraphHole (2, 7, ConsCols-10, 7, ConsCols-3) QPRINTs 7, ConsCols-10, SCHDate$, defattr END IF ELSE QPRINTs 1, 1, "Game:" + STR$(ii) + " of" + STR$(SimTotal) + " ", defattr IF SchedSw THEN QPRINTs 1, ConsCols-8, SCHDate$, defattr END IF END IF ELSE IF CmdSlotGames THEN IF RegDsply THEN x$ = " Game:" + STR$(ii) + " of" + STR$(CmdSlotGames) + " " L = LEN(x$) IF Gfx THEN CALL GraphHole (1, 7, 2, 7, 1+L) 'was hole 3 ?? QPRINTs 7, 2, x$, defattr ELSE QPRINTs 1, 1, "Game:" + STR$(ii) + " of" + STR$(CmdSlotGames) + " ", defattr END IF END IF END IF RETURN PrintEra: IF CmdEra$ < "!" OR CmdEra$ = "N" THEN RETURN IF Gfx THEN CALL GraphHole (8, 6, ConsCols-17, 6, ConsCols-1) IF p4baseNorm! > 0 THEN x$ = "NORM YR/L = " + CmdEra$ QPRINTs 6, ConsCols-17, x$, fldattr ELSE IF CmdEra$ = "V" THEN 'Visitor i = 1 ELSEIF CmdEra$ = "H" THEN 'Home i = 2 ELSE 'Both i = id END IF x$ = "NORM YR/L = " + Year(i) + League(i) QPRINTs 6, ConsCols-17, x$, fldattr END IF RETURN PrintStats: 'Analyze Sim Pitching Data IF CmdStat$ > "!" THEN ref = DataRef(ip, id) InnsF! = SimInn(ref, id) InnsF! = InnsF! + mpo(ref, id) / 3 IF InnsF! = 0 THEN InnsF! = .33 ERAF! = (SimERuns(ref, id) + mper(ref, id)) / InnsF! * 9! IF ERAF! > 99.99 THEN ERAF! = 99.99 m = SimHitsAlw(ref,id) + mph(ref,id) j = SimBBAlw(ref,id) + mpw(ref,id) k = SimSO_P(ref,id) + mpk(ref,id) l = SimSaves(ref,id) IF NOT UseBigP THEN IF InnsF! > 999 OR j > 999 OR k > 999 OR l > 99 THEN UseBigP = TRUE IF Gfx THEN CALL EliminateHole(6) END IF END IF END IF 'Team Colors koloroff = fldattr kolordef = fldattr IF TeamAttr(it) THEN koloroff = TeamAttr(it) IF TeamAttr(id) THEN kolordef = TeamAttr(id) 'Print Season (.DAT) Pitching Data 'Print Sim Pitching Data IF RegDsply THEN xF! = DataRBI(ip, id) / 100 'Pitchers ERA IF UseBigP THEN IF ConsRows > 27 AND ConsCols > 90 THEN r = 9 s = 0 IF it = 2 THEN cp = 2 PitHole = 6 ELSE cp = ConsCols - 46 PitHole = 7 END IF attr = kolordef ELSEIF ConsRows > 27 AND ConsCols > 83 THEN r = 9 s = 5 IF it = 2 THEN cp = 2 PitHole = 6 ELSE cp = ConsCols - 46 + s PitHole = 7 END IF attr = kolordef ELSE r = 17+rowO cp = 19+colO s = 2 PitHole = 6 attr = labattr END IF IF CmdStat$ > "!" THEN rr = 2 ELSE rr = 1 IF Gfx THEN CALL GraphHole (PitHole, r, cp, r+rr, cp+45-s) x$ = " G Inn Hit BB SO W L S ERA" IF s > 0 THEN x$ = RIGHT$(x$, 46 - s) QPRINTs r, cp, x$, attr a$ = SPACE$(46) MID$(a$, 1, 5) = ".DAT " IF DataGames(ip, id) > 0 THEN MID$(a$, 6, 3) = LFORMAT$(DataGames(ip, id), "###") ELSE MID$(a$, 6, 3) = " -" END IF MID$(a$, 10, 4) = LFORMAT$(DataAB(ip, id), "####") MID$(a$, 15, 4) = LFORMAT$(DataHits(ip, id), "####") MID$(a$, 20, 4) = LFORMAT$(DataBB(ip, id), "####") MID$(a$, 25, 4) = LFORMAT$(DataSO(ip, id), "####") MID$(a$, 30, 3) = LFORMAT$(DataDef(ip, id), "###") MID$(a$, 34, 3) = LFORMAT$(DataSB(ip, id), "###") MID$(a$, 38, 3) = LFORMAT$(DataCS(ip, id), "###") MID$(a$, 42, 5) = FFORMAT$(xF!, "#0.##") IF s = 2 THEN a$ = "DT " + RIGHT$(a$, 41) IF s = 5 THEN a$ = RIGHT$(a$, 41) QPRINTs r+1, cp, a$, revattr IF s < 5 THEN CALL ChangeAttribute (r+1, cp, 5-s, attr) IF CmdStat$ > "!" THEN a$ = SPACE$(46) MID$(a$, 1, 5) = " Sim " MID$(a$, 6, 3) = LFORMAT$(SimGames(ref, id) + 1, "###") MID$(a$, 10, 4) = LFORMAT$(INT(InnsF!), "####") MID$(a$, 15, 4) = LFORMAT$(m, "####") MID$(a$, 20, 4) = LFORMAT$(j, "####") MID$(a$, 25, 4) = LFORMAT$(k, "####") MID$(a$, 30, 3) = LFORMAT$(SimWins(ref, id), "###") MID$(a$, 34, 3) = LFORMAT$(SimLosses(ref, id), "###") MID$(a$, 38, 3) = LFORMAT$(SimSaves(ref, id), "###") MID$(a$, 42, 5) = FFORMAT$(ERAF!, "#0.##") IF s = 2 THEN a$ = "Sm " + RIGHT$(a$, 41) IF s = 5 THEN a$ = RIGHT$(a$, 41) QPRINTs r+2, cp, a$, revattr IF s < 5 THEN CALL ChangeAttribute (r+2, cp, 5-s, attr) END IF ELSE IF ConsRows > 27 AND ConsCols > 90 THEN r = 9 IF it = 2 THEN cp = 2 PitHole = 6 ELSE cp = ConsCols - 39 PitHole = 7 END IF attr = kolordef ELSE r = 17+rowO cp = 21+colO PitHole = 6 attr = labattr END IF IF CmdStat$ > "!" THEN rr = 2 ELSE rr = 1 IF Gfx THEN CALL GraphHole (PitHole, r, cp, r+rr, cp+38) QPRINTs r, cp, " G Inn Hit BB SO W L S ERA", attr a$ = SPACE$(39) MID$(a$, 1, 5) = ".DAT " IF DataGames(ip, id) > 0 THEN MID$(a$, 6, 3) = LFORMAT$(DataGames(ip, id), "###") ELSE MID$(a$, 6, 3) = " -" END IF MID$(a$, 10, 3) = LFORMAT$(DataAB(ip, id), "###") MID$(a$, 14, 3) = LFORMAT$(DataHits(ip, id), "###") MID$(a$, 18, 3) = LFORMAT$(DataBB(ip, id), "###") MID$(a$, 22, 3) = LFORMAT$(DataSO(ip, id), "###") MID$(a$, 26, 2) = LFORMAT$(DataDef(ip, id), "##") MID$(a$, 29, 2) = LFORMAT$(DataSB(ip, id), "##") MID$(a$, 32, 2) = LFORMAT$(DataCS(ip, id), "##") MID$(a$, 35, 5) = FFORMAT$(xF!, "#0.##") QPRINTs r+1, cp, a$, revattr CALL ChangeAttribute (r+1, cp, 5, attr) IF CmdStat$ > "!" THEN a$ = SPACE$(39) MID$(a$, 1, 5) = " Sim " MID$(a$, 6, 3) = LFORMAT$(SimGames(ref, id) + 1, "###") MID$(a$, 10, 3) = LFORMAT$(INT(InnsF!), "###") MID$(a$, 14, 3) = LFORMAT$(m, "###") MID$(a$, 18, 3) = LFORMAT$(j, "###") MID$(a$, 22, 3) = LFORMAT$(k, "###") MID$(a$, 26, 2) = LFORMAT$(SimWins(ref, id), "##") MID$(a$, 29, 2) = LFORMAT$(SimLosses(ref, id), "##") MID$(a$, 32, 2) = LFORMAT$(SimSaves(ref, id), "##") MID$(a$, 35, 5) = FFORMAT$(ERAF!, "#0.##") QPRINTs r+2, cp, a$, revattr CALL ChangeAttribute (r+2, cp, 5, attr) END IF END IF END IF 'Analyze Sim BATTING Data SimAtBats = 0 'global SimTotHits = 0 'global SimTotHRs = 0 'global IF CmdStat$ > "!" THEN ref = DataRef(ib, it) SimAtBats = SimAB(ref, it) + mab(ref, it) SimTotHits = SimHits(ref, it) + mhits(ref, it) m = SimBB(ref, it) + mbb(ref, it) j = SimSO(ref, it) + mso(ref, it) SimTotHRs = SimHR(ref, it) + mhr(ref, it) IF SimAtBats > 0 THEN BASF! = SimTotHits / SimAtBats IF BASF! > .999 THEN BASF! = .999 ELSE BASF! = 0 END IF IF NOT UseBigB THEN IF SimAtBats > 999 THEN UseBigB = TRUE IF Gfx THEN IF it = 1 THEN CALL EliminateHole(6) IF it = 2 THEN CALL EliminateHole(7) END IF END IF END IF END IF IF RegDsply = TRUE THEN 'Print Season (.DAT) BATTING Data 'Print Sim Batting Data IF DataAB(ib, it) THEN BAF! = DataHits(ib, it) / DataAB(ib, it) IF BAF! > .999 THEN BAF! = .999 ELSE BAF! = 0 END IF IF UseBigB THEN IF ConsRows > 27 AND ConsCols > 90 THEN s = 0 r = 9 IF it = 1 THEN cb = 2 BatHole = 6 ELSE cb = ConsCols - 43 BatHole = 7 END IF attr = koloroff ELSEIF ConsRows > 27 AND ConsCols > 83 THEN s = 5 r = 9 IF it = 1 THEN cb = 2 BatHole = 6 ELSE cb = ConsCols - 43 + s BatHole = 7 END IF attr = koloroff ELSE s = 0 r = 22+rowO cb = 19+colO BatHole = 7 attr = labattr END IF IF CmdStat$ > "!" THEN rr = 2 ELSE rr = 1 IF Gfx THEN CALL GraphHole (BatHole, r, cb, r+rr, cb+42-s) x$ = " G AB Hit BB SO HR RBI Avg" IF s > 0 THEN x$ = RIGHT$(x$, 43 - s) QPRINTs r, cb, x$, attr a$ = SPACE$(43) MID$(a$, 1, 5) = ".DAT " IF DataGames(ib, it) > 0 THEN MID$(a$, 6, 4) = LFORMAT$(DataGames(ib, it), "####") ELSE MID$(a$, 6, 4) = " -" END IF MID$(a$, 11, 4) = LFORMAT$(DataAB(ib, it), "####") MID$(a$, 16, 4) = LFORMAT$(DataHits(ib, it), "####") MID$(a$, 21, 4) = LFORMAT$(DataBB(ib, it), "####") MID$(a$, 26, 4) = LFORMAT$(DataSO(ib, it), "####") MID$(a$, 31, 3) = LFORMAT$(DataHR(ib, it), "###") MID$(a$, 35, 4) = LFORMAT$(DataRBI(ib, it), "####") MID$(a$, 40, 4) = FFORMAT$(BAF!, ".###") IF s = 5 THEN a$ = RIGHT$(a$, 38) QPRINTs r+1, cb, a$, revattr IF s < 5 THEN CALL ChangeAttribute (r+1, cb, 5-s, attr) IF CmdStat$ > "!" THEN a$ = SPACE$(43) MID$(a$, 1, 5) = " Sim " MID$(a$, 6, 4) = LFORMAT$(SimGames(ref, it) + 1, "####") MID$(a$, 11, 4) = LFORMAT$(SimAtBats, "####") MID$(a$, 16, 4) = LFORMAT$(SimTotHits, "####") MID$(a$, 21, 4) = LFORMAT$(m , "####") MID$(a$, 26, 4) = LFORMAT$(j , "####") MID$(a$, 31, 3) = LFORMAT$(SimTotHRs, "###") MID$(a$, 35, 4) = LFORMAT$(SimRBI(ref, it) + mrbi(ref, it), "####") IF BASF! = 0 THEN MID$(a$, 40, 4) = ".000" ELSE MID$(a$, 40, 4) = FFORMAT$(BASF!, ".###") END IF IF s = 5 THEN a$ = RIGHT$(a$, 38) QPRINTs r+2, cb, a$, revattr IF s < 5 THEN CALL ChangeAttribute (r+2, cb, 5-s, attr) END IF ELSE IF ConsRows > 27 AND ConsCols > 90 THEN r = 9 IF it = 1 THEN cb = 2 BatHole = 6 ELSE cb = ConsCols - 37 BatHole = 7 END IF attr = koloroff ELSE r = 22+rowO '19 cb = 22+colO BatHole = 7 attr = labattr END IF IF CmdStat$ > "!" THEN rr = 2 ELSE rr = 1 IF Gfx THEN CALL GraphHole (BatHole, r, cb, r+rr, cb+36) QPRINTs r, cb, " G AB Hit BB SO HR RBI Avg", attr a$ = SPACE$(37) MID$(a$, 1, 5) = ".DAT " IF DataGames(ib, it) > 0 THEN MID$(a$, 6, 3) = LFORMAT$(DataGames(ib, it), "###") ELSE MID$(a$, 6, 3) = " -" END IF MID$(a$, 10, 3) = LFORMAT$(DataAB(ib, it), "###") MID$(a$, 14, 3) = LFORMAT$(DataHits(ib, it), "###") MID$(a$, 18, 3) = LFORMAT$(DataBB(ib, it), "###") MID$(a$, 22, 3) = LFORMAT$(DataSO(ib, it), "###") MID$(a$, 26, 3) = LFORMAT$(DataHR(ib, it), "###") MID$(a$, 30, 3) = LFORMAT$(DataRBI(ib, it), "###") MID$(a$, 34, 4) = FFORMAT$(BAF!, ".###") QPRINTs r+1, cb, a$, revattr CALL ChangeAttribute (r+1, cb, 5, attr) IF CmdStat$ > "!" THEN MID$(a$, 1, 5) = " Sim " MID$(a$, 6, 3) = LFORMAT$(SimGames(ref, it) + 1, "###") MID$(a$, 10, 3) = LFORMAT$(SimAtBats, "###") MID$(a$, 14, 3) = LFORMAT$(SimTotHits, "###") MID$(a$, 18, 3) = LFORMAT$(m, "###") MID$(a$, 22, 3) = LFORMAT$(j, "###") MID$(a$, 26, 3) = LFORMAT$(SimTotHRs, "###") MID$(a$, 30, 3) = LFORMAT$(SimRBI(ref, it) + mrbi(ref, it), "###") IF BASF! = 0 THEN MID$(a$, 34, 4) = ".000" ELSE MID$(a$, 34, 4) = FFORMAT$(BASF!, ".###") END IF QPRINTs r+2, cb, a$, revattr CALL ChangeAttribute (r+2, cb, 5, attr) END IF END IF END IF RETURN GoBullPenIfNoWarm: 'Is anybody already throwing or warm? N = 0 FOR i = 10 TO LastPiAd(it) 'Promote "Throwing" to "Warm" IF WarmUpStatus(i, it) > 8 THEN WarmUpStatus(i, it) = 8 'Check to see if warm IF WarmUpStatus(i, it) > 0 THEN N = -1 EXIT FOR END IF NEXT IF N = 0 THEN 'Nobody's warm j = 0 DO N = 0 CALL PopMsg(8+rowO, 22+colO, "Start someone throwing in your bullpen...", errattr, 2, kc) CALL ClearInpBuffer CALL Bullpen(0, it, 0, -1) FOR i = 10 TO LastPiAd(it) IF WarmUpStatus(i, it) > 0 THEN N = -1 EXIT FOR END IF NEXT INCR j LOOP UNTIL N OR j > 2 'j is a fail-safe to avoid being caught in infinite loop IF Gfx THEN CALL UnfreezeAndRefresh END IF END IF RETURN BatterOnScreen: IF DelFac THEN IF DataHand(ib, it) = "S" OR DataHand(ib, it) = "B" THEN IF UCASE$(DataHand(ip, id)) = "R" THEN xS$ = "L" ELSE xS$ = "R" END IF ELSEIF DataHand(ib, it) = "L" THEN xS$ = "L" ELSE xS$ = "R" END IF CALL BatterName(BLN$, xS$, FALSE) ELSE CALL BatterName(BLN$, "", TRUE) END IF RETURN RebuildFieldScreen: COLOR fldfor, fldbac CLS IF Gfx THEN CALL ShowGfx CALL ScoreBrd(TRUE, TRUE) 'Draws frame and blank announcer's box IF DelFac > 0 THEN CALL AddToAnnouncer(it, BLN$ + " steps back in...") CALL PostAnnouncer(FALSE) 'Displays "Quick Play" if DelFac = 0 ANx = 0 CALL Prompt(0) GOSUB PrintEra GOSUB PrintButtons GOSUB PrintStats CALL Defens(0) CALL Batord CALL Baspat GOSUB BatterOnScreen 'Does nothing if DelFac = 0 IF Gfx THEN CALL UnfreezeAndRefresh END IF RETURN GetPhotoSpecs: 'Look for .DAT PH name (or default CmdPic$) in STADIUM.TXT rec$ = ReturnLineInTextFile$ ("STADIUM.TXT", BackgroundPic$, 1, 20) L = LEN(rec$) IF L > 25 THEN 'picked one with angles defined 'Load rest of parameters off the selected record ObsD = VAL(MID$(rec$, 21, 6)) ObsY = VAL(MID$(rec$, 27, 6)) ObsH = VAL(MID$(rec$, 33, 6)) ObsTz = VAL(MID$(rec$, 39, 6)) ObsTy = VAL(MID$(rec$, 45, 6)) PhotoCredit$ = RTRIM$(MID$(rec$, 53, 26)) + " - " + RTRIM$(MID$(rec$, 80, 19)) + ": " + RTRIM$(MID$(rec$, 100)) Gfx = TRUE ELSEIF L > 0 THEN 'picked one without angles defined ObsD =-100 ObsY = 0 ObsH = 70 ObsTz = -10 ObsTy = 0 PhotoCredit$ = "" Gfx = TRUE ELSE 'did not find .DAT filename in STADIUM.TXT ObsD =-100 ObsY = 0 ObsH = 70 ObsTz = -10 ObsTy = 0 PhotoCredit$ = "" Gfx = TRUE END IF IF ConsRows = 25 AND ConsCols = 80 THEN Gfx = FALSE RETURN DefineBitmap: 'Does photo exist? m = LEN(DIR$(BackgroundPic$)) IF m = 0 THEN 'Oops. No picture on file IF Gfx THEN BitmapNRF = TRUE 'Turn on failure switch if Gfx was on FOR nn = 1 TO 32 CALL EliminateHole(nn) NEXT ' ForceCLS = TRUE CALL HideGfx END IF Gfx = FALSE 'Turn Gfx off temporarily ELSE BitmapNRF = FALSE END IF 'Define Graphics background screen IF Gfx THEN FOR nn = 1 TO 32 CALL EliminateHole(nn) NEXT ConsoleGfx 1, 6, ConsCols, ConsRows-1 'Start a thread to periodically refresh the graphics window. 'THREAD CREATE RefreshWindow(0) SUSPEND TO ThreadNo 'Hide the windows for now CALL HideGfx sFileName$ = BackgroundPic$ IF UCASE$(RIGHT$(sFileName$, 3)) = "BMP" THEN ' lResult = BitmapParam(sFileName$, %IMAGE_WIDTH_HEIGHT) ' lWidth = LOWRD(lResult) ' lHeight= HIWRD(lResult) lResult = StretchBitmap(sFileName$, 1024, 512) ELSE ' lResult = ImageParam(sFileName$, %IMAGE_WIDTH_HEIGHT) ' lWidth = LOWRD(lResult) ' lHeight= HIWRD(lResult) lResult = StretchImage(sFileName$, 1024, 512) END IF 'The graphic window is from row 6 to (ConsRows - 1), 'so there are (ConsRows - 1) - 6 + 1 rows inside the window. ' (ConsRows - 6) 'The first row is 1 'The last row is (ConsRows - 6) r = DrawToRow (ConsRows-6, ConsRows-6) c = DrawToCol (2, ConsCols) GfxFontName "Arial" GfxFontSize 13 DrawFrom c, r-1 'r+2 x$ = "Photo credit: " + PhotoCredit$ DrawTextRow x$, 0 ELSE ObsD = -130: ObsY = 0: ObsH = 350: ObsTz = -50: ObsTy = 0 END IF RETURN DefineBigBitmap: m = LEN(DIR$(CmdPic$)) IF m THEN ConsoleGfx 1, 1, ConsCols, ConsRows sFileName$ = CmdPic$ IF UCASE$(RIGHT$(sFileName$, 3)) = "BMP" THEN ' lResult = BitmapParam(sFileName$, %IMAGE_WIDTH_HEIGHT) ' lWidth = LOWRD(lResult) ' lHeight= HIWRD(lResult) lResult = StretchBitmap(sFileName$, 1024, 512) ELSE ' lResult = ImageParam(sFileName$, %IMAGE_WIDTH_HEIGHT) ' lWidth = LOWRD(lResult) ' lHeight= HIWRD(lResult) lResult = StretchImage(sFileName$, 1024, 512) END IF IF PhotoCredit$ > "!" THEN r = DrawToRow (ConsRows-1, ConsRows) c = DrawToCol (2, ConsCols) GfxFontName "Arial" GfxFontSize 14 DrawFrom c, r+4 x$ = "Photo credit: " + PhotoCredit$ DrawTextRow x$, 0 END IF END IF RETURN ChangePhotoManually: CmdChangePhoto$ = "N" Gfx = FALSE IF ConsRows <> 25 AND ConsCols <> 80 THEN IF LEN(DIR$("STADIUM.TXT")) THEN FileLimit = 200 REDIM List1(1 TO FileLimit) AS List1Type CALL LoadStadiumToList(List1(), choices) CALL SelectPhotoIO(List1(), choices, BackgroundPic$) IF BackgroundPic$ <> "--NONE--" AND BackgroundPic$ > "!" THEN r = 17 + rowO c = 20 + colO QPRINTs r, c, " One moment please, stretching photograph... ", defattr GOSUB GetPhotoSpecs ELSE PhotoCredit$ = "" END IF GOSUB DefineBitmap GOSUB RebuildFieldScreen END IF END IF RETURN SetParkEffects: 'Credit Shane Holmes for this routine 'Requires HBF(), TeamsInLeague(), CurrParkBF!, CurrParkPF! 'internally uses it, n IF HBF!(1) > 0 AND HBF!(2) > 0 THEN FOR it = 1 TO 2 n = TeamsInLeague(it) IF n > 1 THEN NT! = 2 / (HBF!(it) + (n - HBF!(it))/(n - 1) ) ParkBatAdj(it) = CurrParkBF! * NT! - 1 END IF NEXT END IF IF HPF!(1) > 0 AND HPF!(2) > 0 THEN FOR it = 1 TO 2 n = TeamsInLeague(it) IF n > 1 THEN NT! = 2 / (HPF!(it) + (n - HPF!(it))/(n - 1) ) ParkPitAdj(it) = CurrParkPF! * NT! - 1 END IF NEXT END IF RETURN DeclareConsole: CONSOLE SCREEN ConsRows, ConsCols ConsoleTitle "Strategic Baseball Simulator 4.9" IF winver < 2 THEN ConsoleIcon %IDI_Console DeleteWindowMenuItem %MENUITEM_TOOLBAR DeleteWindowMenuItem %MENUITEM_CLOSE ConsoleToolbar %OFF, %NO_CHANGE ConsoleWindow %SHOW ConsoleWindow %MAXIMIZE RETURN PBM_ErrorTrap: LOCATE 10, 30 PRINT " PBM_Error"; ERRCLEAR LOCATE 11, 30 PRINT " LL="; LL, ref, id, ps x$ = WAITKEY$ END FUNCTION '*********************** END OF MAIN MODULE ************************ '*************************** FUNCTIONS ***************************** FUNCTION BattersFacedByPit! (Innings, Hits, BB, SO) 'BattersFacedByPit! = (((Innings * 3) - SO) * .966) + Hits + BB + SO BattersFacedByPit! = (((Innings * 3) - SO) * .990) + Hits + BB + SO '.990 .975?? END FUNCTION FUNCTION BUBuildLine$ (j, tm, CalledFromOffense) IF iused(j, tm) OR j = ipa(tm) THEN flag$ = "x" ELSEIF SimDaysOff(j, tm) > 0 AND DaysOffRule = TRUE THEN 'Override: SimDaysOff is negative, so this is skipped flag$ = LTRIM$(STR$(SimDaysOff(j, tm))) ELSEIF WarmUpRule = TRUE THEN IF WarmUpStatus(j, tm) > 10 THEN flag$ = "T" ELSEIF CalledFromOffense = TRUE AND WarmUpStatus(j, tm) > 8 THEN flag$ = "T" ELSEIF WarmUpStatus(j, tm) > 0 THEN flag$ = "W" END IF ELSE flag$ = " " END IF a$ = SPACE$(66) MID$(a$, 1, 1) = flag$ MID$(a$, 3, 18) = DataName(j, tm) MID$(a$, 22, 1) = DataHand(j, tm) MID$(a$, 26, 2) = LFORMAT$(DataDef(j, tm), "##") MID$(a$, 29, 2) = LFORMAT$(DataSB(j, tm), "##") MID$(a$, 32, 2) = LFORMAT$(DataCS(j, tm), "##") MID$(a$, 35, 2) = LFORMAT$(DataGames(j, tm), "##") MID$(a$, 39, 2) = LFORMAT$(DataGbyP(j, tm, 1), "##") MID$(a$, 43, 4) = LFORMAT$(DataAB(j, tm), "####") MID$(a$, 49, 4) = LFORMAT$(DataHits(j, tm), "####") MID$(a$, 55, 3) = LFORMAT$(DataBB(j, tm), "###") MID$(a$, 59, 3) = LFORMAT$(DataSO(j, tm), "###") MID$(a$, 63, 4) = FFORMAT$(DataRBI(j, tm)/100, "#.##") BUBuildLine$ = a$ END FUNCTION FUNCTION CalcAttr (forg, bacg) AS LONG CalcAttr = (bacg * 16) + forg END FUNCTION FUNCTION CalcOPS! (p, tm) STATIC IF DataAB(p, tm) > 0 THEN TB = DataHits(p,tm) + Data2B(p,tm) + 2 * Data3B(p,tm) + 3 * DataHR(p,tm) Slug! = TB / DataAB(p, tm) OnBase! = (DataBB(p,tm) + DataHits(p,tm)) / (DataBB(p,tm) + DataAB(p,tm)) CalcOPS! = Slug! + OnBase! ELSE CalcOPS! = 0.0 END IF END FUNCTION FUNCTION CANADA (xS$) cS$ = UCASE$(xS$) CANADA = 0 IF INSTR(cS$, "JAYS") > 0 OR INSTR(cS$, "EXPOS") > 0 THEN CANADA = -1 END IF IF INSTR(cS$, "TORON") > 0 OR INSTR(cS$, "MONT") > 0 THEN CANADA = -1 END IF IF MID$(cS$, 5, 4) = "ATOR" OR MID$(cS$, 5, 4) = "NMON" THEN CANADA = -1 END IF END FUNCTION FUNCTION CircularFcn! (x!) 'INPUT IS ASSUMED IN RADIANS 'ELIMINATES MULTIPLES OF 2*PI AND RETURNS VALUE AS POSITIVE IF x! > 6.2831853071 OR x! < -6.2831853071 THEN z! = x! / 6.2831853071 Fract! = FRAC(z!) x! = Fract! * 6.2831853071 IF x! < 0 THEN x! = 6.2831853071 + x! CircularFcn! = x! ELSE CircularFcn! = x! END IF END FUNCTION FUNCTION CODESUM (xS$) CSum = 0 FOR i = 1 TO LEN(xS$) CSum = CSum + ASC(MID$(xS$, i, 1)) NEXT CODESUM = CSum END FUNCTION FUNCTION CountGamesInSCH (FavLeague$, FavTeam$, DateL$, DateH$, SubLen, VisiOff, HomeOff, OptOff) 'Counts total number of games in a schedule file OPEN CmdPath$ + CmdSCH$ FOR BINARY AS #2 RecLen = 0 L& = LOF(2) IF L& MOD 210 = 0 THEN RecLen = 210 : SchGamesPerRecord = 7 IF L& MOD 430 = 0 THEN RecLen = 430 : SchGamesPerRecord = 15 IF RecLen > 0 THEN SchRecords = L& / RecLen ELSE CountGamesInSCH = 0: EXIT FUNCTION Buffer$ = SPACE$(RecLen) GET #2 ,, Buffer$ 'Skip 1st record GET #2 ,, Buffer$ rec = 2 EndOfFile = 0 Total = 0 DO WHILE NOT EndOfFile DeleteFlag$ = MID$(Buffer$, 1, 1) IF DeleteFlag$ <> "D" THEN SCHDate$ = MID$(Buffer$, 3, 8) FOR n = 1 TO SchGamesPerRecord 'formerly 7 SubRecOff = 10 + (n - 1) * SubLen a$ = MID$(Buffer$, SubRecOff + VisiOff, 8) bS$ = MID$(Buffer$, SubRecOff + HomeOff, 8) a$ = UCASE$(a$) bS$ = UCASE$(bS$) TeamOK = -1 IF LEN(FavLeague$) THEN 'xS$ = MID$(a$, 3, 1) 'yS$ = MID$(bS$, 3, 1) IF NUMERIC(MID$(a$, 1, 4), FALSE, FALSE) THEN xS$ = MID$(a$, 5, 1) ELSE xS$ = MID$(a$, 3, 1) END IF IF NUMERIC(MID$(bS$, 1, 4), FALSE, FALSE) THEN yS$ = MID$(bS$, 5, 1) ELSE yS$ = MID$(bS$, 3, 1) END IF IF FavLeague$ <> xS$ AND FavLeague$ <> yS$ THEN TeamOK = 0 END IF END IF IF LEN(FavTeam$) THEN IF FavTeam$ <> RTRIM$(a$) AND FavTeam$ <> RTRIM$(bS$) THEN TeamOK = 0 END IF END IF IF LEN(DateL$) THEN IF SCHDate$ < DateL$ OR SCHDate$ > DateH$ THEN TeamOK = 0 END IF END IF IF a$ <> SPACE$(8) AND bS$ <> SPACE$(8) AND TeamOK = -1 THEN INCR Total xS$ = MID$(Buffer$, SubRecOff + OptOff, 12) IF xS$ <> SPACE$(12) THEN 'Parse the Options xS$ = UCASE$(xS$) i = INSTR(xS$, "/N:") IF i THEN Total = Total + VAL(MID$(xS$, i+3, 3)) - 1 END IF END IF END IF NEXT END IF INCR rec IF rec > SchRecords THEN EndOfFile = -1 ELSE GET #2 ,, Buffer$ END IF LOOP CLOSE #2 CountGamesInSCH = Total END FUNCTION FUNCTION CountGamesInSER OPEN CmdPath$ + CmdSER$ FOR INPUT AS #2 LEN = 128 Total = 0 DO LINE INPUT #2, x$ L = LEN(x$) IF x$ <> SPACE$(L) THEN x$ = UCASE$(x$) i = INSTR(x$, "/N:") IF i THEN Total = Total + VAL(MID$(x$, i+3, L-i-2)) ELSE INCR Total END IF END IF LOOP UNTIL EOF(2) CLOSE #2 CountGamesInSER = Total END FUNCTION FUNCTION ConsoleShell (BYVAL CmdLine$, BYVAL ShowWindState&) AS LONG ' How to use: ' target app will start in it's own console ' ShowWindState& = %SW_SHOW '1 = normal? ' ConsoleShell "E:\PB35\PTS&SVCE.V72\LOGON.exe 1 /Q/B", ShowWindState& LOCAL Si AS STARTUPINFO LOCAL Pi AS PROCESS_INFORMATION LOCAL Result AS LONG Si.cb = SIZEOF(Si) Si.dwFlags = %STARTF_USESHOWWINDOW Si.wShowWindow = ShowWindState& Result = CreateProcess("", BYVAL STRPTR(CmdLine$), BYVAL %NULL, BYVAL %NULL, _ 0, %NORMAL_PRIORITY_CLASS OR %CREATE_NEW_CONSOLE, BYVAL %NULL, BYVAL %NULL, Si, Pi) 'PRINT cmdline$ IF Result THEN CALL CloseHandle(pi.hProcess) CALL CloseHandle(pi.hThread) FUNCTION = Result END IF 'PRINT "result = "; result END FUNCTION FUNCTION DECRYPT$ (x$) 'Dim z$, c$, i, n z$ = "" FOR i = 1 TO LEN(x$) c$ = MID$(x$, i, 1) n = ASC(c$) XOR 171 z$ = z$ + CHR$(n) NEXT DECRYPT$ = z$ END FUNCTION FUNCTION DEFPCT!(n) STATIC IF DataPos(n, id) = 1 THEN defperF! = NormDEF(1) GOTO ExitDEFPCT ELSEIF ERRSw(id) THEN DatErrors = DataDef(n, id) ' Adj! = (1.0 - pkbaseF(id)) / .753 'League K's vs 2003 NL Standard Adj! = (1.0 - pkbaseF(id)) / .7496 'League K's vs 1998 NL Standard 'Results < 1 result in more errors 'Results > 1 result in less errors 'Exaggerate the result a little for low-strike-out leagues '(We seem to get too many errors in the AL if we don't) IF dh THEN Adj! = Adj! + .06 END IF ' IF dh = TRUE AND Adj! > 1 AND Adj! < 1.05 THEN ' Adj! = 1.075 ' ELSEIF (Adj! > 1.05 AND Adj! < 1.10) THEN ' Adj! = ((Adj! - 1.0) * .5) + Adj! ' END IF 'We do not do separate standards for the AL and NL. 'Otherwise we would need separate DefChancesPerGame Tables . 'The table we use is assumed to be for a non-DH league (NL). 'We know that with the DH, there are few strike-outs in the AL and 'therefore more fielding chances. ch! = 0 i = 1 DO UNTIL i > 4 IF DataGbyP(n, id, i) = 0 THEN EXIT DO ch! = ch! + DataGbyP(n, id, i) * Adj! * DefChancesPerGameF(DataPosi(n, id, i)) INCR i LOOP IF ch! > 0 THEN CDEF! = 1.0 - (DatErrors / ch!) IF i = 2 THEN 'just 1 G-By-P entry defperF! = CDEF! ELSE defperF! = DEFSplit!(n, CDEF!, Adj!) 'more than 1 G-By-P entry END IF ELSE DatGames = DataGames(n, id) 'no G-By-P data at all IF DatGames = 0 THEN DatGames = DataAB(n, id) / 3.5 IF DatGames = 0 THEN DatGames = 1 defperF! = 1.0 - ( DatErrors / ( DatGames * Adj! * DefChancesPerGameF(DataPos(n, id)) ) ) END IF ELSE 'Raw DEF% given instead of ERR Adj! = 1.0 CDEF! = DataDef(n, id) / 1000 defperF! = DEFSplit!(n, CDEF!, Adj!) p = DataPos(n, id) IF p = 2 THEN defperF! = defperF! * 0.9550 IF p = 3 THEN defperF! = defperF! * 0.9870 '9820 IF p = 4 THEN defperF! = defperF! * 1.0060 IF p = 5 THEN defperF! = defperF! * 1.0080 '1.0070 IF p = 6 THEN defperF! = defperF! * 1.0060 END IF IF defperF! > .999 THEN defperF! = .999 IF defperF! < .800 THEN defperF! = .800 'Check to see if penalty appies for out-of-position player ValidPos = FALSE CurrPos = DataPos(n, id) IF DataPosi(n, id, 1) > 0 AND DataGbyP(n, id, 1) > 0 THEN 'strict IF FoundPosition(CurrPos, n, id) THEN ValidPos = TRUE ELSE 'loose ListedPos = OrgPos(DataRef(n, id), id) SELECT CASE CurrPos CASE 2 IF ListedPos = 2 THEN ValidPos = TRUE CASE 3 IF ListedPos = 3 OR ListedPos = 5 THEN ValidPos = TRUE CASE 4 IF ListedPos = 4 OR ListedPos = 6 THEN ValidPos = TRUE CASE 5 IF ListedPos = 5 OR ListedPos = 6 THEN ValidPos = TRUE CASE 6 IF ListedPos = 6 THEN ValidPos = TRUE CASE 7, 8, 9 IF ListedPos = 7 OR ListedPos = 8 OR ListedPos = 9 THEN ValidPos = TRUE END SELECT END IF IF ValidPos = TRUE GOTO ExitDEFPCT 'Penalty: defperF! = defperF! * .75 ExitDEFPCT: DEFPCT! = defperF! END FUNCTION FUNCTION DefaultDHResponse$ IF MenuOpt$ = "S" OR MenuOpt$ = "E" THEN DefaultDHResponse$ = "H" ELSE IF League(2) = "A" THEN IF Century(2) = "19" AND MID$(Names(2), 1, 2) > "73" THEN DefaultDHResponse$ = "Y" ELSEIF Century(2) = "20" THEN DefaultDHResponse$ = "Y" ELSE DefaultDHResponse$ = "N" END IF ELSE DefaultDHResponse$ = "N" END IF END IF END FUNCTION FUNCTION DEFSplit!(n, ActDEF!, Adj!) STATIC numer! = 0 denom! = 0 i = 1 DO UNTIL i > 4 IF DataGbyP(n, id, i) = 0 THEN EXIT DO p = DataPosi(n, id, i) numer! = numer! + DataGbyP(n, id, i) * DefChancesPerGameF(p) * Adj! * NormDEF(p) denom! = denom! + DataGbyP(n, id, i) * DefChancesPerGameF(p) * Adj! INCR i LOOP IF i = 2 THEN DEFSplit! = ActDEF! ELSEIF denom! > 0 THEN ExpDEF! = numer! / denom! p = DataPos(n, id) xa! = NormDEF(p) * (ActDEF! / ExpDEF!) xb! = xa! / (xa! + ( (1-NormDEF(p))*(1-ActDEF!)/(1-ExpDEF!) ) ) DEFSplit! = xb! ELSE DEFSplit! = ActDEF! END IF END FUNCTION FUNCTION DHinDAT (team) DHinDAT = 0 i = 1 DO IF DataPos(i, team) = 10 THEN DHinDAT = -1 EXIT DO END IF INCR i LOOP WHILE i < 10 END FUNCTION FUNCTION DrawToRow (row, winrows) x! = 512 / winrows DrawToRow = INT( x! * (row - 1) ) END FUNCTION FUNCTION DrawToCol (col, wincols) x! = 1024 / wincols DrawToCol = INT( x! * (col - 1) ) END FUNCTION FUNCTION ExpectedPitchCount (pit, tm) 'Computes Avg PitchCount / Game for a given pitcher 'Takes into account starter innings and relief innings Starts = DataGbyP(pit, tm, 1) TotalInnings = DataAB(pit, tm) Games = DataGames(pit, tm) HB = DataBB(pit, tm) * 0.08 ' PitchCount = 4.81 * SOs& + 5.14 * BBs& + 3.27 * (Hits& + HB&) + 3.16 * (TotOuts& - SOs&) 'TotalPitches& = 4.8 * DataSO(pit,tm) + 5.2 * DataBB(pit,tm) + _ ' 3.3 * (DataHits(pit,tm) + HB) + _ ' 3.2 * (DataAB(pit,tm) * 3 - DataSO(pit,tm)) TotalPitches& = 5.0 * DataSO(pit,tm) + 5.3 * DataBB(pit,tm) + _ 3.4 * (DataHits(pit,tm) + HB) + _ 3.3 * (DataAB(pit,tm) * 3 - DataSO(pit,tm)) IF (Games > Starts) AND Starts > 0 THEN 'Has both starts and relief '+2 IF np(tm) = 1 THEN 'Assign stam! to starter ReliefInnings = (Games - Starts) * 1.8 StartInnings = TotalInnings - ReliefInnings StartPitches& = TotalPitches& * (StartInnings / TotalInnings) PitchesExpected = StartPitches& / Starts IF PitchesExpected < 66 THEN PitchesExpected = 66 '4 innings ELSE 'Assign stam! to reliever StartInnings = Starts * 6.0 ReliefInnings = TotalInnings - StartInnings ReliefPitches& = TotalPitches& * (ReliefInnings / TotalInnings) PitchesExpected = ReliefPitches& / (Games - Starts) IF PitchesExpected < 17 THEN PitchesExpected = 17 '1 inning IF PitchesExpected > 116 THEN PitchesExpected = 116 '7 innings END IF ELSE 'Almost all appearances are starts IF Games > 0 THEN 'Or all appearances are relief PitchesExpected = TotalPitches& / Games IF PitchesExpected < 17 THEN PitchesExpected = 17 '1 inning ELSE PitchesExpected = 116 END IF END IF IF PitchersPerGame(tm) < 2.5 THEN y! = 1.375 - (0.15 * PitchersPerGame(tm)) '15% boost for 1.5-PPG teams (c1912) ELSE y! = 1.0 END IF ExpectedPitchCount = PitchesExpected * y! END FUNCTION FUNCTION FFormat$ (InValue!, mask$) L = LEN(mask$) i = INSTR(mask$, ".") IF i THEN dp = L - i f! = MyROUND!(InValue!, dp) IF i > 1 THEN 'look at 1st "place holder" left of dp fph$ = MID$(mask$, i - 1, 1) ELSE fph$ = "" END IF ELSE dp = 0 f! = InValue! END IF x$ = LTRIM$(STR$(f!)) IF x$ = "0" THEN IF fph$ = "#" THEN x$ = "" END IF END IF IF LEFT$(x$, 1) = "." THEN IF fph$ = "0" THEN x$ = "0" + x$ END IF END IF 'Pad (or truncate) necessary places to right of decimal point IF dp THEN dppos = INSTR(x$, ".") IF dppos = 0 THEN x$ = x$ + "." LL = LEN(x$) IF dppos = 0 THEN dppos = LL IF dppos < LL THEN fp$ = MID$(x$, dppos + 1) 'fractional part ELSE fp$ = "" END IF IF LEN(fp$) > dp THEN 'truncate fractional part fp$ = LEFT$(fp$, dp) ELSE 'pad-right fractional part WHILE (LEN(fp$) < dp) fp$ = fp$ + "0" WEND END IF wp$ = LEFT$(x$, dppos) + fp$ ELSE wp$ = x$ END IF FFormat$ = PADLEFT$(wp$, L) END FUNCTION FUNCTION FindPP! psoF! = DataSO(ip, id) / (DataAB(ip, id) * 3) 'Pitcher's SO of total outs IF pkbaseF(id) > 0 THEN 'L.Avg. SO of total outs xF! = psoF! / pkbaseF(id) ELSE xF! = psoF! / .239 '.239 is a norm value END IF ppF! = 0.90 - (0.32 * xF!) '90 - 32 = 58 default pp IF ppF! > .78 THEN ppF! = .78 '+/- .20 IF ppF! < .38 THEN ppF! = .38 IF DataHand(ib, it) = "L" THEN ppF! = 1 - ppF! ELSEIF (DataHand(ib, it) = "S" OR DataHand(ib, it) = "B") AND UCASE$(DataHand(ip, id)) = "R" THEN ppF! = 1 - ppF! END IF FindPP! = ppF! END FUNCTION FUNCTION FindRA$ (RecNum, fp, Reclen, start, leng) SEEK fp, (RecNum - 1) * Reclen + start GET$ fp, leng, x$ FindRA$ = x$ END FUNCTION FUNCTION FIRSTNAME$ (xS$) STATIC a$ i = INSTR(xS$, ",") IF i > 1 THEN a$ = MID$(xS$, i + 1) FIRSTNAME$ = LTRIM$(RTRIM$(a$)) ELSE FIRSTNAME$ = nulls$ END IF END FUNCTION FUNCTION FLASTNAMER$ (player, team) ' "player" must be reference index IF DLN(player, team) = 0 THEN RS$ = LASTNAME$(NameRef(player, team)) ELSE FS$ = FIRSTNAME$(NameRef(player, team)) zi$ = MID$(FS$, 1, 1) RS$ = zi$ + "." + LASTNAME$(NameRef(player, team)) END IF FLASTNAMER$ = RS$ END FUNCTION FUNCTION FLASTNAME$ (player, team) ' "player" is NOT reference number (although DLN must be looked up by ref) IF DLN(DataRef(player, team), team) = 0 THEN RS$ = LASTNAME$(DataName(player, team)) ELSE FS$ = FIRSTNAME$(DataName(player, team)) zi$ = MID$(FS$, 1, 1) RS$ = zi$ + "." + LASTNAME$(DataName(player, team)) END IF FLASTNAME$ = RS$ END FUNCTION FUNCTION FLOAT2STR$ (xF!) STATIC n = xF! * 1000 xS$ = LTRIM$(STR$(n)) FLOAT2STR$ = PADZEROS$(xS$, 4) END FUNCTION FUNCTION FoundInMMList (xS$) REGISTER i AS INTEGER a$ = xS$ i = INSTR(a$, ".") IF i THEN a$ = LEFT$(a$, i - 1) a$ = RTRIM$(a$) Found = FALSE i = 0 DO INCR i IF i > MMx THEN EXIT DO IF RTRIM$(MMList(i).MMFile) = a$ THEN Found = TRUE LOOP UNTIL Found IF Found THEN FoundInMMList = TRUE ELSE FoundInMMList = FALSE END FUNCTION FUNCTION FoundPosition (posi, plyr, team) FoundPosition = 0 z = 1 DO IF DataPosi(plyr, team, z) = posi THEN FoundPosition = -1 EXIT FUNCTION END IF INCR z LOOP UNTIL z > 4 END FUNCTION FUNCTION FRND (i) STATIC FRND = INT(i * RND) + 1 END FUNCTION FUNCTION FULLNAME$ (xS$) i = INSTR(xS$, ",") IF i > 1 THEN FULLNAME$ = FIRSTNAME$(xS$) + " " + LASTNAME$(xS$) ELSE FULLNAME$ = RTRIM$(xS$) END IF END FUNCTION FUNCTION GetDaysOff (pl, tm) IF UBOUND(PSum) = -1 THEN 'Array has not been dimensioned GetDaysOff = 0 EXIT FUNCTION END IF FoundAt = 0 Find$ = League(tm) Find$ = Find$ + PADRIGHT$(Names(tm), 12) + PADRIGHT$(DataName(pl, tm), 16) TotalRecs = PSum(0).PGameCtr CALL BinarySearchP (PSum(), 1, 29, 1, TotalRecs, Find$, FoundAt, mini) IF FoundAt = 0 THEN DaysOff = 0 ELSE DaysOff = PSum(FoundAt).PDaysOff IF CmdSch$ > "!" THEN Now = JDATE(SchDate$) Last = PSum(FoundAt).PJDate DaysOff = DaysOff - (Now - Last) + 1 IF DaysOff < 0 THEN DaysOff = 0 IF DaysOff > 4 THEN DaysOff = 4 END IF END IF GetDaysOff = DaysOff END FUNCTION FUNCTION GROUNDBALLWHOAT (ppF!) STATIC 'First Randomization: add +/- .2 yF! = ppF! + (21 - FRND(41)) / 100! ' +/- .20 'Second Randomization: add +/- .4 xF! = yF! + (41 - FRND(81)) / 100! ' +/- .40 'This defines the infielder's "range": IF xF! > .78 THEN i = 5 '22 ELSEIF xF! > .51 THEN i = 6 '27 ELSEIF xF! > .26 THEN i = 4 '25 ELSEIF xF! > .18 THEN i = 1 ' 8 ELSEIF xF! > .16 THEN i = 2 ' 2 ELSE i = 3 '16 END IF GROUNDBALLWHOAT = i END FUNCTION FUNCTION HiSaves (tm) REGISTER i AS INTEGER, j AS INTEGER 'Returns the saves of the leader in this category 'Takes into account starter innings and relief innings Sav = 0 j = LastPiAd(tm) FOR i = 10 TO j IF DataCS(i, tm) > Sav THEN Sav = DataCS(i, tm) NEXT HiSaves = Sav END FUNCTION FUNCTION HITRATING! (bo, tm) STATIC IF DataAB(bo, tm) = 0 THEN HITRATING! = 0 EXIT FUNCTION END IF temp! = (DataHits(bo, tm) / DataAB(bo, tm)) 'BA Component temp! = temp! + (DataHR(bo, tm) / DataAB(bo, tm)) * 1.5 'Add Power Component (2008 1.5 power factor) 'Adjust For Over-use if using a stat file IF CmdStat$ > "!" THEN IF CmdFocus$ = "Y" THEN r = DataRef(bo, tm) StatABs = SimAB(r, tm) ELSE FoundAt = 0 xS$ = DataName(bo, tm) Find$ = League(tm) Find$ = Find$ + PADRIGHT$(Names(tm), 12) Find$ = Find$ + PADRIGHT$(xS$, 16) TotalRecs = BSum(0).BGameCtr CALL BinarySearchB (BSum(), 1, 29, 1, TotalRecs, Find$, FoundAt, mini) IF FoundAt = 0 THEN StatABs = 0 ELSE StatABs = BSum(FoundAt).BABs END IF END IF IF (StatABs * 1.2) > DataAB(bo, tm) THEN xF! = DataAB(bo, tm) / (StatABs * 1.2) HITRATING! = temp! * xF! ELSE HITRATING! = temp! END IF ELSE HITRATING! = temp! END IF END FUNCTION FUNCTION IFORMAT$ (InValue%, mask$) IFormat$ = PADLEFT$(LTRIM$(STR$(InValue%)), LEN(mask$)) END FUNCTION FUNCTION InBox(r1,c1,r2,c2, r, c, OnBorderOK) AS LONG InBox = FALSE IF OnBorderOK THEN IF r >= r1 AND r <= r2 THEN IF c >= c1 AND c <= c2 THEN InBox = TRUE END IF END IF ELSE IF r > r1 AND r < r2 THEN IF c > c1 AND c < c2 THEN InBox = TRUE END IF END IF END IF END FUNCTION FUNCTION JDATE(x$) STATIC 'Assume non-leap year IF UBOUND(MD) = -1 THEN 'If array is un-dimensioned: DIM MD(12) DATA 31,28,31,30,31,30,31,31,30,31,30 MD(1) = 0 FOR i = 2 TO 12 MD(i) = MD(i-1) + VAL(READ$(i-1)) NEXT END IF FOR i = 2 TO 12 MD(i) = MD(i-1) + VAL(READ$(i-1)) NEXT mm = VAL(MID$(x$, 1, 2)) dd = VAL(MID$(x$, 4, 2)) JDATE = MD(mm) + dd END FUNCTION FUNCTION LASTNAME$ (xS$) i = INSTR(xS$, ",") IF i > 1 THEN LASTNAME$ = MID$(xS$, 1, i - 1) ELSE LASTNAME$ = RTRIM$(xS$) END IF END FUNCTION FUNCTION LFORMAT$ (InValue&, mask$) LFormat$ = PADLEFT$(LTRIM$(STR$(InValue&)), LEN(mask$)) END FUNCTION FUNCTION LINESCORE$ (t) REGISTER i AS INTEGER, j AS INTEGER, s AS INTEGER 'Return line score for team specified x$ = PADRIGHT$(Names(t), 12) + " " IF inn > RegInns THEN j = inn ELSE j = RegInns FOR i = 1 TO j IF inn < 31 THEN c$ = " " s = iScore(t, i) IF i <= inn THEN IF i = inn THEN IF it = 1 THEN 'visitor batting IF t = 1 THEN IF s = 0 THEN c$ = "*" '219 ELSE c$ = LTRIM$(STR$(s)) END IF END IF ELSE 'home batting IF t = 1 THEN c$ = LTRIM$(STR$(s)) ELSE IF iwin = 2 AND s = 0 THEN 'home team has won and didn't score, so apparently 'didn't bat c$ = "-" ELSEIF iwin = 0 AND s = 0 THEN 'home team still batting and hasn't scored c$ = "*" ELSE 'runs have been scored or home team has lost c$ = LTRIM$(STR$(s)) END IF END IF END IF ELSE 'i < inn c$ = LTRIM$(STR$(s)) END IF END IF IF LEN(c$) > 1 THEN c$ = "#" x$ = x$ + c$ IF i MOD 3 = 0 THEN x$ = x$ + " " END IF NEXT x$ = x$ + PADLEFT$(STR$(itruns(t)), 3) x$ = x$ + PADLEFT$(STR$(ithits(t)), 3) x$ = x$ + PADLEFT$(STR$(iterrs(t)), 3) LINESCORE$ = x$ END FUNCTION FUNCTION LW! (Hits, Doubles, Triples, HR, BB) Singles = Hits - Doubles - Triples - HR LW! = Singles + Doubles * 1.6 + Triples * 2.2 + HR * 3 + BB * 0.7 END FUNCTION FUNCTION MenuRoutine2$ REDIM List1(1 TO 21) AS List1Type c1 = (ConsCols - 54) \ 2 c2 = ConsCols - c1 r1 = (ConsRows - 21) \ 2 - 1 r2 = ConsRows - r1 IF Gfx THEN CALL GraphHole(32, r1, c1, r2, c2) END IF CALL Drawfrm(r1, c1, r2, c2, defattr, "SBS Main Menu", "Make Selection or [Q]uit", 0, 0, 1) List1(01).ListItem = "% " List1(02).ListItem = "Manual [Single Game] Mode" List1(03).ListItem = "% Challenge a friend or the computer manager" List1(04).ListItem = "% " List1(05).ListItem = "Two Team Multi-Game Mode" List1(06).ListItem = "% Quick-Play computer-managed simulation" List1(07).ListItem = "% " List1(08).ListItem = "Schedule Mode" List1(09).ListItem = "% Replay a season" List1(10).ListItem = "% " List1(11).ListItem = "Series Mode" List1(12).ListItem = "% Run a predetermined sequence of games" List1(13).ListItem = "% " List1(14).ListItem = "Statistics Report" List1(15).ListItem = "% Create report for sims-in-progress" List1(16).ListItem = "% " List1(17).ListItem = "File Viewer" List1(18).ListItem = "% View documentation and report files" List1(19).ListItem = "% " List1(20).ListItem = "Edit BASEBALL.CFG" List1(21).ListItem = "% Edit game preferences" IF Gfx THEN GfxRefresh 0 END IF DO saveskipattr = skipattr skipattr = dimattr CALL PickFromList(List1(), 21, 21, 1, c2-c1-3, r1, c1, r2, c2, defattr, revattr, Pick, RetKey, nulls$, mous, ms$) skipattr = saveskipattr IF Pick > 0 THEN SELECT CASE Pick CASE 2 z$ = "M" CASE 5 z$ = "T" CASE 8 z$ = "S" CASE 11 z$ = "E" CASE 14 z$ = "A" CASE 17 z$ = "F" CASE 20 z$ = "P" CASE ELSE END SELECT IF ms$ = CloseButton THEN z$ = "Q" 'Special Case on this menu ELSE IF mous THEN IF ms$ = "Q" THEN z$ = "Q" ELSE z$ = "$" END IF ELSE z$ = "Q" END IF END IF LOOP UNTIL INSTR("MTSEAFPQ", z$) ERASE List1 MenuRoutine2$ = z$ END FUNCTION FUNCTION MyROUND! (InValue!, DecPts&) Tens = 1 FOR i = 1 TO DecPts& Tens = Tens * 10 NEXT MyROUND! = INT(((InValue! * Tens) + .5)) / Tens END FUNCTION FUNCTION MYINPUT$ (AutoSw, KeyEscape, CustomEscKey, KeyAccept, kc, fore, back, row, col, leng, edit$, lowlim, uplim, default$, msx, msy) COLOR fore, back LOCATE row, col PRINT SPACE$(leng); IF default$ <> nulls$ THEN LOCATE row, col PRINT default$; END IF CsrSize = 100 CURSOR ON, CsrSize LOCATE row, col InsToggle = FALSE DoneSw = FALSE DO msx = 0 msy = 0 KyS$ = WAITKEY$ 'Ignore Button Release in case we're detecting "UP" IF ASC(KyS$, 3) = 8 THEN ITERATE DO s% = INSHIFT IF LEN(KyS$) = 1 THEN kc = ASC(KyS$) ELSEIF LEN(KyS$) = 2 THEN kc = -ASC(RIGHT$(KyS$, 1)) ELSEIF LEN(KyS$) = 4 THEN IF ASC(KyS$, 3) = 2 THEN DoubleClick = TRUE ELSE DoubleClick = FALSE END IF msx = MOUSEX msy = MOUSEY IF AutoSw THEN kc = -99 ELSE kc = 27 END IF IF kc = 9 AND s% = 48 THEN kc = -15 'Support Shift-Tab KyS$ = UCASE$(KyS$) MYINPCheckKey: ' AutoSw is TRUE from ScreenIO ' Allow ESC with or without reading field for AutoSw = FALSE IF AutoSw = FALSE AND kc = 27 THEN cS$ = MID$(edit$, 2, 1) IF cS$ = "E" THEN '1. Dont read field, then exit MYINPUT$ = CHR$(27) DoneSw = TRUE ELSEIF cS$ = "?" THEN GOSUB MYINPGetField '2. Read the field, then exit END IF ' If field is required you have to ' check that when you return ' AutoSw AND [tab Shift-tab Up/Dn arrows] usually Esc = KeyAccept ELSEIF AutoSw = TRUE AND _ (kc = KeyAccept OR kc = 9 OR kc = -15 OR kc = -80 OR kc = -72 OR _ kc = -99 OR kc = CustomEscKey) THEN GOSUB MYINPGetField 'Sets DoneSw to TRUE if OK ELSEIF AutoSw = TRUE AND kc = KeyEscape THEN 'usually F3. you must handle this 'manually before screenio gets 'called again or else you'll display 'the little arrow that's in FCONTENTS MYINPUT$ = CHR$(27) DoneSw = TRUE ' C/R ELSEIF kc = 13 THEN GOSUB MYINPGetField 'Sets DoneSw to TRUE if OK ' Left/Right Arrows or normal printing moved cursor out of field ELSEIF (CURSORX >= col + leng) OR (CURSORX < col) THEN IF AutoSw THEN GOSUB MYINPGetField END IF IF CURSORX >= col + leng THEN LOCATE row, CURSORX - 1 IF CURSORX < col THEN LOCATE row, col ' Delete ELSEIF kc = -83 THEN CALL ReadFromScreen(row, col, leng, field$, edit$, Valid$) screencol = CURSORX fieldcol = CURSORX - col + 1 IF fieldcol > 0 AND fieldcol <= leng THEN field$ = MID$(field$, 1, fieldcol - 1) + MID$(field$, fieldcol + 1) + " " CURSOR OFF LOCATE row, col PRINT field$; CURSOR ON LOCATE row, screencol END IF ' Insert ELSEIF kc = -82 THEN InsToggle = NOT (InsToggle) IF InsToggle THEN CURSOR ON, CsrSize \ 2 ELSE CURSOR ON, CsrSize END IF ' Left-arrow ELSEIF kc = -75 AND CURSORX > 1 THEN LOCATE , CURSORX - 1 IF CURSORX < col THEN GOTO MYINPCheckKey ' Right-arrow ELSEIF kc = -77 AND CURSORX < 80 THEN LOCATE , CURSORX + 1 IF CURSORX >= col + leng THEN GOTO MYINPCheckKey ' Backspace ELSEIF kc = 8 THEN PRINT " "; LOCATE , CURSORX - 2 IF CURSORX < col THEN GOTO MYINPCheckKey ' Unsupported Extended Key ELSEIF kc > 127 OR kc < 32 THEN CALL MyBeep ' Put on Screen ELSE IF InsToggle THEN CALL ReadFromScreen(row, col, leng, field$, edit$, Valid$) screencol = CURSORX fieldcol = CURSORX - col + 1 field$ = MID$(field$, 1, fieldcol - 1) + KyS$ + MID$(field$, fieldcol) CURSOR OFF LOCATE row, col PRINT LEFT$(field$, leng); CURSOR ON LOCATE , screencol + 1 ELSE PRINT KyS$; END IF IF CURSORX >= col + leng THEN GOTO MYINPCheckKey END IF LOOP UNTIL DoneSw CURSOR OFF 'Turn Cursor Off EXIT FUNCTION MYINPGetField: CALL ReadFromScreen(row, col, leng, field$, edit$, Valid$) IF Valid$ = "N" THEN CALL MyBeep ELSEIF field$ <> SPACE$(leng) AND MID$(edit$, 1, 1) = "N" AND (VAL(field$) < lowlim OR VAL(field$) > uplim) THEN 'Numeric input out-of-range CALL MyBeep ELSE MYINPUT$ = field$ DoneSw = TRUE END IF RETURN END FUNCTION FUNCTION NUMBERON STATIC i = 0 IF ir1 THEN i = 1 IF ir2 THEN INCR i IF ir3 THEN INCR i NUMBERON = i END FUNCTION FUNCTION NUMERIC (field$, sp, decpt) 'STATIC 'STATIC validlist$, chS$ validlist$ = "0123456789" IF sp THEN validlist$ = validlist$ + " " IF decpt THEN validlist$ = validlist$ + "." NUMERIC = -1 FOR i = 1 TO LEN(field$) chS$ = MID$(field$, i, 1) IF INSTR(validlist$, chS$) = 0 THEN NUMERIC = 0 EXIT FOR END IF NEXT END FUNCTION FUNCTION OUTFIELDWHOAT (ppF!) STATIC xF! = ppF! + (36 - FRND(71)) / 100! ' +/- .35 IF xF! > .66 THEN i = 7 '34 ELSEIF xF! > .32 THEN i = 8 '34 ELSE i = 9 '32 END IF OUTFIELDWHOAT = i END FUNCTION FUNCTION OUTfrIN (Posi, Middle) STATIC IF Middle THEN OUTfrIN = 8: EXIT FUNCTION OUTfrIN = Posi IF Posi = 5 OR Posi = 6 THEN OUTfrIN = 7 IF Posi = 1 OR Posi = 2 THEN OUTfrIN = 8 IF Posi = 3 OR Posi = 4 THEN OUTfrIN = 9 END FUNCTION FUNCTION PADLEFT$ (xS$, leng) STATIC Temp$ = SPACE$(leng) RSET Temp$ = xS$ PADLEFT$ = Temp$ END FUNCTION FUNCTION PADRIGHT$ (xS$, leng) STATIC Temp$ = SPACE$(leng) LSET Temp$ = xS$ PADRIGHT$ = Temp$ END FUNCTION FUNCTION PADZEROS$ (xS$, leng) STATIC 'to the left L = LEN(xS$) IF L >= leng THEN PADZEROS$ = RIGHT$(xS$, leng) ELSE PADZEROS$ = STRING$(leng - L, "0") + xS$ END IF END FUNCTION FUNCTION PitcherCloneUnused (SearchName$, tm) STATIC 'Search the starting lineup 'A return of FALSE means you can't use "SearchName$", he's either in the 'starting lineup or on the bench and "used" PitcherCloneUnused = TRUE c1 = SearchDAT(1, 9, tm, SearchName$, 0) IF c1 > 0 THEN PitcherCloneUnused = FALSE EXIT FUNCTION END IF 'Name isn't in starting lineup 'Search the bench c2 = SearchDAT(LastPiAd(tm) + 1, MAXPLAYERS, tm, SearchName$, 0) IF c2 > 0 THEN 'Name is on bench - is he used? IF iused(c2, tm) THEN PitcherCloneUnused = FALSE END IF END FUNCTION FUNCTION PlayWav(WavFile$) AS LONG IF LEN(DIR$(WavFile$)) = 0 THEN EXIT FUNCTION ELSE IF CmdDeBug$ = "Y" THEN QPRINTs 6, 42, WavFile$, defattr END IF SndPlaySound BYVAL STRPTR(WavFile$), %SND_ASYNC PlayWav = 0 END FUNCTION FUNCTION RefreshWindow(BYVAL lPlaceHolder AS LONG) AS LONG 'Refresh the graphics window every 20 seconds. DO SLEEP 20000 CALL UnfreezeAndRefresh LOOP END FUNCTION FUNCTION ReturnLineInTextFile$ (fil$, keyy$, keybeg, keylen) Found = FALSE IF LEN(DIR$(fil$)) THEN OPEN fil$ FOR INPUT AS #1 DO WHILE NOT EOF(1) LINE INPUT #1, rec$ rec$ = RTRIM$(UCASE$(rec$)) IF RTRIM$(MID$(rec$, keybeg, keylen)) = UCASE$(keyy$) THEN Found = TRUE EXIT DO END IF LOOP CLOSE #1 END IF IF Found THEN ReturnLineInTextFile$ = rec$ ELSE ReturnLineInTextFile$ = "" END IF END FUNCTION FUNCTION ROTATIONLIST (Fil$) REGISTER i AS INTEGER Found = FALSE i = 1 DO UNTIL i > RTx IF RTRIM$(RotRec(i).RotTeam) = RTRIM$(Fil$) THEN Found = TRUE: EXIT DO INCR i LOOP IF NOT Found THEN i = 0 ROTATIONLIST = i END FUNCTION FUNCTION RunsAllowed! (TB, Hits, BB, Innings, SO) 'Estimate Batters Faced by Pitcher BattersFaced! = BattersFacedByPit! (Innings, Hits, BB, SO) RunsAllowed! = (Hits + BB) * TB / BattersFaced! END FUNCTION FUNCTION RunsCreated! (TB, Hits, BB, AB) RunsCreated! = (Hits + BB) * TB / (AB + BB) END FUNCTION FUNCTION RunsCreated27! (AB, Hits, H2, H3, HR, BB, HBP, SH, SF, SB, CS, GIDP) IF (AB + BB + HBP + SH + SF) = 0 THEN RunsCreated27! = 0 EXIT FUNCTION END IF TB = Hits + H2 + 2*H3 + 3*HR RC! = ( (Hits + BB + HBP - CS - GIDP) * _ (TB + .26*(BB + HBP) + .52*(SH + SF + SB)) ) / _ (AB + BB + HBP + SH + SF) den = AB - Hits + CS + SH + SF + GIDP IF den > 0 THEN RC27! = (RC! / den) * 27 ELSE RC27! = 0 END IF IF RC27! > 99.99 THEN RC27! = 99.99 RunsCreated27! = RC27! END FUNCTION FUNCTION SearchDAT (s1, s2, tm, SearchName$, posit) STATIC n = s1 DO IF DataName(n, tm) < "!" THEN n = 99 EXIT DO END IF IF SearchName$ = DataName(n, tm) THEN IF posit = 0 THEN EXIT DO ELSE IF posit = DataPos(n, tm) THEN EXIT DO END IF END IF END IF INCR n LOOP UNTIL n > s2 IF n > s2 THEN SearchDAT = 0 ELSE SearchDAT = n END FUNCTION FUNCTION SubDoubleQuote$ (xS$) yS$ = xS$ FOR i = 1 TO LEN(yS$) IF MID$(yS$, i, 1) = "'" THEN MID$(yS$, i, 1) = CHR$(34) NEXT SubDoubleQuote$ = yS$ END FUNCTION FUNCTION TotalBases (Hits, Doubles, Triples, HR) TotalBases = Hits + Doubles + 2*Triples + 3*HR END FUNCTION FUNCTION TRUNCFILENAME$ (flnm$) STATIC 'Do NOT feed this function a file extension! 'This function limits the main part of the file name to the DOS 'limit of 8 characters L = LEN(flnm$) i = L + 1 DO i = i - 1 IF i <= 0 THEN EXIT DO xS$ = MID$(flnm$, i, 1) LOOP WHILE xS$ <> "\" AND xS$ <> ":" AND i > 0 ' Length of file-name part is (L - i) IF L > 8 THEN TRUNCFILENAME$ = LEFT$(flnm$, 8 + i) ELSE TRUNCFILENAME$ = flnm$ END IF END FUNCTION FUNCTION ValidMMDDYY (MMDDYY$) MM$ = MID$(MMDDYY$, 1, 2) DD$ = MID$(MMDDYY$, 4, 2) YY$ = MID$(MMDDYY$, 7, 2) ValidMMDDYY = FALSE IF NOT NUMERIC (MM$, FALSE, FALSE) THEN EXIT FUNCTION IF NOT NUMERIC (DD$, FALSE, FALSE) THEN EXIT FUNCTION IF NOT NUMERIC (YY$, FALSE, FALSE) THEN EXIT FUNCTION IF MM$ < "01" OR MM$ > "12" OR DD$ < "01" OR DD$ > "31" THEN EXIT FUNCTION ValidMMDDYY = TRUE END FUNCTION FUNCTION WHOATGUY (WhoAtPos) STATIC 'Determine who is playing the position "WhoAtPos" IF WhoAtPos = 1 THEN i = ip ELSE i = 1 DO UNTIL WhoAtPos = DataPos(i, id) OR i > 8 INCR i LOOP END IF WHOATGUY = i END FUNCTION FUNCTION YESorNO$ (revfor, revbac, regfor, regbac, default$) OrgY = CURSORY OrgX = CURSORX COLOR revfor, revbac PRINT default$; CURSOR ON LOCATE OrgY, OrgX zS$ = WAITKEY$ IF LEN(zS$) = 4 THEN msx = MOUSEX msy = MOUSEY CALL FlashField (msy, msx, 1, 2, 80, 0) zS$ = UCASE$(CHR$(SCREEN(msy, msx))) LOCATE OrgY, OrgX ELSE zS$ = UCASE$(zS$) END IF IF zS$ <> "Y" AND zS$ <> "N" THEN zS$ = default$ COLOR revfor, revbac PRINT zS$; YESorNO$ = zS$ COLOR regfor, regbac LOCATE 1, 1 CURSOR OFF END FUNCTION '**************************** SUBROUTINES ****************************** SUB AddToAnnouncer (tm, xS$) 'tm indicates which team the announcement concerns - so gender changes 'can be applied to that team IF ANx < 12 THEN INCR ANx IF tm THEN IF Gender(tm) THEN 'should be indexed by team 1 or 2 REPLACE "He " WITH "She " IN xS$ REPLACE "He'" WITH "She'" IN xS$ REPLACE " he " WITH " she " IN xS$ REPLACE " he's " WITH " she's " IN xS$ REPLACE " him" WITH " her" IN xS$ REPLACE " HIM" WITH " HER" IN xS$ REPLACE " guy" WITH " gal" IN xS$ REPLACE " his " WITH " her " IN xS$ REPLACE " fellow" WITH " gal" IN xS$ REPLACE " himself" WITH " herself" IN xS$ END IF END IF Announcer(ANx).mgs = xS$ END IF END SUB SUB AddToMMList (xS$) a$ = xS$ i = INSTR(a$, ".") IF i THEN a$ = LEFT$(a$, i - 1) IF MMx < 100 THEN INCR MMx MMList(MMx).MMFile = a$ END IF END SUB SUB AddToScoreCrd (team, RefNum, Code$, Result$) STATIC IF SCx < 300 THEN INCR SCx SCRec(SCx).SCTeam = team SCRec(SCx).SCRef = RefNum SCRec(SCx).SCInn = inn SCRec(SCx).SCCode = Code$ SCRec(SCx).SCResult = LEFT$(Result$, 30) IF ir1 THEN SCRec(SCx).SCBase1 = " X" ELSE SCRec(SCx).SCBase1 = " ." IF ir2 THEN SCRec(SCx).SCBase2 = " X" ELSE SCRec(SCx).SCBase2 = " ." IF ir3 THEN SCRec(SCx).SCBase3 = " X" ELSE SCRec(SCx).SCBase3 = " ." RunsAfterPlay = itruns(it) - RunsBeforePlay IF RunsAfterPlay THEN SCRec(SCx).SCBase4 = STR$(RunsAfterPlay) ELSE SCRec(SCx).SCBase4 = " " END IF END IF END SUB SUB AddToRefByBO (bo, tm, ref) IF bo <= 9 THEN RefByBO(bo, tm) = RefByBO(bo, tm) + PADZEROS$(LTRIM$(STR$(ref)), 2) END IF END SUB SUB AdjustBattingOrder (tm) ON ERROR GOTO ErrorTrap REDIM Protect(9) ProtectCtr = 0 IF dh = 0 THEN s = 9 FOR i = 1 TO 9 IF DataPos(i, tm) = 1 THEN s = i EXIT FOR END IF NEXT IF s <> 9 THEN CALL Switch(9, s, tm) INCR ProtectCtr Protect(ProtectCtr) = 9 END IF 'Who has best OPS? MostF! = -1 FOR i = 1 TO 9 GOSUB SearchProtectList IF NOT InList THEN GOSUB ComputeOPS_Slug IF OPS! > MostF! THEN MostF! = OPS! s = i END IF END IF NEXT IF s <> 3 THEN CALL Switch(3, s, tm) INCR ProtectCtr Protect(ProtectCtr) = 3 'Who left has most RBI/P.A. ? MostF! = -1 FOR i = 1 TO 9 GOSUB SearchProtectList IF NOT InList THEN 'Normalize RBI per P.A. x1! = DataRBI(i, tm) / (DataAB(i, tm) + DataBB(i, tm)) IF x1! > MostF! THEN MostF! = x1! s = i END IF END IF NEXT IF s <> 4 THEN CALL Switch(4, s, tm) INCR ProtectCtr Protect(ProtectCtr) = 4 'Who left has most SB/P.A.? MostF! = -1 FOR i = 1 TO 9 GOSUB SearchProtectList IF NOT InList THEN nsb! = (DataSB(i,tm) * 600) / (DataAB(i,tm) + DataBB(i,tm)) IF nsb! > MostF! THEN MostF! = nsb! s = i END IF END IF NEXT nsb1! = MostF! IF s <> 1 THEN CALL Switch(1, s, tm) INCR ProtectCtr Protect(ProtectCtr) = 1 'Who left has most SB/P.A.? MostF! = -1 FOR i = 1 TO 9 GOSUB SearchProtectList IF NOT InList THEN nsb! = (DataSB(i,tm) * 600) / (DataAB(i,tm) + DataBB(i,tm)) IF nsb! > MostF! THEN MostF! = nsb! s = i END IF END IF NEXT nsb2! = MostF! IF s <> 2 THEN CALL Switch(2, s, tm) INCR ProtectCtr Protect(ProtectCtr) = 2 'Of #1 and #2, who has the best OBP? 'Swap if #2 has a better OBP IF DataAB(1, tm) THEN x1! = (DataHits(1, tm) + DataBB(1, tm)) / (DataAB(1,tm) + DataBB(1,tm)) ELSE x1! = 0. END IF IF DataAB(2, tm) THEN x2! = (DataHits(2, tm) + DataBB(2, tm)) / (DataAB(2,tm) + DataBB(2,tm)) ELSE x2! = 0. END IF 'We know that #1 has more SB/P.A. 'But if the difference is small... IF nsb1! - nsb2! < 11 THEN 'And if #2's OBP is significantly better... IF x2! > (x1! + .050) THEN CALL Switch(1, 2, tm) END IF END IF 'Who left has highest Slug%? MostF! = 0 FOR i = 1 TO 9 GOSUB SearchProtectList IF NOT InList THEN GOSUB ComputeOPS_Slug IF Slug! > MostF! THEN MostF! = Slug! s = i END IF END IF NEXT IF s <> 5 THEN CALL Switch(5, s, tm) INCR ProtectCtr Protect(ProtectCtr) = 5 'Who left has highest Slug%? MostF! = 0 FOR i = 1 TO 9 GOSUB SearchProtectList IF NOT InList THEN GOSUB ComputeOPS_Slug IF Slug! > MostF! THEN MostF! = Slug! s = i END IF END IF NEXT IF s <> 6 THEN CALL Switch(6, s, tm) INCR ProtectCtr Protect(ProtectCtr) = 6 'Who left has highest Slug%? MostF! = 0 FOR i = 1 TO 9 GOSUB SearchProtectList IF NOT InList THEN GOSUB ComputeOPS_Slug IF Slug! > MostF! THEN MostF! = Slug! s = i END IF END IF NEXT IF s <> 7 THEN CALL Switch(7, s, tm) INCR ProtectCtr Protect(ProtectCtr) = 7 'Who left has highest Slug%? MostF! = 0 FOR i = 1 TO 9 GOSUB SearchProtectList IF NOT InList THEN GOSUB ComputeOPS_Slug IF Slug! > MostF! THEN MostF! = Slug! s = i END IF END IF NEXT IF s <> 8 THEN CALL Switch(8, s, tm) INCR ProtectCtr Protect(ProtectCtr) = 8 IF dh THEN 'Who has not been picked? Should just be one left. FOR i = 1 TO 9 GOSUB SearchProtectList IF NOT InList THEN s = i EXIT FOR END IF NEXT IF s <> 9 THEN CALL Switch(9, s, tm) INCR ProtectCtr Protect(ProtectCtr) = 9 END IF EXIT SUB ErrorTrap: LOCATE 10, 30 PRINT "BO_Error"; ERRCLEAR x$ = WAITKEY$ EXIT SUB SearchProtectList: InList = 0 FOR n = 1 TO 9 IF Protect(n) = i THEN InList = -1 EXIT FOR END IF NEXT RETURN ComputeOPS_Slug: TB = DataHits(i,tm) + Data2B(i,tm) + 2 * Data3B(i,tm) + 3 * DataHR(i,tm) IF DataAB(i,tm) > 0 THEN Slug! = TB / DataAB(i,tm) OBP! = (DataHits(i, tm) + DataBB(i, tm)) / (DataAB(i, tm) + DataBB(i,tm)) OPS! = OBP! + Slug! ELSE Slug! = 0. OBP! = 0. OPS! = 0. END IF RETURN END SUB SUB Advanc (I1, I2, I3) STATIC ON ERROR GOTO ERRORTRAP ' On a score: ' Increment team's total runs, the scoreboard, hitter's box rbi, ' hitter's box runs, opposing pitcher responsible for runner, ' runs this half-inning. IF I3 = 0 OR ir3 = 0 THEN GOTO A10 IF iout < 3 THEN runner = ir3 GOSUB AdvanceCredit ELSE '3rd out just made - add to LOB before we erase the runner 'innLOB should always be zero at this point IF ir3 THEN innLOB = 1 END IF ir3 = 0 A10: IF I2 = 0 OR ir2 = 0 THEN GOTO A20 IF I2 = 1 THEN ir3 = ir2 IF I2 = 2 THEN runner = ir2 GOSUB AdvanceCredit END IF ir2 = 0 A20: IF I1 = 0 OR ir1 = 0 THEN GOTO A30 IF I1 = 1 THEN ir2 = ir1 IF I1 = 2 THEN ir3 = ir1 IF I1 = 3 THEN runner = ir1 GOSUB AdvanceCredit END IF ir1 = 0 A30: GOTO AdvanceEXIT AdvanceCredit: '"runner" previously set...credit one run at a time IF NOT IGone THEN IF inn >= RegInns AND it = 2 THEN IF itruns(2) > itruns(1) THEN GOTO AdvanceExit END IF END IF INCR itruns(it) INCR iScoreBd(it, innct) IF inn < 31 THEN INCR iScore(it, inn) IF Errorx = FALSE AND DPsw = FALSE THEN INCR mrbi(ref, it) END IF INCR mruns(DataRef(runner, it), it) INCR mpr(ABS(mpp(runner)), id) IF mpp(runner) > 0 AND inne - innadverr + iout < 3 AND Errorx = FALSE THEN INCR mper(mpp(runner), id) END IF IF itruns(it) = itruns(id) THEN 'Score now tied? Erase "pitcher-of-record" WPteam = 0: WPpit = 0: LPteam = 0: LPpit = 0: SPteam = 0: SPpit = 0 'Check for Blown Save IF QualSave1IP OR QualSave2IP THEN QualSave1IP = 0 QualSave1ID = 0 QualSave2IP = 0 QualSave2ID = 0 IF inn > (RegInns - 3) THEN INCR mpBS(ip, id) END IF ELSEIF itruns(it) - itruns(id) = 1 THEN WPteam = it: WPpit = ipa(it) LPteam = id: LPpit = ABS(mpp(runner)) END IF INCR innr IF NOT IGone AND NOT RunAnnounced THEN IF DelFac THEN CALL Msg ("15", "0", "0", "07", runner, it, man2, team2) '* scores END IF RETURN ErrorTrap: LOCATE 10, 30 PRINT "ERROR: Advance "; ERRCLEAR LOCATE 11, 30 'PRINT "inn:";inn;"innct:";innct;"id:";id;"it:";it;"runner";runner; _ ' "ref:";ref;"mpp(runner):";mpp(runner); _ ' "Dataref(runner, it):";Dataref(runner, it); x$ = WAITKEY$ AdvanceEXIT: END SUB SUB AnnScoring (runner) IF runner THEN CALL Msg ("15", "0", "0", "07", runner, it, man2, team2) RunAnnounced = TRUE END IF END SUB SUB AssignFatigue (team) 'On each pitching change a new assignment is made to the new current pitcher 'on the team specified. The larger FatRnd is, the more durable the pitcher. 'If you want to lower complete games (and use the bullpen more) 'make FatRnd smaller. 'Starters: IF np(team) = 1 THEN 'Assign Fatigue-factor to starter 'Assign random fatigue factor (0.9 - 1.4) avg 1.15 'FatRnd(team) = (FRND(6) + 8) / 10 'Assign random fatigue factor (0.9 - 1.2) avg 1.05 'this takes CG from about 220 to 160 'FatRnd(team) = (FRND(4) + 8) / 10 'let's try a bell curve (see fitcurve.bas) 'we need to maintain the avg around 1.15, but would like to 'cut down on complete games, so we need fewer instances of 'high numbers, but the few we get need to be really high 'so we can maintain the 1.15 number x! = RND IF PitchersPerGame(id) < 2.5 THEN y! = .190 ELSE y! = .205 FatRnd(team) = (2.71 ^ (-1 * ABS(x! - .5) ^.3)) / (y! * SQR(2 * 3.14159)) ELSE 'Bullpen Assign Fatigue-factor to reliever IF inn < 6 THEN '1 thru 5 'Assign random fatigue factor (1.0 - 2.0) avg 1.50 FatRnd(team) = (FRND(11) + 9) / 10 ELSEIF inn < 8 THEN '6 thru 7 'Assign random fatigue factor (0.9 - 1.6) avg 1.25 FatRnd(team) = (FRND(8) + 8) / 10 ELSE '8 + 'Assign random fatigue factor (0.8 - 1.4) avg 1.10 FatRnd(team) = (FRND(7) + 7) / 10 END IF END IF END SUB SUB AutoLineup (tm, c) 'Select Players by their playing-time history 'List of players (max of 12) who play a given position 'Reset for each position 'Check DIM Positions (10) FOR i = 1 TO 9 Positions(DataPos(i,tm)) = 1 NEXT FOR i = 2 TO 9 IF Positions(i) = 0 THEN x$ ="AUTOLINEUP detected error:|Def. position " + STR$(i) + " unfilled" CALL ErrorBox (x$) END IF NEXT 'End Check c = 0 PPoolLim = 12 REDIM PosPool(PPoolLim) AS PosPoolType DIM SlotFilled(9) DIM Rando(9) FOR i = 1 TO 9 Rando(i) = i SlotFilled(i) = 0 NEXT 'Shuffle the "Deck" FOR i = 1 TO 20 m = FRND(9) 'was just RND(9) which doesn't work n = FRND(9) ' "" j = Rando(m) Rando(m) = Rando(n) Rando(n) = j NEXT StartingPitName$ = DataName(ipa(tm), tm) 'Go through each Batting Order Slot "n" in starting nine '"n" is random so we won't introduce a bias in player selection FOR r = 1 TO 9 n = Rando(r) 'The default position for this guy: p = DataPos(n, tm) IF p < 2 THEN 'Skip pitchers & blanks GOTO AuLiNextN END IF 'Reset and Load PosPool 'Build list of all who play this position 'If already in lineup, make sure there's someone on the bench that 'can replace that selection PPool = 0 TotABthisPos! = 0 nn = 1 DO GamesAllPos = 0 FOR i = 1 TO 4 '4 possible games by position IF DataPosi(nn, tm, i) > 1 THEN GamesAllPos = GamesAllPos + DataGbyP(nn, tm, i) END IF NEXT 'GamesAllPos will be 0 for old-style but we'll handle that later FOR i = 1 TO 4 IF i = 1 AND DataPosi(nn, tm, 1) = 0 THEN 'old style posi = DataPos(nn, tm) ELSE 'new style posi = DataPosi(nn, tm, i) END IF IF posi = p THEN BenchSlot = 0 OKay = TRUE IF nn <> n AND nn < 10 THEN IF SlotFilled(nn) = FALSE THEN pp = DataPos(nn, tm) m = LastPiAd(tm) + 1 DO FOR ii = 1 TO 4 '4 possible games by position IF ii = 1 AND DataPosi(m, tm, 1) = 0 THEN posi2 = DataPos(m, tm) ELSE posi2 = DataPosi(m, tm, ii) END IF IF pp = posi2 AND posi2 <> 1 THEN BenchSlot = m EXIT DO END IF NEXT INCR m IF m > MAXPLAYERS THEN EXIT DO LOOP UNTIL DataPos(m, tm) = 0 ELSE OKay = FALSE END IF IF BenchSlot = 0 THEN OKay = FALSE END IF IF OKay THEN IF PPool < PPoolLim THEN INCR PPool PosPool(PPool).PSlot = nn IF GamesAllPos = 0 THEN 'Old Style xF! = DataAB(nn, tm) ELSE xF! = (DataGByP(nn, tm, i) / GamesAllPos) * DataAB(nn, tm) END IF 'Make it almost impossible to select a player that has 'the same name as the starting pitcher IF DataName(nn, tm) = StartingPitName$ THEN xF! = .0001 END IF PosPool(PPool).PABbyPos = xF! PosPool(PPool).PPct = 0! PosPool(PPool).PRepl = BenchSlot TotABthisPos! = TotABthisPos! + PosPool(PPool).PABbyPos END IF END IF END IF NEXT IF nn = 9 THEN nn = LastPiAd(tm) INCR nn IF nn > MAXPLAYERS THEN EXIT DO LOOP UNTIL DataPos(nn, tm) = 0 AND nn > 9 IF PPool < 1 THEN GOTO AuLiNextN 'Calculate percent of games by each player in pool FOR i = 1 TO PPool IF TotABthisPos! > 0 THEN PosPool(i).PPct = PosPool(i).PABbyPos / TotABthisPos! END IF NEXT 'Get a random number to select the player xF! = RND 'Select the "Pick" Pick = 0 BaseP! = 0 FOR i = 1 TO PPool IF xF! < BaseP! + PosPool(i).PPct THEN Pick = i EXIT FOR END IF BaseP! = BaseP! + PosPool(i).PPct NEXT IF Pick = 0 THEN Pick = PPool PickSlot = PosPool(Pick).PSlot 'If we picked a different player: IF n <> PickSlot THEN c = -1 'If the player we picked is already in the starting lineup: IF PickSlot < 10 THEN 'We picked someone already in lineup (B) to replace A: pp = DataPos(PickSlot, tm) 'Old field pos B's now playing CALL Switch(n, PickSlot, tm) 'Switch B to A's slot DataPos(n, tm) = p 'Make sure B's playing A's org. field pos "p" IF PosPool(Pick).PRepl > MAXPLAYERS THEN PRINT "***"; PRINT PosPool(Pick).PRepl; PRINT "***"; PauseIt END IF 'Player A is now sitting in the "PickSlot" position 'Swap someone in from bench (C) to take A's place nn1 = PosPool(Pick).PRepl CALL Switch(PickSlot, nn1, tm) 'Make sure he's playing B's org. field pos DataPos(PickSlot, tm) = pp ELSE 'We picked someone from the bench: IF PickSlot > MAXPLAYERS THEN PRINT "***2"; PRINT PickSlot; PRINT "***2"; PauseIt END IF CALL Switch(n, PickSlot, tm) DataPos(n, tm) = p END IF END IF AuLiNextN: SlotFilled(n) = TRUE NEXT 'r END SUB SUB AutoPitcher (tm, Method$, Repl$, N) ' RotRec must be DIMed ' In: Fil$, Method$ (Opt: Repl$) ' Out: N N = 10 Fil$ = DataFil(tm) i = ROTATIONLIST (Fil$) IF i = 0 THEN 'Should never occur on two-team situation, IF RTx > 299 THEN 'already added CALL MyBeep x$ = " SUB AutoPitcher ERROR: Rotation List Full. " + Fil$ CALL ErrorBox (x$) EXIT SUB END IF INCR RTx i = RTx RotRec(i).RotTeam = Fil$ RotRec(i).RotMeth = Method$ IF (tm = 1 AND CmdVSpot$ = "Y") OR _ (tm = 2 AND CmdHSpot$ = "Y") OR _ CmdSpot$ = "Y" THEN RotRec(i).RotSpot = "Y" ELSE RotRec(i).RotSpot = " " END IF RotRec(i).RotIndex = 0 RotRec(i).RotList(1) = 10 RotRec(i).RotList(2) = 11 RotRec(i).RotList(3) = 12 RotRec(i).RotList(4) = 13 RotRec(i).RotList(5) = 14 END IF IF Repl$ = "Y" THEN RotRec(i).RotMeth = Method$ END IF IF RotRec(i).RotMeth < "!" THEN CALL MyBeep x$ = "AutoPitcher ERROR: No Rotation Method: " + RotRec(i).RotMeth CALL ErrorBox (x$) EXIT SUB END IF m1$ = MID$(RotRec(i).RotMeth, 1, 1) m2$ = MID$(RotRec(i).RotMeth, 2, 1) TotPitchers = LastPiAd(tm) - 9 IF m1$ = "S" THEN 'sequential/two-team IF VAL(m2$) < 1 OR VAL(m2$) > 5 THEN m2$ = "5" 'What if we have very few pitchers? k = VAL(m2$) IF k > TotPitchers THEN k = TotPitchers 'Clear out un-used spots in the rotation list kk = k DO WHILE kk < 5 INCR kk RotRec(i).RotList(kk) = 0 LOOP 'Point index to next slot in rotation IF RotRec(i).RotIndex < k THEN INCR RotRec(i).RotIndex ELSE RotRec(i).RotIndex = 1 END IF j = RotRec(i).RotIndex ELSEIF m1$ = "R" THEN 'random IF VAL(m2$) < 1 OR VAL(m2$) > 5 THEN m2$ = "5" k = VAL(m2$) IF k > TotPitchers THEN k = TotPitchers j = FRND(k) ELSEIF m1$ > "0" AND m1$ <= "9" THEN 'direct IF m2$ >= "0" AND m2$ <= "9" THEN j = VAL(m1$ + m2$) ELSE j = VAL(m1$) END IF ELSEIF m1$ > "@" AND m1$ < "K" THEN 'sch file direct j = ASC(m1$) - 55 ELSE CALL MyBeep x$ = "SUB AutoPitcher ERROR: Invalid Method: " + m1$ CALL ErrorBox (x$) EXIT SUB END IF IF j > 0 AND j < 6 THEN N = RotRec(i).RotList(j) ELSEIF j > 5 AND j < (LastPiAd(tm) - 8) THEN 'Direct N = j + 9 'fixed 10/7/00 ELSE BEEP N = 10 END IF END SUB SUB BasPat zS$ = SPACE$(15) 'Batting order box borders (we don't want to collide with them) b1r1 = ConsRows - 12 b1c1 = 2 b1r2 = b1r1 + 10 b1c2 = 18 b2r1 = ConsRows - 12 b2c1 = ConsCols - 17 b2r2 = b2r1 + 10 b2c2 = ConsCols - 1 IF Gfx THEN CALL EliminateHole(14) CALL EliminateHole(15) CALL EliminateHole(16) ELSE IF BasPatRow(1) > 0 AND BasPatRow(1) < ConsRows THEN QPRINTs BasPatRow(1), BasPatCol(1), zS$, fldattr IF BasPatRow(2) > 0 AND BasPatRow(2) < ConsRows THEN QPRINTs BasPatRow(2), BasPatCol(2), zS$, fldattr IF BasPatRow(3) > 0 AND BasPatRow(3) < ConsRows THEN QPRINTs BasPatRow(3), BasPatCol(3), zS$, fldattr END IF IF ir1 THEN tr = BasPatRow(1) tc = BasPatCol(1) runner = ir1 GOSUB BPGetName GOSUB AttachSR CALL ClipIfNecessary (xS$, tr, tc, b1r1, b1c1, b1r2, b1c2, b2r1, b2c1, b2r2, b2c2, ca, cf) IF ca THEN IF Gfx THEN CALL GraphHole(14, tr, ca, tr, cf) IF TeamAttr(it) <> 0 THEN kk = TeamAttr(it) ELSE kk = drtattr QPRINTs tr, ca, xS$, kk END IF END IF IF ir2 THEN tr = BasPatRow(2) tc = BasPatCol(2) runner = ir2 GOSUB BPGetName GOSUB AttachSR CALL ClipIfNecessary (xS$, tr, tc, b1r1, b1c1, b1r2, b1c2, b2r1, b2c1, b2r2, b2c2, ca, cf) IF ca THEN IF Gfx THEN CALL GraphHole(15, tr, ca, tr, cf) IF TeamAttr(it) <> 0 THEN kk = TeamAttr(it) ELSE kk = drtattr QPRINTs tr, ca, xS$, kk END IF END IF IF ir3 THEN tr = BasPatRow(3) tc = BasPatCol(3) runner = ir3 GOSUB BPGetName GOSUB AttachSR CALL ClipIfNecessary (xS$, tr, tc, b1r1, b1c1, b1r2, b1c2, b2r1, b2c1, b2r2, b2c2, ca, cf) IF ca THEN IF Gfx THEN CALL GraphHole(16, tr, ca, tr, cf) IF TeamAttr(it) <> 0 THEN kk = TeamAttr(it) ELSE kk = drtattr QPRINTs tr, ca, xS$, kk END IF END IF EXIT SUB BPGetName: xS$ = FLASTNAME$(runner, it) RETURN AttachSR: IF LEN(xS$) > 9 THEN xS$ = LEFT$(xS$, 9) xS$ = xS$ + "/" + LTRIM$(STR$(DataSpeed(runner, it))) RETURN END SUB SUB BatOrd REGISTER j AS INTEGER 'Check if frame is already on screen tr = ConsRows - 12 tc = ConsCols - 16 IF linattr <> SCREENATTR(tr, 2) OR (inn = 1 AND it = 1) THEN 'check color attr inside lineup card area 'TEST TEAM LOGO IF Gfx THEN IF TeamLogo(1) > "!" THEN r = DrawToRow (ConsRows-24, ConsRows-6) c = DrawToCol (4, ConsCols) DrawFrom c, r lResult = StretchImage(TeamLogo(1), 96, 64) END IF IF TeamLogo(2) > "!" THEN r = DrawToRow (ConsRows-24, ConsRows-6) c = DrawToCol (tc+1, ConsCols) DrawFrom c, r lResult = StretchImage(TeamLogo(2), 96, 64) END IF END IF 'Team Label names x$ = RTRIM$(Names(1)) y$ = RTRIM$(Names(2)) 'Erase old labels because length is variable IF Gfx THEN CALL EliminateHole(10) CALL EliminateHole(11) 'Create Holes for Team Label CALL GraphHole(10, tr-2, 4, tr-2, 3+LEN(x$)) CALL GraphHole(11, tr-2, tc+1, tr-2, tc+LEN(y$)) ELSE xS$ = SPACE$(14) QPRINTs tr-2, 4, xS$, fldattr QPRINTs tr-2, tc+1, xS$, fldattr END IF 'Print Labels QPRINTs tr-2, 4, x$, linattr QPRINTs tr-2, tc+1, y$, linattr 'Holes for Batting Order IF Gfx THEN CALL GraphHole(12, tr, 2, tr+10, 18) CALL GraphHole(13, tr, tc-1, tr+10, ConsCols-1) END IF 'Draw Batting order frames CALL Drawfrm(tr, 2, tr+10, 18, linattr, nulls$, "VISI", 0, 0, 0) CALL Drawfrm(tr, tc-1, tr+10, ConsCols-1, linattr, nulls$, "HOME", 0, 0, 0) END IF FOR t = 1 TO 2 IF t = 1 THEN c = 3 ELSE c = tc FOR i = 1 TO 9 r = tr + i '13 + i xS$ = FLASTNAME$(i, t) xS$ = PADRIGHT$(xS$, 12) MID$(xS$, 12, 1) = UCASE$(DataHand(i, t)) xS$ = Pos(DataPos(i, t)) + " " + xS$ QPRINTs r, c, xS$, linattr NEXT NEXT 'Set batter pointer IF DelFac > 0 THEN leng = 15 IF it = 1 THEN IF ibp(1) THEN CALL ChangeAttribute (ibp(1) + tr, 3, leng, scdattr) IF ibp(2) THEN CALL ChangeAttribute (ibp(2) + tr, tc, leng, drkattr) ELSE IF ibp(1) THEN CALL ChangeAttribute (ibp(1) + tr, 3, leng, drkattr) IF ibp(2) THEN CALL ChangeAttribute (ibp(2) + tr, tc, leng, scdattr) END IF END IF END SUB SUB BatterName(BLastName$, LorR$, EraseOnly) 'Where's the catcher? CALL DefCoordinates (2, r, c, ObsD, ObsY, ObsH, ObsTz, ObsTy) CatcherRow = r CatcherCol = c IF CatcherRow < 1 OR CatcherCol < 1 THEN EXIT SUB BatterRow = CatcherRow - 1 'Eliminate old holes IF Gfx THEN CALL EliminateHole(19) CALL EliminateHole(20) ELSE 'Or blank out non-graphic screens zS$ = SPACE$(14) IF CatcherCol - 13 > 0 THEN QPRINTs BatterRow, CatcherCol -13, zS$, fldattr END IF IF CatcherCol + 6 + 14 <= ConsCols THEN QPRINTs BatterRow, CatcherCol + 6, zS$, fldattr END IF END IF IF EraseOnly THEN EXIT SUB 'Trim the name if it's too long x$ = BLastName$ IF LEN(x$) > 12 THEN x$ = LEFT$(x$, 12) 'Tack on Speed-Rating x$ = x$ + "/" + LTRIM$(STR$(DataSpeed(ib, it))) LX = LEN(x$) 'Decide where to put the batter IF LorR$ = "R" THEN BatterCol = CatcherCol - LEN(x$) + 1 'Possibly Trim RH Batter IF BatterCol < 1 THEN BatterCol = 1 Hole = 19 END IF IF LorR$ = "L" THEN BatterCol = CatcherCol + 6 'Possibly trim LH Batter L = BatterCol + LX IF L > ConsCols THEN LD = L - ConsCols x$ = LEFT$(x$, LX - LD + 1) LX = LEN(x$) END IF Hole = 20 END IF 'Batting order box borders b1r1 = ConsRows - 12 b1c1 = 2 b1r2 = b1r1 + 10 b1c2 = 18 b2r1 = ConsRows - 12 b2c1 = ConsCols - 17 b2r2 = b2r1 + 10 b2c2 = ConsCols - 1 'LOCATE 4, 45 'PRINT SPACE$(30); 'LOCATE 4, 45 'PRINT "B "; BatterRow; BatterCol; x$; 'PauseIt CALL ClipIfNecessary (x$, BatterRow, BatterCol, b1r1, b1c1, b1r2, b1c2, b2r1, b2c1, b2r2, b2c2, ca, cf) 'LOCATE 4, 45 'PRINT SPACE$(40); 'LOCATE 4, 45 'PRINT "A "; BatterRow; BatterCol; x$; ca; cf; 'PauseIt IF ca THEN IF Gfx THEN CALL GraphHole(Hole, BatterRow, ca, BatterRow, cf) IF TeamAttr(it) <> 0 THEN kk = TeamAttr(it) ELSE kk = drtattr QPRINTs BatterRow, ca, x$, kk END IF END SUB SUB BinarySearchB (ARRAYx() AS BatSummaryOVL, beg, leng, rangelo, rangehi, Find$, FoundAt, mini) STATIC FoundAt = 0 'no matching element yet mini = rangelo maxi = rangehi DO Try = (mini + maxi) \ 2 'start testing in middle xS$ = ARRAYx(Try).BatSummaryRec xS$ = MID$(xS$, beg, leng) IF xS$ = Find$ THEN 'found it! FoundAt = Try 'return matching element EXIT DO 'all done END IF IF xS$ > Find$ THEN 'too high, cut in half maxi = Try - 1 ELSE mini = Try + 1 'too low, cut other way END IF LOOP WHILE maxi >= mini END SUB SUB BinarySearchP (ARRAYx() AS PitSummaryOVL, beg, leng, rangelo, rangehi, Find$, FoundAt, mini) STATIC FoundAt = 0 'no matching element yet mini = rangelo maxi = rangehi DO Try = (mini + maxi) \ 2 'start testing in middle xS$ = ARRAYx(Try).PitSummaryRec xS$ = MID$(xS$, beg, leng) IF xS$ = Find$ THEN 'found it! FoundAt = Try 'return matching element EXIT DO 'all done END IF IF xS$ > Find$ THEN 'too high, cut in half maxi = Try - 1 ELSE mini = Try + 1 'too low, cut other way END IF LOOP WHILE maxi >= mini END SUB SUB BinarySearchF (ARRAYx() AS FldSummaryOVL, beg, leng, rangelo, rangehi, Find$, FoundAt, mini) STATIC FoundAt = 0 'no matching element yet mini = rangelo maxi = rangehi DO Try = (mini + maxi) \ 2 'start testing in middle xS$ = ARRAYx(Try).FldSummaryRec xS$ = MID$(xS$, beg, leng) IF xS$ = Find$ THEN 'found it! FoundAt = Try 'return matching element EXIT DO 'all done END IF IF xS$ > Find$ THEN 'too high, cut in half maxi = Try - 1 ELSE mini = Try + 1 'too low, cut other way END IF LOOP WHILE maxi >= mini END SUB SUB Box ON ERROR GOTO ErrorTrap REGISTER i AS INTEGER, j AS INTEGER i = 2 j = 30 REDIM TxtTbl (i, j) AS ScrType REDIM BoxPosit (i, j) AS PosiType DIM BoxRefbyLine(2, 30) AS LONG 'Special Stats Savlin = 0 FOR t = 1 TO 2 lin = 0 FOR i = 1 TO MAXPLAYERS IF merr(i, t) > 0 THEN IF lin = 0 THEN INCR lin: TxtTbl(t, lin).ScrLine = "Errors:" INCR lin IF lin < 30 THEN player = i team = t GOSUB BSGetName xS$ = LEFT$(RS$, 11) IF merr(i, t) > 1 THEN TxtTbl(t, lin).ScrLine = " " + xS$ + STR$(merr(i, t)) ELSE TxtTbl(t, lin).ScrLine = " " + xS$ END IF IF CmdStat$ > "!" THEN GOSUB LookUpBatStats IF FoundAt THEN TxtTbl(t, lin).ScrLine = _ RTRIM$(TxtTbl(t, lin).ScrLine) + _ " (" + LTRIM$(STR$( BSum(FoundAt).BErrs )) + ")" END IF END IF END IF END IF NEXT i Lastlin = lin FOR i = 1 TO MAXPLAYERS IF m2b(i, t) > 0 THEN IF lin = Lastlin THEN INCR lin: TxtTbl(t, lin).ScrLine = "Doubles:" INCR lin IF lin < 30 THEN player = i team = t GOSUB BSGetName xS$ = LEFT$(RS$, 11) IF m2b(i, t) > 1 THEN TxtTbl(t, lin).ScrLine = " " + xS$ + STR$(m2b(i, t)) ELSE TxtTbl(t, lin).ScrLine = " " + xS$ END IF IF CmdStat$ > "!" THEN GOSUB LookUpBatStats IF FoundAt THEN TxtTbl(t, lin).ScrLine = _ RTRIM$(TxtTbl(t, lin).ScrLine) + _ " (" + LTRIM$(STR$( BSum(FoundAt).B2Bs )) + ")" END IF END IF END IF END IF NEXT i Lastlin = lin FOR i = 1 TO MAXPLAYERS IF m3b(i, t) > 0 THEN IF lin = Lastlin THEN INCR lin: TxtTbl(t, lin).ScrLine = "Triples:" INCR lin IF lin < 30 THEN player = i team = t GOSUB BSGetName xS$ = LEFT$(RS$, 11) IF m3b(i, t) > 1 THEN TxtTbl(t, lin).ScrLine = " " + xS$ + STR$(m3b(i, t)) ELSE TxtTbl(t, lin).ScrLine = " " + xS$ END IF IF CmdStat$ > "!" THEN GOSUB LookUpBatStats IF FoundAt THEN TxtTbl(t, lin).ScrLine = _ RTRIM$(TxtTbl(t, lin).ScrLine) + _ " (" + LTRIM$(STR$( BSum(FoundAt).B3Bs )) + ")" END IF END IF END IF END IF NEXT i Lastlin = lin FOR i = 1 TO MAXPLAYERS IF mhr(i, t) > 0 THEN IF lin = Lastlin THEN INCR lin: TxtTbl(t, lin).ScrLine = "Home Runs:" INCR lin IF lin < 30 THEN player = i team = t GOSUB BSGetName xS$ = LEFT$(RS$, 11) IF mhr(i, t) > 1 THEN TxtTbl(t, lin).ScrLine = " " + xS$ + STR$(mhr(i, t)) ELSE TxtTbl(t, lin).ScrLine = " " + xS$ END IF IF CmdStat$ > "!" THEN GOSUB LookUpBatStats IF FoundAt THEN TxtTbl(t, lin).ScrLine = _ RTRIM$(TxtTbl(t, lin).ScrLine) + _ " (" + LTRIM$(STR$( BSum(FoundAt).BHRs )) + ")" END IF END IF END IF END IF NEXT i Lastlin = lin FOR i = 1 TO MAXPLAYERS IF msb(i, t) > 0 THEN IF lin = Lastlin THEN INCR lin: TxtTbl(t, lin).ScrLine = "Stolen Bases:" INCR lin IF lin < 30 THEN player = i team = t GOSUB BSGetName xS$ = LEFT$(RS$, 11) IF msb(i, t) > 1 THEN TxtTbl(t, lin).ScrLine = " " + xS$ + STR$(msb(i, t)) ELSE TxtTbl(t, lin).ScrLine = " " + xS$ END IF IF CmdStat$ > "!" THEN GOSUB LookUpBatStats IF FoundAt THEN TxtTbl(t, lin).ScrLine = _ RTRIM$(TxtTbl(t, lin).ScrLine) + _ " (" + LTRIM$(STR$( BSum(FoundAt).BSBs )) + ")" END IF END IF END IF END IF NEXT i Lastlin = lin FOR i = 1 TO MAXPLAYERS IF mcs(i, t) > 0 THEN IF lin = Lastlin THEN INCR lin: TxtTbl(t, lin).ScrLine = "Caught Stealing:" INCR lin IF lin < 30 THEN player = i team = t GOSUB BSGetName xS$ = LEFT$(RS$, 11) IF mcs(i, t) > 1 THEN TxtTbl(t, lin).ScrLine = " " + xS$ + STR$(mcs(i, t)) ELSE TxtTbl(t, lin).ScrLine = " " + xS$ END IF IF CmdStat$ > "!" THEN GOSUB LookUpBatStats IF FoundAt THEN TxtTbl(t, lin).ScrLine = _ RTRIM$(TxtTbl(t, lin).ScrLine) + _ " (" + LTRIM$(STR$( BSum(FoundAt).BCSs )) + ")" END IF END IF END IF END IF NEXT i IF dp(t) > 0 THEN INCR lin IF lin < 30 THEN TxtTbl(t, lin).ScrLine = "Double Play:" + STR$(dp(t)) END IF END IF IF GameLOB(t) > 0 THEN INCR lin IF lin < 30 THEN TxtTbl(t, lin).ScrLine = "LOB:" + STR$(GameLOB(t)) END IF END IF IF lin > Savlin THEN Savlin = lin NEXT t Txtlines = Savlin 'Regular Batting Box Score: Savlin = 0 FOR t = 1 TO 2 lin = 0 FOR s = 1 TO 9 p = RefOrg(s, t).RefPos 'p: org. defensive position of each starter L = LEN(RefByBO(s, t)) 'list of each person (ref #) to appear in this spot in the batting order FOR i = 1 TO L - 1 STEP 2 rf = VAL(MID$(RefByBO(s, t), i, 2)) 'skip relief pitchers who haven't batted IF p = 1 AND i > 1 AND rf <= LastPiAd(t) AND rf > 9 _ AND mab(rf, t) = 0 AND mruns(rf, t) = 0 AND mhits(rf, t) = 0 _ AND mrbi(rf, t) = 0 THEN ELSE IF lin < 30 THEN INCR lin IF i = 1 THEN IF p = 10 THEN p = 0 pS$ = LTRIM$(STR$(p)) ELSE pS$ = " " END IF BoxPosit(t, lin).ScrLine = pS$ BoxRefbyLine(t, lin) = rf END IF END IF NEXT i NEXT s IF lin > Savlin THEN Savlin = lin NEXT t IF Savlin > Txtlines THEN TotLines = Savlin ELSE TotLines = Txtlines OUTHdl = 68 Outdevice$ = CmdWritePath$ + "~BOX.PRN" OPEN Outdevice$ FOR OUTPUT AS #OUTHdl 'f1$ = "\\\ \ # # # # \ \ \\\ \ # # # # \ \" 'f2$ = "\\\ \ # # # # \ \ \ \" 'f3$ = " \ \ \\\ \ # # # # \ \" 'f4$ = " \ \ \ \" PRINT #OUTHdl, "~"; LEFT$(Names(1), 11) + " AB R H B W K"; TAB(47);LEFT$(Names(2), 11) + " AB R H B W K" lin = 1 DO UNTIL lin > TotLines Txt1$ = TxtTbl(1,lin).ScrLine Txt2$ = TxtTbl(2,lin).ScrLine Pos1$ = BoxPosit(1,lin).ScrLine Pos2$ = BoxPosit(2,lin).ScrLine IF Txt1$ < " " THEN Txt1$ = " " IF Txt2$ < " " THEN Txt2$ = " " IF BoxRefByLine(1, lin) > 0 THEN rf1 = BoxRefByLine(1, lin) player = rf1 team = 1 GOSUB BSGetName x1S$ = LEFT$(RS$, 11) END IF IF BoxRefByLine(2, lin) > 0 THEN rf2 = BoxRefByLine(2, lin) player = rf2 team = 2 GOSUB BSGetName x2S$ = LEFT$(RS$, 11) END IF a$ = SPACE$(90) IF BoxRefByLine(1, lin) > 0 AND BoxRefByLine(2, lin) > 0 THEN MID$(a$, 1, 2) = Pos1$ MID$(a$, 3, 11) = x1S$ MID$(a$, 15, 1) = LTRIM$(STR$(mab(rf1, 1))) MID$(a$, 17, 1) = LTRIM$(STR$(mruns(rf1, 1))) MID$(a$, 19, 1) = LTRIM$(STR$(mhits(rf1, 1))) MID$(a$, 21, 1) = LTRIM$(STR$(mrbi(rf1, 1))) MID$(a$, 23, 1) = LTRIM$(STR$(mbb(rf1, 1))) MID$(a$, 25, 1) = LTRIM$(STR$(mso(rf1, 1))) MID$(a$, 27, 18) = Txt1$ MID$(a$, 46, 2) = Pos2$ MID$(a$, 48, 11) = x2S$ MID$(a$, 60, 1) = LTRIM$(STR$(mab(rf2, 2))) MID$(a$, 62, 1) = LTRIM$(STR$(mruns(rf2, 2))) MID$(a$, 64, 1) = LTRIM$(STR$(mhits(rf2, 2))) MID$(a$, 66, 1) = LTRIM$(STR$(mrbi(rf2, 2))) MID$(a$, 68, 1) = LTRIM$(STR$(mbb(rf2, 2))) MID$(a$, 70, 1) = LTRIM$(STR$(mso(rf2, 2))) MID$(a$, 72, 18) = Txt2$ PRINT #OUTHdl, a$ ELSEIF BoxRefByLine(1, lin) > 0 THEN MID$(a$, 1, 2) = Pos1$ MID$(a$, 3, 11) = x1S$ MID$(a$, 15, 1) = LTRIM$(STR$(mab(rf1, 1))) MID$(a$, 17, 1) = LTRIM$(STR$(mruns(rf1, 1))) MID$(a$, 19, 1) = LTRIM$(STR$(mhits(rf1, 1))) MID$(a$, 21, 1) = LTRIM$(STR$(mrbi(rf1, 1))) MID$(a$, 23, 1) = LTRIM$(STR$(mbb(rf1, 1))) MID$(a$, 25, 1) = LTRIM$(STR$(mso(rf1, 1))) MID$(a$, 27, 18) = Txt1$ MID$(a$, 72, 18) = Txt2$ PRINT #OUTHdl, a$ ELSEIF BoxRefByLine(2, lin) > 0 THEN MID$(a$, 27, 18) = Txt1$ MID$(a$, 46, 2) = Pos2$ MID$(a$, 48, 11) = x2S$ MID$(a$, 60, 1) = LTRIM$(STR$(mab(rf2, 2))) MID$(a$, 62, 1) = LTRIM$(STR$(mruns(rf2, 2))) MID$(a$, 64, 1) = LTRIM$(STR$(mhits(rf2, 2))) MID$(a$, 66, 1) = LTRIM$(STR$(mrbi(rf2, 2))) MID$(a$, 68, 1) = LTRIM$(STR$(mbb(rf2, 2))) MID$(a$, 70, 1) = LTRIM$(STR$(mso(rf2, 2))) MID$(a$, 72, 18) = Txt2$ PRINT #OUTHdl, a$ ELSE MID$(a$, 27, 18) = Txt1$ MID$(a$, 72, 18) = Txt2$ PRINT #OUTHdl, a$ END IF INCR lin LOOP 'Pitcher stats i = 2 j = 15 REDIM PitTbl(i, j) AS PitTblType PRINT #OUTHdl, PRINT #OUTHdl, "~Pitcher IP H R ER BB SO"; TAB(47); "Pitcher IP H R ER BB SO" 'f$ = "\ \## \ \ ## ## ## ## ##" Savlin = 0 FOR t = 1 TO 2 lin = 0 FOR n = 1 TO np(t) p = iyp(n, t) 'See if we've already done this pitcher. 'It's possible that a pitcher can enter a game more than once... i = 1 Found = FALSE DO WHILE i < n IF p = iyp(i, t) THEN Found = TRUE EXIT DO END IF INCR i LOOP IF Found THEN ITERATE FOR IF WPteam = t AND WPpit = p THEN flag$ = " W" ELSEIF LPteam = t AND LPpit = p THEN flag$ = " L" ELSEIF SPteam = t AND SPpit = p THEN flag$ = " S" ELSE flag$ = " " END IF y$ = " " IF flag$ > " " THEN IF CmdStat$ > "!" THEN Find$ = League(t) + PADRIGHT$(Names(t), 12) + PADRIGHT$(NameRef(p, t), 16) TotalRecs = PSum(0).PGameCtr CALL BinarySearchP (PSum(), 1, 29, 1, TotalRecs, Find$, FoundAt, mini) IF FoundAt THEN IF flag$ = " W" THEN w = PSum(FoundAt).PWin l = PSum(FoundAt).PLoss y$ = "(" + LTRIM$(STR$(w)) + "-" + LTRIM$(STR$(l)) + ")" END IF IF flag$ = " L" THEN w = PSum(FoundAt).PWin l = PSum(FoundAt).PLoss y$ = "(" + LTRIM$(STR$(w)) + "-" + LTRIM$(STR$(l)) + ")" END IF IF flag$ = " S" THEN s = PSum(FoundAt).PSave y$ = "(" + LTRIM$(STR$(s)) + ")" END IF END IF END IF END IF player = p team = t GOSUB BSGetName xS$ = RTRIM$(RS$ + flag$) L = LEN(y$) IF L > 1 THEN d = L + LEN(xS$) IF d > 18 THEN xS$ = LEFT$(xS$, LEN(xS$) - (d-18)) xS$ = xS$ + y$ END IF i = mpo(p, t) MOD 3 SELECT CASE i CASE 0 zS$ = " " CASE 1 zS$ = "1/3" CASE 2 zS$ = "2/3" END SELECT INCR lin ' f$ = "\ \## \ \ ## ## ## ## ##" a$ = SPACE$(39) MID$(a$, 1, 18) = xS$ MID$(a$, 19, 2) = FFORMAT$(INT(mpo(p,t) / 3) , "##") MID$(a$, 22, 3) = zS$ MID$(a$, 26, 2) = LFORMAT$(mph(p,t), "##") MID$(a$, 29, 2) = LFORMAT$(mpr(p,t), "##") MID$(a$, 32, 2) = LFORMAT$(mper(p,t), "##") MID$(a$, 35, 2) = LFORMAT$(mpw(p,t), "##") MID$(a$, 38, 2) = LFORMAT$(mpk(p,t), "##") PitTbl(t, lin).ScrLine = a$ NEXT n IF lin > Savlin THEN Savlin = lin NEXT t FOR i = 1 TO Savlin Txt1$ = PitTbl(1, i).ScrLine Txt2$ = PitTbl(2, i).ScrLine IF Txt1$ < " " THEN Txt1$ = " " IF Txt2$ < " " THEN Txt2$ = " " PRINT #OUTHdl, Txt1$; TAB(46); Txt2$ NEXT i = 2 j = 15 REDIM PitTbl (i, j) AS PitTblType Savlin = 0 FOR t = 1 TO 2 lin = 0 FOR i = 10 TO TopPitLim L = mpBS(i, t) IF L THEN INCR lin IF lin = 1 THEN PitTbl(t, lin).ScrLine = "Blown Save:" player = i team = t GOSUB BSGetName xS$ = LEFT$(RS$, 11) IF L > 1 THEN xS$ = xS$ + "(" + LTRIM$(STR$(L)) + ")" INCR lin PitTbl(t, lin).ScrLine = " " + xS$ END IF NEXT L = LEN(WildPit(t)) IF L THEN INCR lin PitTbl(t, lin).ScrLine = "WP:" n = 1 DO WHILE n < L r = VAL(MID$(WildPit(t), n, 2)) player = r team = t GOSUB BSGetName xS$ = LEFT$(RS$, 11) INCR lin PitTbl(t, lin).ScrLine = " " + xS$ n = n + 2 LOOP END IF L = LEN(PassedB(t)) IF L THEN INCR lin PitTbl(t, lin).ScrLine = "Passed Ball:" n = 1 DO WHILE n < L r = VAL(MID$(PassedB(t), n, 2)) player = r team = t GOSUB BSGetName xS$ = LEFT$(RS$, 11) INCR lin PitTbl(t, lin).ScrLine = " " + xS$ n = n + 2 LOOP END IF L = LEN(HitByPit(t)) IF L THEN INCR lin PitTbl(t, lin).ScrLine = "HBP:" n = 1 DO WHILE n < L r = VAL(MID$(HitByPit(t), n, 2)) player = r team = t GOSUB BSGetName xS$ = LEFT$(RS$, 11) r = VAL(MID$(HitByPit(t), n + 2, 2)) player = r team = 3 - t GOSUB BSGetName yS$ = LEFT$(RS$, 11) INCR lin PitTbl(t, lin).ScrLine = " " + xS$ + "(" + yS$ + ")" n = n + 4 LOOP END IF IF lin > Savlin THEN Savlin = lin NEXT IF Savlin THEN PRINT #OUTHdl, FOR i = 1 TO Savlin Txt1$ = PitTbl(1, i).ScrLine Txt2$ = PitTbl(2, i).ScrLine IF Txt1$ < " " THEN Txt1$ = " " IF Txt2$ < " " THEN Txt2$ = " " PRINT #OUTHdl, Txt1$; TAB(46); Txt2$ NEXT 'Print line score PRINT #OUTHdl, xS$ = LINESCORE$(1) i = LEN(xS$) - 6 PRINT #OUTHdl, TAB(i); "R H E" PRINT #OUTHdl, xS$ xS$ = LINESCORE$(2) PRINT #OUTHdl, xS$ PRINT #OUTHdl, CLOSE #OUTHdl 'Return ERASE TxtTbl ERASE BoxPosit ERASE PitTbl EXIT SUB BSGetName: RS$ = FLASTNAMER$(player, team) RETURN LookUpBatStats: Find$ = League(t) + PADRIGHT$(Names(t), 12) + PADRIGHT$(NameRef(i, t), 16) TotalRecs = BSum(0).BGameCtr FoundAt = 0 CALL BinarySearchB (BSum(), 1, 29, 1, TotalRecs, Find$, FoundAt, mini) RETURN ErrorTrap: LOCATE 10, 30 PRINT "ERROR: BoxScore"; ERRCLEAR x$ = WAITKEY$ END SUB SUB BubbleSortFlt (ArrayFlt!(), ArrayStr() AS SortStrType, O$) 'STATIC DO OutOfOrder = 0 FOR x = 1 TO UBOUND(ArrayFlt!) - 1 IF O$ = "A" THEN IF ArrayFlt!(x) > ArrayFlt!(x + 1) THEN SWAP ArrayFlt!(x), ArrayFlt!(x + 1) SWAP ArrayStr(x).SSItem, ArrayStr(x + 1).SSItem OutOfOrder = -1 END IF ELSE IF ArrayFlt!(x) < ArrayFlt!(x + 1) THEN SWAP ArrayFlt!(x), ArrayFlt!(x + 1) SWAP ArrayStr(x).SSItem, ArrayStr(x + 1).SSItem OutOfOrder = -1 END IF END IF NEXT LOOP WHILE OutOfOrder END SUB SUB BubbleSortInt (ArrayInt(), ArrayStr() AS SortStrType) 'STATIC DO OutOfOrder = 0 FOR x = 1 TO UBOUND(ArrayInt) - 1 IF ArrayInt(x) < ArrayInt(x + 1) THEN ' < is descending ' > is ascending SWAP ArrayInt(x), ArrayInt(x + 1) SWAP ArrayStr(x).SSItem, ArrayStr(x + 1).SSItem OutOfOrder = -1 END IF NEXT LOOP WHILE OutOfOrder END SUB SUB BuildBullpenPlyList (tm, PlyList() AS PlyListType, Av, CalledFromOffense) Av = 0 IF NewStyle(tm) AND LastPiAd(tm) > 10 THEN 'New Style has "Games" and "Starts" 'Put Relievers in first, then starters if appropriate 'relief1 is "normal" address of 1st reliever in .DAT 'If less than 6 pitchers, relief1 is the last pitcher relief1 = MIN&(15, LastPiAd(tm)) j = relief1 DO Pass = 0 IF j < relief1 THEN IF DataGames(j, tm) > DataGbyP(j, tm, 1) THEN '+2 Pass = -1 END IF ELSE Pass = -1 END IF IF Pass THEN IF Av < 25 THEN a$ = BUBuildLine$ (j, tm, CalledFromOffense) INCR Av PlyList(Av).Item = a$ PlyList(Av).Ref = j END IF END IF INCR j IF j > LastPiAd(tm) THEN j = 10 IF j = relief1 THEN EXIT DO LOOP ELSE 'Old Style - we know nothing about Games and Starts IF LastPiAd(tm) > 17 THEN 'More than 8 pitchers [take #14+ ] n1 = 14 ELSE n1 = 10 '8 or less pitchers [take all] END IF FOR j = n1 TO LastPiAd(tm) IF Av < 25 THEN a$ = BUBuildLine$ (j, tm, CalledFromOffense) INCR Av PlyList(Av).Item = a$ PlyList(Av).Ref = j END IF NEXT END IF END SUB SUB BuildTeamWin (tm, beg, endd, hdg, pend) REGISTER j AS INTEGER, k AS INTEGER, m AS INTEGER wlim = MAXPLAYERS + 4 REDIM VirtualWin(wlim) AS GLOBAL VirtualWinType Bhdg = FALSE Phdg = FALSE pend = endd FOR j = beg TO endd jj = j IF DataName(j, tm) < "!" THEN pend = j - 1: EXIT FOR IF DataPos(j, tm) = 1 AND j > 9 AND j <= LastPiAd(tm) THEN 'Pitchers IF hdg THEN IF Phdg = FALSE THEN IF m < wlim THEN INCR m VirtualWin(m).item = "~ Name L/R W L S G St Inn Hits HR BB SO ERA" END IF Phdg = TRUE Bhdg = FALSE END IF END IF IF iused(j, tm) THEN flag$ = "x" ELSE flag$ = " " a$ = SPACE$(70) MID$(a$, 1, 2) = LFORMAT$(jj, "##") MID$(a$, 4, 1) = flag$ MID$(a$, 5, 17) = DataName(j, tm) MID$(a$, 24, 1) = DataHand(j, tm) MID$(a$, 28, 2) = LFORMAT$(DataDef(j, tm), "##") MID$(a$, 31, 2) = LFORMAT$(DataSB(j, tm), "##") MID$(a$, 34, 2) = LFORMAT$(DataCS(j, tm), "##") MID$(a$, 37, 2) = LFORMAT$(DataGames(j, tm), "##") MID$(a$, 41, 2) = LFORMAT$(DataGbyP(j, tm, 1), "##") MID$(a$, 45, 4) = LFORMAT$(DataAB(j, tm), "####") MID$(a$, 51, 4) = LFORMAT$(DataHits(j, tm), "####") MID$(a$, 56, 2) = LFORMAT$(DataHR(j, tm), "##") MID$(a$, 59, 3) = LFORMAT$(DataBB(j, tm), "###") MID$(a$, 63, 3) = LFORMAT$(DataSO(j, tm), "###") MID$(a$, 67, 4) = FFORMAT$(DataRBI(j, tm)/100, "#.##") ELSE IF hdg THEN 'Position Players IF Bhdg = FALSE THEN IF m < wlim THEN INCR m VirtualWin(m).item = "~ Name Pos AB Hit 2B 3B HR RBI BB SO B S SB CS Def Avg Games@Pos" IF ERRSw(tm) THEN MID$(VirtualWin(m).item, 65, 3) = "ERR" END IF Bhdg = TRUE Phdg = FALSE END IF END IF IF DataAB(j, tm) = 0 THEN BAF! = 0 ELSE BAF! = DataHits(j, tm) / DataAB(j, tm) END IF IF iused(j, tm) THEN flag$ = "x" ELSE flag$ = " " a$ = SPACE$(114) MID$(a$, 1, 2) = LFORMAT$(jj, "##") MID$(a$, 4, 1) = flag$ MID$(a$, 5, 15) = DataName(j, tm) MID$(a$, 21, 2) = Pos(DataPos(j, tm)) MID$(a$, 24, 3) = LFORMAT$(DataAB(j, tm), "###") MID$(a$, 28, 3) = LFORMAT$(DataHits(j, tm), "###") MID$(a$, 32, 3) = LFORMAT$(Data2B(j, tm), "###") MID$(a$, 36, 2) = LFORMAT$(Data3B(j, tm), "##") MID$(a$, 39, 2) = LFORMAT$(DataHR(j, tm), "##") MID$(a$, 42, 3) = LFORMAT$(DataRBI(j, tm), "###") MID$(a$, 46, 3) = LFORMAT$(DataBB(j, tm), "###") MID$(a$, 50, 3) = LFORMAT$(DataSO(j, tm), "###") MID$(a$, 54, 1) = DataHand(j, tm) MID$(a$, 56, 1) = LFORMAT$(DataSpeed(j, tm), "#") MID$(a$, 58, 3) = LFORMAT$(DataSB(j, tm), "###") MID$(a$, 62, 2) = LFORMAT$(DataCS(j, tm), "##") MID$(a$, 65, 3) = LFORMAT$(DataDef(j, tm), "###") MID$(a$, 69, 4) = FFORMAT$(BAF!, ".###") b$ = "" FOR k = 1 TO 4 IF DataGByP(j,tm,k) > 0 THEN b$ = b$ + LFORMAT$(DataGbyP(j,tm,k), "####") + " at" IF DataPosi(j,tm,k) = 10 THEN b$ = b$ + " DH" ELSE b$ = b$ + LFORMAT$(DataPosi(j,tm,k), "###") END IF END IF NEXT bl = LEN(b$) IF bl THEN MID$(a$, 73, bl) = b$ END IF END IF IF m < wlim THEN INCR m VirtualWin(m).item = a$ END IF NEXT END SUB SUB Bullpen (n, tm, ForceN, CalledFromOffense) STATIC 'Be aware that we pass back "n" and "tm", so don't use them as variables in this routine REGISTER i AS INTEGER 'Check if we already have selected pitcher IF ForceN THEN n = ForceN GOTO BU150 END IF IF CalledFromOffense = FALSE AND amgr(tm) THEN GOTO BU1000 REDIM PlyList(1 TO 25) AS PlyListType 'was 14 'Build list of relief pitchers CALL BuildBullpenPlyList (tm, PlyList(), Av, CalledFromOffense) 'Returns PlyList() and Av 'Save the screen QPush r = MIN&(Av+7+rowO, ConsRows-1) IF Gfx THEN CALL GraphHole(30, 5+rowO, 5+colO, r+1, 77+colO) BU10: 'Display the pitchers selected CALL Drawfrm(5+rowO, 5+colO, r, 75+colO, defattr, "'" + RTRIM$(Names(tm)) + " Bullpen", "Dbl-click (or Enter) selection or ESC", 1, 0, 2) QPRINTs 6+rowO, 7+colO, " Name L/R W L S G St Inn Hits BB SO ERA", defattr 'Row and Col are coordinates of the upper-left corner of the FRAME CALL PickFromPlyList (PlyList(), Av, r-7-rowO, 1, 66, 6+rowO, 5+colO, r, 75+colO, dimattr, revattr, Pick, RetKey, nulls$, 0) IF Pick > 0 THEN n = PlyList(Pick).Ref ELSE n = 0 ERASE PlyList GOTO BU999 END IF r2 = MIN&(Av+9+rowO, ConsRows-1) IF iused(n, tm) THEN CALL PopMsg(r2, 20+colO, " Sorry, that pitcher has already been used. ", errattr, 2, kc) GOTO BU10 END IF IF SimDaysOff(n, tm) > 0 AND DaysOffRule = TRUE THEN x$ = " This pitcher needs the day off. | Hit 'Y' to select anyway (with performance penalty). " CALL PopMsg(r2, 10+colO, x$, errattr, 0, kc) IF UCASE$(CHR$(kc)) <> "Y" THEN GOTO BU10 SimDaysOff(n, tm) = 0 - SimDaysOff(n, tm) END IF IF PitcherCloneUnused(DataName(n, tm), tm) = 0 THEN CALL PopMsg(r2, 23+colO, " Sorry, that pitcher is/has been in the lineup! ", errattr, 2, kc) GOTO BU10 END IF 'Reject if current pitcher is picked IF n = ipa(tm) THEN CALL PopMsg(r2, 24+colO, " Oops, that player is pitching now! ", errattr, 2, kc) GOTO BU10 END IF IF WarmUpRule = TRUE THEN 'Pitcher selected is "cold" IF WarmUpStatus(n, tm) < 1 THEN NowThrowing = 0 FOR i = 10 TO TopPitLim IF CalledFromOffense = FALSE THEN IF WarmUpStatus(i, tm) > 10 THEN INCR NowThrowing ELSE IF WarmUpStatus(i, tm) > 8 THEN INCR NowThrowing END IF NEXT 'Get up and start throwing if there's room (only 2 can throw at same time) IF NowThrowing > 1 THEN CALL PopMsg(r2, 23+colO, " You already have two people throwing! ", errattr, 2, kc) GOTO BU10 END IF IF CalledFromOffense = FALSE THEN WarmUpStatus(n, tm) = 12 ELSE WarmUpStatus(n, tm) = 10 END IF IF Gender(tm) THEN xS$ = " She'll get up and start throwing! " ELSE xS$ = " He'll get up and start throwing! " END IF CALL PopMsg(r2, 25+colO, xS$, errattr, 2, kc) CALL BuildBullpenPlyList (tm, PlyList(), Av, CalledFromOffense) 'Returns PlyList() and Av GOTO BU10 'Pitcher selected has just started throwing, not warm yet ELSEIF WarmUpStatus(n, tm) > 10 THEN IF Gender(tm) THEN xS$ = " She's not quite warm yet! " ELSE xS$ = " He's not quite warm yet! " END IF CALL PopMsg(r2, 28+colO, xS$, errattr, 2, kc) GOTO BU10 END IF END IF ERASE PlyList 'Just in case WarmUpRule = FALSE and somehow we get here from offense IF CalledFromOffense = TRUE THEN GOTO BU999 END IF 'We now have a new pitcher iused(ip, tm) = TRUE 'mark old ip as used BU150: ip = n 'set new IP ipa(tm) = ip 'store the pitchers address INCR np(tm) 'add to count of pitchers iyp(np(tm), tm) = ip 'store pitchers number by order of appearance nPitch(tm) = 0 'reset pitch-count (by team only) CALL AssignFatigue (tm) 'Reset WarmUpStatus of new pitcher IF WarmUpRule = TRUE THEN WarmUpStatus(ip, tm) = 0 'Check to see if pitcher has a save situation brewing DefLead = itruns(tm) - itruns(it) IF DefLead > 0 THEN 'Faces tying run on-deck IF DefLead < (NUMBERON + 3) THEN QualSave1IP = ip QualSave1ID = tm END IF 'Has a three-run (or less) lead with nobody on IF DefLead < 4 AND (NUMBERON = 0) THEN QualSave2IP = ip QualSave2ID = tm END IF END IF IF NOT dh THEN 'we have to put pitcher in batting order ps = 0 'find slot where the last pitcher was hitting (=ps) DO INCR ps IF ps > 9 THEN x$ = "ERROR(BULL1): No Pitcher Found in Lineup:" + DataFil(tm) CALL ErrorBox (x$) END IF LOOP UNTIL DataPos(ps, tm) = 1 'If the current guy in the pitcher's slot is a pinch-hitter, 'the pitcher he pinch-hit for is on the bench! Do a swap which 'puts the pinch-hitter back on the bench (he's not staying in the 'game) and the old pitcher temporarily back in the lineup. 'Then we'll copy the new pitcher into the lineup. 'Check the pitcher list to see if the guy in the pitcher's slot is here LastRealPitcher$ = DataName(iyp(np(tm)-1, tm), tm) IF DataName(ps, tm) <> LastRealPitcher$ THEN 'Must be a pinch hitter/runner 'Find LastRealPitcher$ on bench - with position of pitcher ps2 = SearchDAT(LastPiAd(tm)+1, MAXPLAYERS, tm, LastRealPitcher$, 1) IF ps2 THEN CALL Switch(ps, ps2, tm) 'Mark PH as used and restore his .DAT position iused(ps2, tm) = TRUE DataPos(ps2, tm) = OrgPos(DataRef(ps2, tm), tm) ELSE x$ = "ERROR(BULL1): Failed to locate previous pitcher on bench" x$ = x$ + "|" + DataFil(tm) CALL ErrorBox (x$) END IF END IF 'Copy pitcher's name and reference to slot ps 'Insert hitting stats 'Does new pitcher's name exist on bench? SearchName$ = DataName(ip, tm) n2 = SearchDAT (LastPiAd(tm)+1, MAXPLAYERS, tm, SearchName$, 0) IF n2 THEN CALL CopyStats(n2, ps, tm) ELSE DataAB(ps, tm) = 100 xS$ = UCASE$(DataCode(ip, tm)) code = ASC(xS$) - 64 IF code < 1 OR code > 5 THEN IF RND < .5 THEN DataHits(ps, tm) = 16 ELSE DataHits(ps, tm) = 17 END IF ELSE DataHits(ps, tm) = 30 - (5 * code) END IF '1 A = 24 25 '2 B = 19 20 '3 C = 14 15 '4 D = 09 10 '5 E = 04 05 DataHR(ps, tm) = DataHits(ps, tm) * .025 DataSO(ps, tm) = 49.1 - DataHits(ps, tm) * 0.9 DataBB(ps, tm) = 5 IF DataPBatAB(ip, tm) > 0 THEN DataAB(ps, tm) = DataPBatAB(ip, tm) DataHits(ps, tm) = DataPBatHi(ip, tm) DataHR(ps, tm) = DataPBatHR(ip, tm) DataBB(ps, tm) = DataPBatBB(ip, tm) DataSO(ps, tm) = DataPBatSO(ip, tm) END IF Data2B(ps, tm) = DataHits(ps, tm) * .14 Data3B(ps, tm) = DataHits(ps, tm) * .02 DataRBI(ps, tm) = DataHits(ps, tm) / 2.4 IF DataHand(ip, tm) = "r" THEN DataHand(ps, tm) = "L" ELSEIF DataHand(ip, tm) = "l" THEN DataHand(ps, tm) = "R" ELSE DataHand(ps, tm) = DataHand(ip, tm) END IF DataDef(ps, tm) = 0 DataSpeed(ps, tm) = 3 DataSB(ps, tm) = 1 'was 3 DataCS(ps, tm) = 1 'was 2 END IF DataName(ps, tm) = DataName(ip, tm) DataRef(ps, tm) = ip 'Mark New pitcher as NOT used in case he's coming in because 'the last pitcher was PH'ed for iused(ps, tm) = FALSE CALL AddToRefByBO (ps, tm, ip) 'bat position, team, ref END IF GOTO BU999 BU1000: 'Automatic manager side trip 'Mark old IP as used - guarantees we won't select the current pitcher ' "SUB Manage" guarantees there IS at least one more to select REDIM DupNameFlag (10:TopPitLim) AS LONG nn = LastPiAd(tm) IF DupNameTeam(tm) THEN FOR i = 10 TO nn SearchName$ = DataName(i, tm) IF PitcherCloneUnused(SearchName$, tm) = 0 THEN DupNameFlag(i) = TRUE NEXT END IF iused(ip, tm) = TRUE DefLead = itruns(tm) - itruns(it) CloserSituation = FALSE IF DefLead > -1 AND DefLead < 4 THEN IF StrictCloserRule THEN IF inn > 8 THEN IF DefLead > 0 THEN CloserSituation = TRUE END IF END IF ELSE IF inn > 8 THEN CloserSituation = TRUE ELSEIF inn = 8 AND (iout > 0 OR NUMBERON) THEN CloserSituation = TRUE END IF END IF END IF IF CloserSituation THEN GOSUB BUGetAvClosers IF AvCls > 0 THEN Closers = TRUE GOSUB BUSelectReliever CloserIn(tm) = TRUE ELSE GOSUB BUGetAvGeneral IF AvGen > 0 THEN Closers = FALSE GOSUB BUSelectReliever ELSE GOSUB BUFindAnyOne IF n = 0 THEN GOSUB DumpScoreCard x$ = "Bullpen Error-Closer: Out of Pitchers" x$ = x$ + "|" + DataFil(tm) CALL ErrorBox (x$) GOTO BU999 END IF END IF END IF ELSE 'Setup Pitcher Situation GOSUB BUGetAvGeneral IF AvGen > 0 THEN Closers = FALSE GOSUB BUSelectReliever ELSE GOSUB BUFindAnyOne IF n = 0 THEN GOSUB DumpScoreCard x$ = "Bullpen Error-General: Out of Pitchers" x$ = x$ + "|" + DataFil(tm) CALL ErrorBox (x$) GOTO BU999 END IF END IF END IF GOTO BU150 'Back to Primary Routine BUGetAvClosers: 'Games = DataGames(i, tm) 'Starts = DataGbyP(i, tm, 1) 'Saves = DataCS(i, tm) REDIM PitList(1 TO 25) AS TotPctType AvCls = 0 IF NewStyleWithSaves(tm) THEN TotSaves = 0 TopCloser = 0 TopCloserSaves = 0 IF LastPiAd(tm) < 15 THEN '5 or less pitchers [take all] nb = 10 ELSEIF LastPiAd(tm) < 18 THEN '6 - 8 pitchers nb = 14 ELSE '9 or more pitchers nb = 15 END IF FOR i = nb TO LastPiAd(tm) IF DataCS(i, tm) > 0 AND iused(i, tm) = 0 THEN IF SimDaysOff(i, tm) = 0 OR DaysOffRule = FALSE THEN IF NOT DupNameFlag(i) THEN IF DataCS(i, tm) > TopCloserSaves THEN TopCloserSaves = DataCS(i, tm) TopCloser = i END IF TotSaves = TotSaves + DataCS(i, tm) END IF END IF END IF NEXT FOR i = nb TO LastPiAd(tm) IF DataCS(i, tm) > 0 AND iused(i, tm) = 0 THEN IF SimDaysOff(i, tm) = 0 OR DaysOffRule = FALSE THEN IF NOT DupNameFlag(i) THEN IF TotSaves > 0 THEN IF i = TopCloser THEN 'the "Go-To Guy" xF! = (DataCS(i, tm) * 1.2) / TotSaves ELSE xF! = DataCS(i, tm) / TotSaves END IF IF xF! > 0 AND AvCls < 25 THEN INCR AvCls PitList(AvCls).PctOfTot = xF! PitList(AvCls).Slot = i END IF END IF END IF END IF END IF NEXT ELSE 'Old Style j = MIN&(15, LastPiAd(tm)) 'usually 15 unless not that many pitchers IF iused(j, tm) = 0 THEN IF SimDaysOff(j, tm) = 0 OR DaysOffRule = FALSE THEN IF NOT DupNameFlag(j) THEN AvCls = 1 PitList(1).Slot = j END IF END IF END IF END IF RETURN BUGetAvGeneral: 'Games = DataGames(i, tm) 'Starts = DataGbyP(i, tm, 1) 'Saves = DataCS(i, tm) REDIM PitList(1 TO 25) AS TotPctType TotInn = 0 IF NewStyleWithSaves(tm) THEN 'Have Games, Starts and Saves FOR i = 10 TO LastPiAd(tm) 'If no spot starters, skip pitchers in starting rotation GOSUB CheckIfInRotation IF SkipHim = FALSE AND iused(i, tm) = 0 THEN IF SimDaysOff(i, tm) = 0 OR DaysOffRule = FALSE THEN RA = DataGames(i, tm) - DataGbyP(i, tm, 1) IF RA > 0 THEN IF (DataCS(i, tm) / RA) < .2 THEN 'We skip high-save guys IF NOT DupNameFlag(i) THEN 'Primarily Starter or Reliever? IF DataGbyP(i, tm, 1) < (DataGames(i, tm) \ 2) THEN 'Primarily a reliever ReliefInn = DataAB(i, tm) - (DataGbyP(i, tm, 1) * 6) ELSE 'Primarily a starter (w/2 innings per relief appearance) ReliefInn = RA * 2 END IF IF ReliefInn < 0 THEN ReliefInn = 0 TotInn = TotInn + ReliefInn END IF END IF END IF END IF END IF NEXT AvGen = 0 TopDogInn = 0 TopDog = 0 FOR i = 10 TO LastPiAd(tm) 'If no spot starters, skip pitchers in starting rotation GOSUB CheckIfInRotation IF SkipHim = FALSE AND iused(i, tm) = 0 THEN IF SimDaysOff(i, tm) = 0 OR DaysOffRule = FALSE THEN RA = DataGames(i, tm) - DataGbyP(i, tm, 1) IF RA > 0 THEN IF (DataCS(i, tm) / RA) < .2 THEN 'We skip high-save guys IF NOT DupNameFlag(i) THEN IF TotInn > 0 THEN 'Primarily Starter or Reliever? IF DataGbyP(i, tm, 1) < (DataGames(i, tm) \ 2) THEN 'Primarily a reliever ReliefInn = DataAB(i, tm) - (DataGbyP(i, tm, 1) * 6) ELSE 'Primarily a starter (w/2 innings per relief appearance) ReliefInn = RA * 2 END IF IF ReliefInn > TopDogInn THEN TopDogInn = ReliefInn TopDog = i END IF IF ReliefInn > 0 AND AvGen < 25 THEN INCR AvGen xF! = ReliefInn / TotInn PitList(AvGen).PctOfTot = xF! PitList(AvGen).Slot = i END IF END IF END IF END IF END IF END IF END IF NEXT ELSE 'Old Style .DAT (we know nothing about Games, Starts & Saves) IF LastPiAd(tm) < 15 THEN '5 or less pitchers [take last] nb = LastPiAd(tm) ELSEIF LastPiAd(tm) = 15 THEN '6 nb = 14 ELSE '7 or more nb = 16 'we assume slot 15 is closer END IF TotInn = 0 FOR i = nb TO LastPiAd(tm) IF i <> 15 THEN IF iused(i, tm) = 0 THEN IF SimDaysOff(i, tm) = 0 OR DaysOffRule = FALSE THEN IF NOT DupNameFlag(i) THEN TotInn = TotInn + DataAB(i, tm) END IF END IF END IF END IF NEXT AvGen = 0 FOR i = nb TO LastPiAd(tm) IF i <> 15 THEN IF iused(i, tm) = 0 THEN IF SimDaysOff(i, tm) = 0 OR DaysOffRule = FALSE THEN IF NOT DupNameFlag(i) THEN IF TotInn > 0 THEN IF AvGen < 25 THEN INCR AvGen xF! = DataAB(i, tm) / TotInn PitList(AvGen).PctOfTot = xF! PitList(AvGen).Slot = i END IF END IF END IF END IF END IF END IF NEXT END IF RETURN CheckIfInRotation: 'Input: i SkipHim = FALSE 'Does rotation record exist? Fil$ = DataFil(tm) j = ROTATIONLIST (Fil$) 'RotationList does not exist in Single Game mode, so SBS can pick anyone IF j > 0 THEN IF RotRec(j).RotSpot = " " OR AllowStartersInRelief = FALSE THEN 'We will not allow relivers to be pulled from the starting rotation ' 1. If Spot Starters are not used, OR ' 2. STARTERS-MAY-RELIEVE was specified in baseball.cfg 'Check if pitcher "i" is in starting rotation jj = 1 DO UNTIL jj > 5 OR SkipHim = TRUE IF i = RotRec(j).RotList(jj) THEN SkipHim = TRUE INCR jj LOOP END IF END IF RETURN BUFindANYONE: n = 0 'Try #14 and #15 first: IF LastPiAd(tm) > 14 THEN IF iused(14, tm) = 0 AND DupNameFlag(i) = 0 THEN n = 14 ELSEIF iused(15, tm) = 0 AND DupNameFlag(i) = 0 THEN n = 15 END IF END IF IF n THEN RETURN 'Last desperate search i = 10 DO UNTIL i > LastPiAd(tm) IF iused(i, tm) = 0 AND DupNameFlag(i) = 0 THEN n = i EXIT DO END IF INCR i LOOP RETURN BUSelectReliever: IF Closers = TRUE THEN NList = AvCls TopDog = 99 ELSE NList = AvGen END IF IF NList = 1 THEN n = PitList(1).Slot ELSEIF NList > 1 THEN DO 'Get a random number to select the pitcher xF! = RND Pick = 0 BaseP! = 0 FOR i = 1 TO NList IF xF! < BaseP! + PitList(i).PctOfTot THEN Pick = i EXIT FOR END IF BaseP! = BaseP! + PitList(i).PctOfTot NEXT IF Pick = 0 THEN Pick = NList n = PitList(Pick).Slot LOOP WHILE n = TopDog AND inn > 6 AND RND < .25 'Reject the biggest-inning guy after the 6th some of the time END IF RETURN DumpScoreCard: 'Append ScoreCard to CmdScrF$ file IF CmdScrF$ > "!" THEN REDIM List1(1 TO 300) AS List1Type CALL LoadScoreCardToList1 (List1(), j) ' j returns items in list IF LEFT$(CmdScrF$, 3) = "LPT" THEN xS$ = CmdScrF$ ELSE xS$ = CmdWritePath$ + CmdScrF$ END IF CALL DumpList(List1(), j, xS$, TRUE) ERASE List1 END IF RETURN BU999: IF NOT amgr(tm) THEN IF Gfx THEN CALL EliminateHole(30) QPop END IF END SUB SUB BUNTRoutine ON ERROR GOTO ERRORTRAP 'We take back some of these results if batter doesn't make contact WhoAtPos = fr4 IF WhoAtPos = 4 THEN WhoAtPos = 5 wag = WHOATGUY(WhoAtPos) Result$ = LTRIM$(STR$(WhoAtPos)) 'What if a Pitch-Out occurred? IF POut THEN IF ir3 <> 0 AND iout < 2 THEN GOTO CheckSqueeze ELSE IF DelFac THEN AddToAnnouncer id, "They Pitchout..." AddToAnnouncer it, "The batter pulls the bat back..." AddToAnnouncer it, "And the runner holds..." END IF CALL ResetBatter Result$ = "" WhoAtPos = 0 'to keep defense from flashing EXIT SUB END IF END IF 'Sac Bunt Attempts that accidentally turn into a hit IF DataSpeed(ib, it) < 4 THEN x! = .13: y! = .11 ELSEIF DataSpeed(ib, it) < 7 THEN x! = .18: y! = .13 ELSEIF DataSpeed(ib, it) < 9 THEN x! = .23: y! = .15 ELSE x! = .28: y! = .17 END IF IF (ir1 = 0 AND ir2 = 0 AND ir3 = 0) THEN y! = 0 IF Tight THEN z! = x! - y! + .05 ELSE z! = 0 END IF IF RND < (x! - y! - z!) THEN ' IF (DataSpeed(ib, it) / 2) + FRND(10) > 13 THEN 'Its a hit! 9/19 '7 - 10% '8 - 10% '9 - 20% IF DelFac THEN IF SoundOn THEN CALL WavBunt CALL Msg ("24", "0", "0", "01", ib, it, man2, team2) 'sq's around CALL Msg ("24", "0", "0", "02", ib, it, man2, team2) 'down CALL Msg ("02", "4", "2", "00", wag, id, man2, team2) 'fields & throws CALL Msg ("23", "0", "0", "01", 0, it, man2, team2) 'safe END IF CALL Advanc(1, 1, 1) ir1 = ib mpp(ib) = ip 'Credit the hit. Bump "Batters Faced". CALL CreditHit INCR mpbf(ip, id) Result$ = "1B" EXIT SUB END IF 'Nobody on base! OR two-out: Just an out. IF (ir1 = 0 AND ir2 = 0 AND ir3 = 0) OR iout = 2 THEN IF DelFac THEN IF SoundOn THEN CALL WavBunt CALL Msg ("24", "0", "0", "01", ib, it, man2, team2) 'sq's around CALL Msg ("24", "0", "0", "02", ib, it, man2, team2) 'down CALL Msg ("02", "4", "2", "00", wag, id, man2, team2) 'fields & throws CALL Msg ("02", "4", "3", "00", ib, it, man2, team2) 'out END IF INCR iout INCR mpo(ip, id) IF WhoAtPos <> 3 THEN Result$ = Result$ + "-3" INCR Assists(DataRef(wag, id), id, WhoAtPos) ELSE Result$ = Result$ + "UN" END IF INCR PutOuts(DataRef(WHOATGUY(3), id), id, 3) INCR mpbf(ip, id) EXIT SUB END IF CheckSqueeze: 'Calculate bunting ability (successrate!) singles = DataHits(ib,it) - Data2B(ib,it) - Data3B(ib,it) - DataHR(ib,it) x! = (singles + DataSB(ib,it) - DataCS(ib,it)) / (DataAB(ib,it) + DataBB(ib,it)) x1! = x! / p1baseF(it) 'around 1.0 would be a bit less than average 'get pitchers rate IF DataPos(ib, it) = 1 AND DataRef(ib, it) <= LastPiAd(it) THEN SuccessRate! = x1! - .1 ' zzzSumR = zzzSumR + SuccessRate! ' zzzSumN = zzzSumN + 1 ELSE SuccessRate! = x1! - .2 END IF IF SuccessRate! < .35 THEN SuccessRate! = .35 IF SuccessRate! > .85 THEN SuccessRate! = .85 IF ir3 THEN 'RUNNER ON THIRD SqueezeAttempt = FALSE IF ir1 <> 0 AND ir2 = 0 THEN '1st and 3rd situation IF amgr(it) = 0 THEN 'Player is calling the shots x$ = " Attempt squeeze? [y/N]" CALL PopMsg(10+rowO, 30+colO, x$, errattr, 0, kc) IF UCASE$(CHR$(kc)) = "Y" THEN SqueezeAttempt = TRUE ELSE 'Computer is in control IF RND < DataSpeed(ir3, it) / 9 THEN SqueezeAttempt = TRUE '8 'Also, make SqueezeAttempt true is pitcher is next IF ib < 9 THEN ibp1 = ib + 1 ELSE ibp1 = 1 IF DataPos(ibp1, it) = 1 THEN SqueezeAttempt = TRUE 'No Squeeze if infield is in IF Tight THEN SqueezeAttempt = FALSE END IF ELSE SqueezeAttempt = TRUE END IF IF SqueezeAttempt THEN IF DelFac THEN CALL Msg ("24", "0", "0", "04", 0, it, man2, team2) 'sq is on! Success = FALSE IF NOT Tight THEN IF RND < SuccessRate! THEN Success = TRUE ELSE 'IF FRND(10) + DataSpeed(ir3) > 15 THEN Success = TRUE IF RND < SuccessRate! * 0.66 THEN Success = TRUE END IF IF POut THEN Success = FALSE IF Success THEN IF DelFac THEN IF SoundOn THEN CALL WavBunt CALL Msg ("24", "0", "0", "10", ir3, it, man2, team2) 'here comes CALL Msg ("15", "0", "0", "05", ir3, it, man2, team2) 'SAFE END IF CALL Advanc(1, 1, 1) IF DelFac THEN CALL Msg ("02", "4", "3", "00", ib, it, man2, team2) 'batter out INCR iout INCR mpo(ip, id) 'credit a squeeze as a sacrifice INCR mSacB(ref, it) mab(ref, it) = mab(ref, it) - 1 IF UCASE$(DataHand(ip, id)) = "L" THEN mabLHP(ref, it) = mabLHP(ref, it) - 1 ELSE mabRHP(ref, it) = mabRHP(ref, it) - 1 END IF IF WhoAtPos <> 3 THEN Result$ = Result$ + "-3 SQZ" n = 3 INCR Assists(DataRef(wag, id), id, WhoAtPos) ELSE Result$ = Result$ + "-4 SQZ" n = 4 END IF INCR PutOuts(DataRef(WHOATGUY(n), id), id, n) INCR mpbf(ip, id) ELSE IF DelFac THEN 'Squeeze Unsuccessful IF POut THEN AddToAnnouncer id, "They Pitchout!" CALL Msg ("24", "0", "0", "03", ib, it, man2, team2) 'no contact CALL Msg ("24", "0", "0", "10", ir3, it, man2, team2) 'here comes AddToAnnouncer it, "He is...OUT at the plate!" CALL Msg ("29", "0", "0", "11", 0, id, man2, team2) 'boo END IF INCR iout INCR mpo(ip, id) i = ir3 ir3 = ir2 ir2 = ir1 ir1 = 0 Result$ = "" CALL AddToScoreCrd(it, DataRef(i, it), "4", "1-2 Bad SQZ") INCR PutOuts(DataRef(WHOATGUY(2), id), id, 2) 'Runner on 3rd should get tagged with a caught stealing INCR mcs(DataRef(i, it), it) 'No assist unless the pitcher gets one (this was a pitchout) CALL ResetBatter WhoAtPos = 0 'to keep defense from flashing END IF EXIT SUB END IF END IF ' Either NO Runner on Third ' [1st only, 2nd only or 1st and 2nd] ' OR ' 1st and 3rd and NO Squeeze Attempt 'Basic Sacrifice attempt IF DelFac THEN IF SoundOn THEN CALL WavBunt CALL Msg ("24", "0", "0", "01", ib, it, man2, team2) 'sq's around END IF Success = FALSE IF NOT Tight THEN IF RND < SuccessRate! THEN Success = TRUE ELSE IF RND < .55 THEN Success = TRUE END IF IF Success THEN zzsacok = zzsacok + 1 IF DelFac THEN CALL Msg ("24", "0", "0", "02", ib, it, man2, team2) 'bunt is down CALL Msg ("24", "0", "0", "11", wag, id, man2, team2) '* up with it END IF INCR iout 'Success - runners advance (except 3rd) INCR mpo(ip, id) INCR mSacB(ref, it) mab(ref, it) = mab(ref, it) - 1 IF UCASE$(DataHand(ip, id)) = "L" THEN mabLHP(ref, it) = mabLHP(ref, it) - 1 ELSE mabRHP(ref, it) = mabRHP(ref, it) - 1 END IF CALL Advanc(1, 1, 0) IF DelFac THEN CALL Msg ("02", "4", "3", "00", ib, it, man2, team2) 'batter out CALL Msg ("24", "0", "0", "07", ib, it, man2, team2) 'nice bunt END IF IF WhoAtPos <> 3 THEN Result$ = Result$ + "-3 SAC" n = 3 INCR Assists(DataRef(wag, id), id, WhoAtPos) ELSE Result$ = Result$ + "-1 SAC" n = 1 END IF INCR PutOuts(DataRef(WHOATGUY(n), id), id, n) ELSE 'Unsuccessful! zzsacfa = zzsacfa + 1 INCR iout INCR mpo(ip, id) IF Tight THEN x! = .9 ELSE x! = .5 IF RND < x! THEN 'Lead runner out - batter reaches first i = 4 Rezult$ = " FO" IF ir3 = 0 THEN IF ir2 THEN 'Get lead runner at third ir2 = ir1 'Proposed fix: IF ir1 = 0 THEN Rezult$ = " FC" '--- IF WhoAtPos <> 5 THEN i = 5 ELSE i = 6 'Proposed change - no more 5-6 force outs 'change to 1-5 WhoAtPos = 1 wag = WHOATGUY(WhoAtPos) Result$ = "1" i = 5 '--- END IF END IF END IF ir1 = ib mpp(ib) = ip Result$ = Result$ + "-" + LTRIM$(STR$(i)) + Rezult$ INCR Assists(DataRef(wag, id), id, WhoAtPos) INCR PutOuts(DataRef(WHOATGUY(i), id), id, i) IF DelFac THEN CALL Msg ("24", "0", "0", "02", ib, it, man2, team2) 'bunt is down CALL Msg ("24", "0", "0", "11", wag, id, man2, team2) '* up with it CALL Msg ("24", "0", "0", "06", 0, id, man2, team2) 'get lead CALL Msg ("24", "0", "0", "08", ib, it, man2, team2) 'batter on END IF ELSE 'Batter pops it up INCR PutOuts(DataRef(wag, id), id, WhoAtPos) IF DelFac THEN CALL Msg ("05", "0", "3", "00", 0, it, man2, team2) 'popped it up CALL Msg ("24", "0", "0", "09", wag, id, man2, team2) '* grabes it END IF END IF END IF INCR mpbf(ip, id) EXIT SUB ErrorTrap: LOCATE 10, 30 PRINT "BUNT_Error"; ERRCLEAR LOCATE 11, 30 PRINT "wag="; wag; "WhoAtPos="; WhoAtPos; "n="; n; x$ = WAITKEY$ END SUB SUB Button (row, col, attr, xS$, shadow) QPRINTs row, col, xS$, attr IF shadow THEN L = LEN(xS$) a = SCREENATTR(row + 1, col + i) 'return color attr at shadow point bac = (a AND &H70) \ 16 'background color at shadow point attr2 = bac * 16 'black on background color FOR i = 1 TO L QPRINTs row + 1, col + i, CHR$(223), attr2 NEXT QPRINTs row, col + L, CHR$(220), attr2 END IF END SUB SUB ChangeAttribute (row, col, leng, attr) STATIC 'Pure PB/CC method LOCATE row, col forg = attr MOD 16 bacg = attr \ 16 IF (col + leng) < (ConsCols + 2) THEN COLOR forg, bacg, leng END SUB SUB CheckForValidFile (File$, RecLen, Valid) 'Is File$ the old format or the new? 'Check for existence of File$ before going here OPEN File$ FOR BINARY AS #4 L& = LOF(4) IF (L& MOD RecLen <> 0) THEN 'Wrong Record Length Valid = 0 ELSE Valid = -1 END IF CLOSE #4 END SUB SUB ClearActiveSTATRec OPEN CmdPath$ + CmdSCH$ FOR BINARY AS #2 Buffer$ = SPACE$(90) GET #2 ,, Buffer$ 'Read 1st 90 bytes (active stat files) MID$(Buffer$, 11, 80) = SPACE$(80) PUT #2, 1, Buffer$ 'Rewrite 1st 90 bytes CLOSE #2 STx = 0 REDIM ActiveSTAT(10) AS GLOBAL STRING END SUB SUB ClipIfNecessary (xS$, tr, tc, b1r1, b1c1, b1r2, b1c2, b2r1, b2c1, b2r2, b2c2, ca, cf) 'Input: ' xS$ ' Object origin and length: tr, tc ' Box to protect: b1r1, b1c1, b1r2, b1c2 'Output: ' xS$ ' first column: ca ' last column: cf ce = tc + LEN(xS$) - 1 cf = ce ca = 0 cb = 0 'Does any part of the name overlap the batting orders? FOR i = tc TO ce IF Inbox(b1r1, b1c1, b1r2, b1c2, tr, i, -1) THEN IF cb = 0 THEN cb = i ELSE IF ca = 0 THEN ca = i END IF NEXT IF cb = 0 THEN 'we didn't clip anything -- try other box ca = 0 FOR i = tc TO ce IF Inbox(b2r1, b2c1, b2r2, b2c2, tr, i, -1) THEN IF cb = 0 THEN cb = i ELSE IF ca = 0 THEN ca = i END IF NEXT END IF IF cb = 0 THEN 'we still didn't clip anything ca = tc cf = ce EXIT SUB END IF IF ca > 0 THEN IF cb > ca THEN 'clipped on right xS$ = MID$(xS$, 1, cb-ca) cf = cb - 1 ELSE 'clipped on left xS$ = MID$(xS$, ca-tc+1) cf = ce END IF END IF END SUB SUB ClearInpBuffer DO x$ = INKEY$ LOOP WHILE LEN(x$) END SUB SUB CopyStats(fr, tw, tm) DataAB(tw, tm) = DataAB(fr, tm) DataHits(tw, tm) = DataHits(fr, tm) DataHR(tw, tm) = DataHR(fr, tm) DataSO(tw, tm) = DataSO(fr, tm) DataBB(tw, tm) = DataBB(fr, tm) Data2B(tw, tm) = Data2B(fr, tm) Data3B(tw, tm) = Data3B(fr, tm) DataRBI(tw, tm) = DataRBI(fr, tm) DataHand(tw, tm) = DataHand(fr, tm) DataDef(tw, tm) = DataDef(fr, tm) DataSB(tw, tm) = DataSB(fr, tm) DataCS(tw, tm) = DataCS(fr, tm) DataSpeed(tw,tm) = DataSpeed(fr,tm) FOR i = 1 TO 4 DataPosi(tw, tm, i) = DataPosi(fr, tm, i) DataGByP(tw, tm, i) = DataGByP(fr, tm, i) NEXT END SUB SUB CountActiveSTATFiles OPEN CmdPath$ + CmdSCH$ FOR BINARY AS #2 Buffer$ = SPACE$(90) GET #2 ,, Buffer$ STx = 0 REDIM ActiveSTAT(10) AS GLOBAL STRING a$ = MID$(Buffer$, 11, 8) n = 11 DO WHILE a$ <> SPACE$(8) AND STx < 10 INCR STx ActiveSTAT(STx) = RTRIM$(a$) a$ = MID$(Buffer$, n + 8, 8) n = n + 8 LOOP CLOSE #2 END SUB SUB CountAvPitchers (t, Av, LastGuy) STATIC Av = 0 LastGuy = 0 FOR i = 10 TO LastPiAd(t) IF iused(i, t) = 0 AND i <> ipa(t) THEN IF SimDaysOff(i, t) = 0 OR DaysOffRule = FALSE THEN IF DupNameTeam(t) THEN IF PitcherCloneUnused(DataName(i, t), t) THEN OK = TRUE ELSE OK = FALSE END IF ELSE OK = TRUE END IF IF OK THEN IF NewStyle(t) THEN 'Games > Starts IF DataGames(i, t) > DataGbyP(i, t, 1) THEN INCR Av LastGuy = i END IF ELSE INCR Av LastGuy = i END IF END IF END IF END IF NEXT END SUB SUB CreditHit 'pitcher: INCR mph(ip, id) 'hitter: INCR mhits(ref, it) IF UCASE$(DataHand(ip, id)) = "L" THEN INCR mhitsLHP(ref, it) ELSE INCR mhitsRHP(ref, it) END IF INCR ithits(it) INCR innh END SUB SUB DefCheck (OutOfPositionMsg) FOR i = 1 TO 9 OK = FALSE CurrPos = DataPos(i, id) IF CurrPos = 1 OR CurrPos = 10 THEN OK = TRUE ELSE IF DataPosi(i, id, 1) > 0 AND DataGbyP(i, id, 1) > 0 THEN 'Strict IF FoundPosition(CurrPos, i, id) THEN OK = TRUE END IF ELSE ListedPos = OrgPos(DataRef(i, id), id) 'Loose SELECT CASE CurrPos CASE 2 IF ListedPos = 2 THEN OK = TRUE CASE 3 IF ListedPos = 3 OR ListedPos = 5 THEN OK = TRUE CASE 4 IF ListedPos = 4 OR ListedPos = 6 THEN OK = TRUE CASE 5 IF ListedPos = 5 OR ListedPos = 6 THEN OK = TRUE CASE 6 IF ListedPos = 6 THEN OK = TRUE CASE 7, 8, 9 IF ListedPos = 7 OR ListedPos = 8 OR ListedPos = 9 THEN OK = TRUE END SELECT END IF END IF IF OK = FALSE AND OutOfPositionMsg = TRUE THEN zS$ = LASTNAME$(DataName(i, id)) xS$ = "Note: " + zS$ + " is playing out-of-position. " CALL PopMsg(9+rowO, 20+colO, xS$, errattr, 2, kc) END IF NEXT 'Are all positions occupied? IF dh THEN p1 = 2: p2 = 10 ELSE p1 = 1: p2 = 9 FOR p = p1 TO p2 OK = FALSE FOR i = 1 TO 9 IF p = DataPos(i, id) THEN OK = TRUE EXIT FOR END IF NEXT IF NOT OK THEN xS$ = STR$(p) CALL PopMsg(10+rowO, 20+colO, "Lineup error: No Position" + xS$, errattr, 2, kc) END IF NEXT END SUB SUB DefCoordinates (p, r, c, ObsD, ObsY, ObsH, ObsTz, ObsTy) ON ERROR GOTO ERRORTRAP IF ConsRows < 28 OR ConsCols < 85 THEN SELECT CASE p CASE 1 r = MidRow + 4: c = MidCol - 6 CASE 2 r = MidRow + 9: c = MidCol - 4 CASE 3 r = MidRow + 2: c = MidCol + 11 CASE 4 r = MidRow : c = MidCol + 4 CASE 5 r = MidRow + 2: c = MidCol - 16 CASE 6 r = MidRow : c = MidCol - 12 CASE 7 r = MidRow - 3: c = MidCol - 26 CASE 8 r = MidRow - 5: c = MidCol - 4 CASE 9 r = MidRow - 3: c = MidCol + 16 CASE 10 r = 0: c = 0 END SELECT EXIT SUB END IF DIM ax(10) DIM ay(10) DIM az(10) ax(1) = 58: ay(1) = -10: az(1) = 0 'pitcher ax(2) = -3: ay(2) = -3: az(2) = 0 'catcher ax(3) = 73: ay(3) = 53: az(3) = 0 '1st ax(4) = 128: ay(4) = 32: az(4) = 0 '2nd ax(5) = 73: ay(5) = -63: az(5) = 0 '3rd ax(6) = 128: ay(6) = -38: az(6) = 0 'short ax(7) = 250: ay(7) = -150: az(7) = 0 'lf ax(8) = 350: ay(8) = -15: az(8) = 0 'cf ax(9) = 250: ay(9) = 150: az(9) = 0 'rf ox = ObsD oy = ObsY oz = ObsH xw! = .8 sfv! = ConsRows sfh! = ConsCols * .85 TiltZ! = ObsTz * .01745 'convert to radians TiltY! = ObsTy * .01745 'convert to radians TiltZ! = CircularFcn(TiltZ!) TiltY! = CircularFcn(TiltY!) 'Verticle (row) IF ox = ax(p) AND oy = ay(p) THEN ThetaZ! = 0 ELSE ThetaZ! = ATN( (oz - az(p)) / SQR( (ox - ax(p))^2 + (oy - ay(p))^2 ) ) ThetaZ! = CircularFcn(ThetaZ!) END IF ThetaZ! = CircularFcn(ThetaZ! + TiltZ!) IF ThetaZ! > 3.14159 THEN SignFac! = 1.0 ELSE SignFac! = -1.0 cv! = SignFac! * TAN(ThetaZ!) * xw! * sfv! 'Horizontal (column) IF ox = ax(p) AND oy = ay(p) THEN ThetaY! = 0 ELSE ThetaY! = ATN( (oy - ay(p)) / SQR( (ox - ax(p))^2 + (oy - ay(p))^2 ) ) ThetaY! = CircularFcn(ThetaY!) END IF ThetaY! = CircularFcn(ThetaY! + TiltY!) IF ThetaY! > 3.14159 THEN SignFac! = 1.0 ELSE SignFac! = -1.0 ch! = SignFac! * TAN(ThetaY!) * xw! * sfh! c = ch! + MidCol TotGraphRows = ConsRows - 6 'Calculate mid-row for graphics window, then add 5 because window starts at 6 mr! = (TotGraphRows \ 2) + 5 r = mr! - cv! IF c < 1 THEN c = 1 IF c > ConsCols THEN c = ConsCols IF r < 6 THEN r = 6 IF r > ConsRows - 1 THEN r = ConsRows - 1 GOTO DefCoordEXIT ErrorTrap: LOCATE 10, 30 PRINT "ERROR: DefCoordinates "; ERRCLEAR LOCATE 11, 30 x$ = WAITKEY$ DefCoordEXIT: END SUB SUB DefSwitch (row, tm) DIM Llitrow(3), Llitcol(3), Llit$(3), Lrow(3), Lcol(3), Llen(3), Led$(3), LContents$(3) IF Gfx THEN CALL GraphHole(30, row+rowO, 1+colO, row+18+rowO, 80+colO) CALL Drawfrm(row+rowO, 1+colO, row+17+rowO, 78+colO, defattr, "'" + RTRIM$(Names(tm))+ " Lineup", "ESC (or close window) to Continue", 1, 0, 1) QPRINTs row+2+rowO, 18+colO, "Change DEFENSIVE POSITIONING in Current Lineup", defattr DATA 16,35,"",16,37,01,"X " DATA 16,39,"",16,43,01,"X " Flds = 2 c = 1 FOR i = 1 TO Flds Llitrow(i) = VAL(READ$(c)) + row + rowO Llitcol(i) = VAL(READ$(c+1)) + colO Llit$(i) = READ$(c+2) Lrow(i) = VAL(READ$(c+3)) + row + rowO Lcol(i) = VAL(READ$(c+4)) + colO Llen(i) = VAL(READ$(c+5)) Led$(i) = READ$(c+6) c = c + 7 NEXT DoneSw = FALSE DO x$ = " Name Pos Gam Avg AB Hit HR Def Games@Pos" IF ERRSw(tm) THEN MID$(x$, 40, 3) = "ERR" QPRINTs row+4+rowO, 3+colO, x$, defattr FOR j = 1 TO 9 IF DataAB(j, tm) = 0 THEN BAF! = 0 ELSE BAF! = DataHits(j, tm) / DataAB(j, tm) END IF a$ = SPACE$(75) MID$(a$, 1, 1) = LFORMAT$(j, "#") MID$(a$, 3, 13) = DataName(j, tm) MID$(a$, 17, 2) = Pos(DataPos(j, tm)) MID$(a$, 20, 3) = LFORMAT$(DataGames(j, tm), "###") MID$(a$, 24, 4) = FFORMAT$(BAF!, ".###") MID$(a$, 29, 3) = LFORMAT$(DataAB(j, tm), "###") MID$(a$, 33, 3) = LFORMAT$(DataHits(j, tm), "###") MID$(a$, 37, 2) = LFORMAT$(DataHR(j, tm), "##") MID$(a$, 40, 3) = LFORMAT$(DataDef(j, tm), "###") b$ = "" FOR k = 1 TO 4 IF DataGByP(j,tm,k) > 0 THEN b$ = b$ + LFORMAT$(DataGbyP(j,tm,k), "####") + " @" IF DataPosi(j,tm,k) > 9 THEN b$ = b$ + "DH" ELSE b$ = b$ + LFORMAT$(DataPosi(j,tm,k), "##") END IF END IF NEXT bl = LEN(b$) IF bl THEN MID$(a$, 44, bl) = b$ END IF QPRINTs row+4+j+rowO, 3+colO, a$, dimattr NEXT FOR i = row+5+rowO TO row+13+rowO CALL ChangeAttribute(i, 19+colO, 2, revattr) NEXT QPRINTs row+15+rowO, 9+colO, "Enter the player numbers whose POSITION you want to switch.", defattr x$ = LPtr$ + "-" + RPtr$ QPRINTs row+16+rowO, 39+colO, x$, defattr LContents$(1) = " " LContents$(2) = " " CursorPtr = 1 DO TakeFromAnywhere = 1 'Grabs any mouse-clicked character CALL ScreenIO(Keyed, KeyEsc, 0, KeyEsc, Flds, CursorPtr, Llen(), Lrow(), Lcol(), Led$(), Llit$(), Llitrow(), Llitcol(), LContents$()) TakeFromAnywhere = 0 IF LContents$(1) = " " AND LContents$(2) = " " THEN DoneSw = TRUE: EXIT DO p1 = VAL(LContents$(1)) p2 = VAL(LContents$(2)) IF p1 > 0 AND p1 <= 9 AND p2 > 0 AND p2 <= 9 THEN IF p1 = p2 THEN EXIT DO n1 = 0 n2 = 0 IF DataPos(p1, tm) = 1 THEN 'Can p2 pitch? SearchName$ = DataName(p2, tm) n2 = SearchDAT (10, LastPiAd(tm), tm, SearchName$, 0) IF n2 = 0 THEN CALL PopMsg(13+rowO, 28+colO, LASTNAME$(SearchName$) + " can't pitch. ", errattr, 2, kc) EXIT DO END IF END IF IF DataPos(p2, tm) = 1 THEN 'Can p1 pitch? SearchName$ = DataName(p1, tm) n1 = SearchDAT (10, LastPiAd(tm), tm, SearchName$, 0) IF n1 = 0 THEN CALL PopMsg(13+rowO, 28+colO, LASTNAME$(SearchName$) + " can't pitch. ", errattr, 2, kc) EXIT DO END IF END IF SWAP DataPos(p1, tm), DataPos(p2, tm) 'Score Card IF inn > 0 THEN x$ = "[DEF]" + FLASTNAME$(p1, tm) _ + " to " + Pos(DataPos(p1, tm)) CALL AddToScoreCrd (0, 0, "X", x$) x$ = "[DEF]" + FLASTNAME$(p2, tm) _ + " to " + Pos(DataPos(p2, tm)) CALL AddToScoreCrd (0, 0, "X", x$) END IF 'Is a pitcher involved? n = 0 IF DataPos(p1, tm) = 1 THEN n = n1 p = p1 otherguy = p2 END IF IF DataPos(p2, tm) = 1 THEN n = n2 p = p2 otherguy = p1 END IF IF n THEN ip = n 'set new IP ipa(tm) = ip 'store the pitchers address INCR np(tm) 'add to count of pitchers iyp(np(tm), tm) = ip 'store pitchers number by order of appearance nPitch(tm) = 0 'clear pitch count CALL AssignFatigue (tm) 'Check to see if pitcher has a save situation brewing DefLead = itruns(tm) - itruns(it) IF DefLead > 0 THEN 'Faces tying run on-deck IF DefLead < (NUMBERON + 3) THEN QualSave1IP = ip QualSave1ID = tm END IF 'Has a three-run (or less) lead with nobody on IF DefLead < 4 AND (NUMBERON = 0) THEN QualSave2IP = ip QualSave2ID = tm END IF END IF 'For Box Score ?? ' CALL AddToRefByBO (p, tm, ip) 'bat position, team, ref 'Score Card 'CALL AddToScoreCrd (it, n, "A", "[Relief]") x$ = "[Relief]" + FLASTNAME$(ip, tm) CALL AddToScoreCrd (it, 0, "X", x$) 'Games-Played-By-Position (use normal pitcher ref no) IF GpPos(n, tm, 1) = 0 THEN GpPos(n, tm, 1) = 1 'Fix: 02/23/05 'Find ex-pitcher's clone and mark as used SearchName$ = DataName(otherguy, tm) nc = SearchDAT (LastPiAd(tm)+1, MAXPLAYERS, tm, SearchName$, 0) IF nc THEN iused(nc, tm) = TRUE END IF EXIT DO END IF LOOP LOOP UNTIL DoneSw IF Gfx THEN CALL EliminateHole(30) LOCATE 1, 1 END SUB SUB DefSwitchSetup (kc, Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) rowx = rowO colx = colO IF ConsRows > 28 THEN rowx = rowx + 2 CALL GetScreen(Scr1$, 20+rowx, 17+colx, 24+rowx, 66+colx) CALL DrawFrm(20+rowx, 17+colx, 24+rowx, 66+colx, defattr, nulls$, "ESC:Continue F3:Cancel", 0, 0, 2) FContents$(1) = "N" Flds = 1 DATA 22,19,"Want to change defensive positioning? [y/N] ",22,63,01,"X " c = 1 FOR i = 1 TO Flds Flitrow(i) = VAL(READ$(c)) + rowx Flitcol(i) = VAL(READ$(c+1)) + colx Flit$(i) = READ$(c+2) Frow(i) = VAL(READ$(c+3)) + rowx Fcol(i) = VAL(READ$(c+4)) + colx Flen(i) = VAL(READ$(c+5)) Fed$(i) = READ$(c+6) c = c + 7 NEXT CursorPtr = 1 DO s = defattr defattr = dimattr CALL ScreenIO(Keyed, KeyF3, 0, KeyEsc, Flds, CursorPtr, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) defattr = s ErrorSw$ = "N" 'Cancel IF Keyed = KeyF3 THEN EXIT DO IF FContents$(1) <> "Y" AND FContents$(1) <> "N" THEN ErrorSw$ = "Y" LOOP WHILE ErrorSw$ = "Y" kc = Keyed CALL PutScreen(Scr1$, 20+rowx, 17+colx, 24+rowx, 66+colx) END SUB SUB DelFrMMList (xS$) a$ = xS$ i = INSTR(a$, ".") IF i THEN a$ = LEFT$(a$, i - 1) a$ = RTRIM$(a$) Found = FALSE i = 0 DO INCR i IF i > MMx THEN EXIT DO IF RTRIM$(MMList(i).MMFile) = a$ THEN FOR j = i + 1 TO MMx MMList(j - 1) = MMList(j) NEXT MMList(MMx).MMFile = nulls$ DECR MMx EXIT DO END IF LOOP END SUB SUB Defens (StepThrough) STATIC xS$, zS$ IF Gfx = FALSE AND ConsRows = 25 AND ConsCols = 80 THEN 'Bases xS$ = CHR$(4) 'little diamond r = MidRow + 8: c = MidCol - 1: GOSUB PRINTIT r = MidRow : c = MidCol - 1: GOSUB PRINTIT r = MidRow + 4: c = MidCol + 11: GOSUB PRINTIT r = MidRow + 4: c = MidCol - 13: GOSUB PRINTIT 'Lower Diamond xS$ = CHR$(249) ' little dot was 250 r = MidRow + 2: c = MidCol - 19: GOSUB PRINTIT r = MidRow + 2: c = MidCol + 17: GOSUB PRINTIT r = MidRow + 1: c = MidCol + 20: GOSUB PRINTIT 'Upper diamond r = MidRow + 2: c = MidCol - 7: GOSUB PRINTIT r = MidRow + 2: c = MidCol + 5: GOSUB PRINTIT 'Inf-outf border r = MidRow + 1: c = MidCol - 15: GOSUB PRINTIT r = MidRow - 1: c = MidCol - 11: GOSUB PRINTIT r = MidRow - 2: c = MidCol - 5: GOSUB PRINTIT r = MidRow - 2: c = MidCol + 3: GOSUB PRINTIT r = MidRow - 1: c = MidCol + 9: GOSUB PRINTIT r = MidRow + 1: c = MidCol + 13: GOSUB PRINTIT 'Foul lines r = MidRow - 3: c = MidCol + 32: GOSUB PRINTIT r = MidRow - 3: c = MidCol - 34: GOSUB PRINTIT END IF 'Get rid of old holes/or erase positions IF Gfx THEN FOR p = 1 TO 9 CALL EliminateHole(20+p) NEXT ELSE zS$ = SPACE$(11) FOR p = 2 TO 9 CALL DefCoordinates (p, r, c, ObsD, ObsY, ObsH, ObsTz, ObsTy) IF r > 0 AND c > 0 THEN QPRINTs r, c, zS$, fldattr END IF NEXT END IF 'Refresh screen after eliminating the defense IF DelFac > 0 AND StepThrough > 0 THEN IF Gfx THEN GfxRefresh 0 CALL Delay(StepThrough/1000.0##) END IF IF DelFac = 0 THEN IF Gfx THEN GfxWindow %GFX_FREEZE END IF 'Batting order box borders 'Left b1r1 = ConsRows - 12 b1c1 = 2 b1r2 = b1r1 + 10 b1c2 = 18 'Right b2r1 = ConsRows - 12 b2c1 = ConsCols - 17 b2r2 = b2r1 + 10 b2c2 = ConsCols - 1 'Left team label: l1r1 = ConsRows - 14 l1c1 = 4 l1r2 = l1r1 l1c2 = l1c1 + LEN(RTRIM$(Names(1))) - 1 'Right team label: l2r1 = ConsRows - 14 l2c1 = ConsCols - 15 l2r2 = l2r1 l2c2 = l2c1 + LEN(RTRIM$(Names(2))) - 1 'Stick in the player names FOR p = 1 TO 9 CALL DefCoordinates (p, r, c, ObsD, ObsY, ObsH, ObsTz, ObsTy) IF r > 0 AND c > 0 THEN k = WHOATGUY(p) xS$ = LASTNAME$(DataName(k, id)) xS$ = LEFT$(xS$, 11) IF p = 1 THEN GOSUB PitchLabel: b=14 ELSE b=11 w = LEN(xS$) ce = c + w - 1 cf = ce ca = 0 cb = 0 'Does any part of the name overlap the batting orders? 'Try left batting order FOR i = c TO ce IF Inbox(b1r1, b1c1, b1r2, b1c2, r, i, -1) THEN IF cb = 0 THEN cb = i ELSE IF ca = 0 THEN ca = i END IF NEXT IF cb = 0 THEN 'We didn't clip anything 'Try right batting order ca = 0 FOR i = c TO ce IF Inbox(b2r1, b2c1, b2r2, b2c2, r, i, -1) THEN IF cb = 0 THEN cb = i ELSE IF ca = 0 THEN ca = i END IF NEXT END IF IF cb = 0 THEN 'We still didn't clip anything 'try left team label ca = 0 FOR i = c TO ce IF Inbox(l1r1, l1c1, l1r2, l1c2, r, i, -1) THEN IF cb = 0 THEN cb = i ELSE IF ca = 0 THEN ca = i END IF NEXT END IF IF cb = 0 THEN 'We still didn't clip anything 'try right team label ca = 0 FOR i = c TO ce IF Inbox(l2r1, l2c1, l2r2, l2c2, r, i, -1) THEN IF cb = 0 THEN cb = i ELSE IF ca = 0 THEN ca = i END IF NEXT END IF IF cb = 0 THEN 'we never did clip anything ca = c cf = ce ELSE IF ca > 0 THEN IF cb > ca THEN 'clipped on right xS$ = MID$(xS$, 1, cb-ca) cf = cb - 1 ELSE 'clipped on left xS$ = MID$(xS$, ca-c+1) cf = ce END IF END IF END IF 'Erase IF Gfx THEN IF ca THEN CALL GraphHole(20+p, r, ca, r, cf) ELSE QPRINTs r, c, SPACE$(b), fldattr END IF 'Replace by: IF ca THEN IF TeamAttr(id) <> 0 THEN kk = TeamAttr(id) ELSE kk = fldattr QPRINTs r, ca, xS$, kk END IF 'Map where to put the baserunners on the screen IF p = 3 THEN BasPatRow(1) = r + 1: BasPatCol(1) = c - 3 IF p = 6 THEN BasPatRow(2) = r + 1: BasPatCol(2) = c + 3 IF p = 5 THEN IF Gfx = FALSE AND ConsRows = 25 AND ConsCols = 80 THEN BasPatRow(3) = r + 1 ELSE BasPatRow(3) = r + 2 END IF BasPatCol(3) = c - 2 END IF IF p = 1 THEN BasPatRow(5) = r + 2: BasPatCol(5) = c IF DelFac > 0 AND StepThrough > 0 THEN IF Gfx THEN GfxRefresh 0 CALL Delay(StepThrough/1000.0##) END IF END IF NEXT IF DelFac = 0 THEN IF Gfx THEN GfxWindow NOT %GFX_FREEZE END IF 'Re-do what defense may have overwritten IF Gfx = FALSE AND ConsRows = 25 AND ConsCols = 80 THEN QPRINTs 14+rowO, 33+colO, CHR$(249), fldattr END IF GOTO DefensEXIT PRINTIT: QPRINTs r, c, xS$, fldattr RETURN PitchLabel: IF UCASE$(DataHand(ip, id)) = "R" THEN xS$ = "[R]" + xS$ ELSE xS$ = xS$ + "[L]" END IF RETURN ErrorTrap: LOCATE 10, 30 PRINT "ERROR: Defens "; ERRCLEAR LOCATE 11, 30 x$ = WAITKEY$ DefensEXIT: END SUB SUB DEFFix(r, c) IF SCREEN(r, c) = 32 THEN QPRINTs r, c, CHR$(249), fldattr END IF END SUB SUB DisplayKeysAndEdit (ParentFrame AS BoxType, ChildFrame AS BoxType, myfile$, RecLen, Flds, Fpos(), Flen(), Flitrow(), Flitcol(), Flit$(), Frow(), Fcol(), Fed$()) ' Displays list of "keys" in random access file and waits for your pick to edit ' ' row1, etc = screen location of parent "key" window ' recrow1, etc = screen location of child "record" window ' DIM FirstRecNum(100) '100 pages max DIM PageRecNum(120) '120 keys on a page max KeyEsc = 27 KeyRet = 13 KeyRtab = 9 KeyLtab = -15 KeyUp = -72 KeyDown = -80 KeyLeft = -75 KeyRight = -77 KeyBack = 8 KeyIns = -82 KeyDel = -83 KeyPgUp = -73 KeyPgDn = -81 COLOR dimfor, dimbac pageno = 1 PageKeyPtr = 1 FirstRecNum(1) = 1 IF LEN(DIR$(myfile$)) = 0 THEN BEEP FileNum = FREEFILE OPEN myfile$ FOR BINARY AS FileNum RecBuff$ = SPACE$(RecLen) MID$(RecBuff$, 1, 1) = "D" MID$(RecBuff$, 3, 8) = STRING$(8, 0) SEEK #FileNum, 1 PUT$ #FileNum, RecBuff$ CLOSE FileNum END IF FileNum = FREEFILE OPEN myfile$ FOR BINARY AS FileNum 'Set KeyPos and KeyLen to first input field KeyFldNdx = 0 GOSUB FindNextDataField KeyPos = Fpos(KeyFldNdx) KeyLen = Flen(KeyFldNdx) Reentry: LOCATE 1, 1 CURSOR OFF NumberOfRecords = LOF(FileNum) \ RecLen Columns = (ParentFrame.col2 - ParentFrame.col1 - 1) \ (KeyLen + 2) IF Columns = 0 THEN Columns = 1 KeysInColumn = ParentFrame.row2 - ParentFrame.row1 - 1 PageMaxKeys = KeysInColumn * Columns RecNumber = FirstRecNum(pageno) PageKeyCtr = 1 PageFull = False EofReached = False DO UNTIL PageFull 'don't read past EoF IF RecNumber > NumberOfRecords THEN EofReached = True PageFull = True EXIT DO END IF SEEK #FileNum, (RecNumber - 1) * RecLen + 1 GET$ #FileNum, RecLen, RecBuff$ 'logic to skip records marked delete DO WHILE MID$(RecBuff$, 1, 1) = "D" AND RecNumber < NumberOfRecords INCR RecNumber SEEK #FileNum, (RecNumber - 1) * RecLen + 1 GET$ #FileNum, RecLen, RecBuff$ LOOP IF RecNumber >= NumberOfRecords AND MID$(RecBuff$, 1, 1) = "D" THEN EofReached = True PageFull = True EXIT DO END IF 'given a PageKeyCtr, store the relative record number PageRecNum(PageKeyCtr) = RecNumber - FirstRecNum(pageno) + 1 'figure where to locate stak = (PageKeyCtr - 1) \ KeysInColumn + 1 c = ParentFrame.col1 + (stak - 1) * (KeyLen + 2) + 2 r = ParentFrame.row1 + PageKeyCtr - (stak - 1) * KeysInColumn IF PageKeyCtr = PageKeyPtr THEN attr = revattr HighLiteR = r: HighLiteC = c END IF QPRINTs r, c, MID$(RecBuff$, KeyPos, KeyLen), attr IF PageKeyCtr = PageKeyPtr THEN attr = dimattr INCR PageKeyCtr INCR RecNumber IF PageKeyCtr > PageMaxKeys THEN PageFull = True LOOP 'Wait for arrow keys / insert / esc / PageUp / PageDown / Enter DO mous = 0 msx = 0 msy = 0 KyS$ = WAITKEY$ s% = INSHIFT IF LEN(KyS$) = 1 THEN kc = ASC(KyS$) KyS$ = UCASE$(KyS$) ELSEIF LEN(KyS$) = 2 THEN kc = -ASC(RIGHT$(KyS$, 1)) ELSEIF LEN(KyS$) = 4 THEN IF ASC(KyS$, 3) = 2 THEN DoubleClick = TRUE ELSE DoubleClick = FALSE END IF mous = TRUE msx = MOUSEX msy = MOUSEY ms$ = CHR$(SCREEN(msy, msx)) IF ms$ = "—" THEN kc = 27 ELSEIF ms$ = CloseButton$ THEN kc = 13 ELSEIF msx > ParentFrame.col1 AND msx < ParentFrame.col2 AND msy > ParentFrame.row1 AND msy < ParentFrame.row2 THEN 'INSIDE frame IF NumberOfRecords > 0 THEN 'Determine PageItemPtr PageKeyPtr = msy - ParentFrame.row1 + INT((msx - ParentFrame.col1 - 2) / (KeyLen + 2)) * KeysInColumn IF PageKeyPtr < 1 THEN PageKeyPtr = 1 IF PageKeyPtr > PageKeyCtr - 1 THEN PageKeyPtr = PageKeyCtr - 1 GOSUB MoveHighLight IF DoubleClick THEN kc = 13 ELSE GOTO ContinueLoop END IF ELSE GOTO ContinueLoop END IF ELSEIF msx < ParentFrame.col1 OR msx > ParentFrame.col2 OR msy < ParentFrame.row1 OR msy > ParentFrame.row2 THEN 'OUTSIDE the frame - ESC kc = 27 ELSE 'ON the frame SELECT CASE ms$ ' CASE "V", "E", "A", "N", "F", "P", "Q" ' KyS$ = ms$ ' kc = ASC(KyS$) CASE DnPtr$ kc = -81 CASE UpPtr$ kc = -73 CASE ELSE kc = 27 END SELECT END IF END IF IF kc = KeyUp THEN IF PageKeyPtr > 1 THEN DECR PageKeyPtr GOSUB MoveHighlight GOTO ContinueLoop END IF END IF IF kc = KeyDown THEN IF PageKeyPtr < PageKeyCtr - 1 THEN INCR PageKeyPtr GOSUB MoveHighlight GOTO ContinueLoop END IF END IF IF kc = KeyLeft THEN IF PageKeyPtr > KeysInColumn THEN PageKeyPtr = PageKeyPtr - KeysInColumn GOSUB MoveHighlight GOTO ContinueLoop END IF END IF IF kc = KeyRight THEN IF PageKeyPtr + KeysInColumn < PageKeyCtr THEN PageKeyPtr = PageKeyPtr + KeysInColumn GOSUB MoveHighlight GOTO ContinueLoop END IF END IF IF kc = KeyPgUp THEN IF pageno > 1 THEN DECR pageno PageKeyPtr = 1 GOTO Reentry END IF IF kc = KeyPgDn AND EofReached = False THEN INCR pageno FirstRecNum(pageno) = RecNumber PageKeyPtr = 1 GOSUB BlankScreen GOTO Reentry END IF IF kc = KeyRet OR kc = KeyIns THEN CALL GetScreen (ScrBuf$, ChildFrame.row1, ChildFrame.col1,ChildFrame.row2 + 1, ChildFrame.col2 + 2) CALL Drawfrm(ChildFrame.row1, ChildFrame.col1, ChildFrame.row2, ChildFrame.col2, defattr, "", "Hit ESC When Done", 1, 0, 1) IF kc = KeyIns THEN RecNum = 0 ELSE RecNum = FirstRecNum(pageno) + PageRecNum(PageKeyPtr) - 1 END IF CLOSE FileNum CALL EditRandomRec(myfile$, RecNum, RecLen, Flds, Fpos(), Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol()) COLOR dimfor, dimbac CALL PutScreen (ScrBuf$, ChildFrame.row1, ChildFrame.col1, ChildFrame.row2 + 1, ChildFrame.col2 + 2) OPEN myfile$ FOR BINARY AS FileNum GOTO Reentry END IF IF kc = KeyF2 THEN CLOSE FileNum beg = 3 'KeyPos leng = 8 'KeyLen CALL QSortRand(myfile$, FileNum, RecLen, beg, leng, "A") OPEN myfile$ FOR BINARY AS FileNum GOTO Reentry END IF IF kc = KeyDel THEN QPRINTs ParentFrame.row2, 5, "[ Are you sure? Y/N ]", defattr x$ = WAITKEY$ QPRINTs ParentFrame.row2, 5, STRING$( 21, "Ž"), defattr IF UCASE$(x$) <> "Y" THEN GOTO ContinueLoop ELSE RecNum = FirstRecNum(pageno) + PageRecNum(PageKeyPtr) - 1 SEEK #FileNum, (RecNum - 1) * RecLen + 1 GET$ #FileNum, RecLen, RecBuff$ MID$(RecBuff$, 1, 1) = "D" SEEK #FileNum, (RecNum - 1) * RecLen + 1 PUT$ #FileNum, RecBuff$ GOSUB BlankScreen GOTO Reentry END IF END IF ContinueLoop: LOOP WHILE kc <> KeyEsc GOTO DisplayKeysExit FindNextDataField: i = KeyFldNdx + 1 IF i > Flds THEN i = 1 DO WHILE Frow(i) = 0 OR Fcol(i) = 0 INCR i IF i > Flds THEN i = 1 LOOP KeyFldNdx = i RETURN MoveHighlight: CALL ChangeAttribute(HighLiteR, HighLiteC, KeyLen, dimattr) stak = (PageKeyPtr - 1) \ KeysInColumn + 1 c = ParentFrame.col1 + (stak - 1) * (KeyLen + 2) + 2 r = ParentFrame.row1 + PageKeyPtr - (stak - 1) * KeysInColumn CALL ChangeAttribute(r, c, KeyLen, revattr) HighLiteR = r: HighLiteC = c RETURN BlankScreen: BlankLine$ = STRING$(ParentFrame.col2 - ParentFrame.col1 - 1, " ") c = ParentFrame.col1 + 1 FOR r = ParentFrame.row1 + 1 TO ParentFrame.row2 - 1 QPRINTs r, c, BlankLine$, dimattr NEXT RETURN DisplayKeysExit: CLOSE FileNum END SUB SUB Drawfrm (row1, col1, row2, col2, attr, TopLiteral$, BotLiteral$, Shadow, Style, ESCPoint) 'STATIC Cul$, Cho$, Cur$, Cmr$, Cml$, Cve$, Cll$, Clr$, CBl$ ' 1 1 2 2 2 ' 8 9 0 1 2 '+ 0 + 0 + 0 + 0 + 2 + ' ø ñ ý ü æ ô ú û § ¯ ¬ « ó ¨ · µ ¶ Ç Ž ’ € Ô Ò Ó Þ Ö × Ø Ñ ¥ ã à â å ™ ž ë é ê š í è á …   '201: 205:Ö 187:¯ 181:æ 198:’ 186:§ 200:Ô 188:¬ '218:é 196:Ž 191:¨ 180: 195:Ç 179:ü 192:· 217:ë IF ConsRows = 25 THEN BeginBuffer CBl$ = " " IF style = 0 THEN 'single lines Cul$ = CHR$(218) Cho$ = CHR$(196) Cur$ = CHR$(191) Cmr$ = CHR$(180) Cml$ = CHR$(195) Cv0$ = CHR$(179) Cll$ = CHR$(192) Clr$ = CHR$(217) Clo$ = " " + CloseButton$ + "Ç" CloCan$ = CHR$(180) + CloseButton$ + CHR$(179) + CHR$(249) + CHR$(195) ELSE Cul$ = CHR$(201) Cho$ = CHR$(205) Cur$ = CHR$(187) Cmr$ = CHR$(181) Cml$ = CHR$(198) Cv0$ = CHR$(186) Cll$ = CHR$(200) Clr$ = CHR$(188) Clo$ = "æ" + CloseButton$ + "’" CloCan$ = CHR$(181) + CloseButton$ + CHR$(179) + CHR$(249) + CHR$(198) END IF IF ESCPoint = 1 THEN xS$ = Cul$ + Clo$ + STRING$(col2 - col1 - 4, Cho$) + Cur$ ELSEIF ESCPoint = 2 THEN xS$ = Cul$ + CloCan$ + STRING$(col2 - col1 - 6, Cho$) + Cur$ ELSE xS$ = Cul$ + STRING$(col2 - col1 - 1, Cho$) + Cur$ END IF QPRINTs row1, col1, xS$, attr c = (col1 + col2) \ 2 - LEN(TopLiteral$) \ 2 - 1 IF LEN(TopLiteral$) THEN x$ = Cmr$ + TopLiteral$ + Cml$ QPRINTs row1, c, x$, attr END IF xS$ = Cv0$ + STRING$(col2 - col1 - 1, CBl$) + Cv0$ FOR r = row1 + 1 TO row2 - 1 QPRINTs r, col1, xS$, attr NEXT xS$ = Cll$ + STRING$(col2 - col1 - 1, Cho$) + Clr$ QPRINTs row2, col1, xS$, attr c = (col1 + col2) \ 2 - LEN(BotLiteral$) \ 2 - 1 IF LEN(BotLiteral$) THEN x$ = Cmr$ + BotLiteral$ + Cml$ QPRINTs row2, c, x$, attr END IF IF Shadow THEN attr2 = 8 'Verticle shadow on right side of frame c = col2 + 1 FOR r = row1 + 1 TO row2 QPRINTs r, c, CHR$(SCREEN(r, c)), 8 QPRINTs r, c+1, CHR$(SCREEN(r, c+1)), 8 NEXT IF ConsRows = 25 THEN EndBuffer 'Have to end buffer before a "color" statement 'Horizontal shadow underneath frame leng = col2 - col1 + 1 LOCATE row2 + 1, col1 + 2 COLOR 8, 0, leng 'Another Horizontal method ' CALL ChangeAttribute (row2+1, col1+2, col2-col1+1, attr2) ELSE IF ConsRows = 25 THEN EndBuffer 'Have to end buffer before a "color" statement END IF END SUB SUB DoubleRoutine IF NOT Errorx THEN ppF! = FindPP! WhoAtPos = OUTFIELDWHOAT (ppF!) wag = WHOATGUY (WhoAtPos) IF DelFac THEN x! = RND IF WhoAtPos = 8 THEN i = RND(1, 3) ELSEIF WhoAtPos = 7 THEN IF x! < .33 THEN i = 1 ELSEIF x! < .67 THEN i = 3 ELSE i = 4 END IF ELSE '9 IF x! < .33 THEN i = 1 ELSEIF x! < .67 THEN i = 2 ELSE i = 4 END IF END IF t$ = LTRIM$(STR$(i)) t$ = PADZEROS$(t$, 2) CALL Msg ("11", "0", "1", t$, 0, it, man2, team2) 'long drive IF t$ <> "04" THEN m = wag: n = id ELSE m = ib: n = it CALL Msg ("11", "0", "2", t$, m, n, man2, team2) '* going back IF t$ = "01" THEN m = wag: n = id ELSE m = ib: n = it CALL Msg ("11", "0", "3", t$, m, n, man2, team2) '* around 1st END IF END IF IF DelFac THEN IF SoundOn THEN CALL WavRegularHit END IF 'Advance runners (Default) ii = 2 'bases to advance runner on 1st jj = 2 'bases to advance runner on 2nd ThrowOutChance1 = 0 Gamble = 0 IF HitAndRun THEN ii = 3: GOTO DoubleTOCheck IF ir1 THEN 'Safe% 1st-Home ' 'Sp 0/1out 2out ' ' 1 54 68 ' 2 58 72 ' 3 62 76 ' 4 66 80 ' 5 70 84 ' 6 74 88 ' 7 78 92 ' 8 82 96 ' 9 86 98 IF iout = 2 THEN i = 14 ELSE i = 0 n = 4 * DataSpeed(ir1, it) + 52 + i '4.6 IF WhoAtPos = 7 THEN i = -4 IF WhoAtPos = 8 THEN i = 0 IF WhoAtPos = 9 THEN i = -4 n = n + i n = n + (9 - FRND(15)) '+/- 8 IF n > 98 THEN n = 98 IF amgr(it) = 0 AND AutoCoach = 0 THEN CALL PostAnnouncer (TRUE) ANx = 0 SLEEP 2000 x$ = " Score runner from 1st? [y/N] (" + LFORMAT$(n, "##") + "%)" CALL PopMsg(10+rowO, 22+colO, x$, errattr, 0, kc) IF UCASE$(CHR$(kc)) = "Y" THEN ii = 3 ThrowOutChance1 = 100 - n END IF ELSE 'AutoCoach IF iout = 0 THEN SucLim = 85 '92 IF iout = 1 THEN SucLim = 72 '76 IF iout = 2 THEN SucLim = 60 '70 IF iout = 2 THEN RunsBehind = itruns(id) - itruns(it) IF ir3 <> 0 AND ir2 <> 0 THEN a = 3 ELSEIF ir3 <> 0 OR ir2 <> 0 THEN a = 2 ELSE a = 1 END IF IF RunsBehind = a OR RunsBehind = (a - 1) THEN SucLim = 50 END IF END IF IF n >= SucLim THEN ii = 3 ThrowOutChance1 = 100 - n IF SucLim = 50 AND n < 80 THEN Gamble = TRUE END IF END IF END IF END IF DoubleTOCheck: IF DelFac THEN IF ir3 > 0 THEN CALL AnnScoring(ir3) IF ir2 > 0 THEN CALL AnnScoring(ir2) IF Gamble THEN xS$ = "They'll try to score " + LASTNAME$(DataName(ir1, it)) + "..." CALL AddToAnnouncer (it, xS$) END IF END IF IF ir1 THEN CALL ThrowOutCheck (ii, jj, ThrowOutChance1, 0, 0, 0) CALL Advanc(ii, jj, 1) IF DelFac THEN IF NOT Errorx THEN CALL Msg ("11", "0", "4", t$, ib, it, man2, team2) 'double for * END IF IF ref2 THEN INCR iout 'Anybody get thrown out? ir2 = ib mpp(ib) = ip IF Errorx THEN mpp(ib) = -mpp(ib) EXIT SUB END IF CALL CreditHit INCR m2b(ref, it) IF UCASE$(DataHand(ip, id)) = "L" THEN INCR m2bLHP(ref, it) ELSE INCR m2bRHP(ref, it) END IF INCR mp2b(ip, id) Result$ = "2B" IF ref2 THEN EXIT SUB 'Outfielder Error? CALL Outfield (WhoAtPos) 'Gamble to stretch double into a triple? IF OutFErr = FALSE THEN IF iout < 2 AND amgr(it) = 0 AND AutoCoach = 0 THEN IF ir2 = ib AND ir3 = 0 THEN 'criteria to gamble RunsBehind = itruns(id) - itruns(it) IF inn > (RegInns - 4) AND (RunsBehind = 1 OR RunsBehind = 0) THEN CALL PostAnnouncer (TRUE) ANx = 0 SLEEP 1500 r = 10+rowO c = 23+colO n = 5 * DataSpeed(ir2, it) + 30 x$ = " Stretch hit to a triple? [y/N] (" + LFORMAT$(n, "##") + "%)" CALL PopMsg(r, c, x$, errattr, 0, kc) IF UCASE$(CHR$(kc)) = "Y" THEN IF DelFac THEN CALL Msg ("31", "0", "0", "10", ir2, it, man2, team2) 'He's going to try for third!" IF DelFac THEN CALL Msg ("31", "0", "0", "06", ir2, it, man2, team2) ' He slides... IF RND < (n / 100) THEN 'Made it! 'Take back his "2b" credits DECR m2b(ref, it) IF UCASE$(DataHand(ip, id)) = "L" THEN DECR m2bLHP(ref, it) ELSE DECR m2bRHP(ref, it) END IF DECR mp2b(ip, id) 'Credit for triple instead INCR m3b(ref, it) IF UCASE$(DataHand(ip, id)) = "L" THEN INCR m3bLHP(ref, it) ELSE INCR m3bRHP(ref, it) END IF INCR mp3b(ip, id) Result$ = "3B" ir3 = ib ir2 = 0 IF DelFac THEN CALL Msg ("15", "0", "0", "09", ir3, it, man2, team2) 'Safe IF DelFac THEN CALL Msg ("31", "0", "0", "11", ir3, it, man2, team2) 'Gamble pays off! ELSE 'Didn't make it INCR mpo(ip, id) IF DelFac THEN CALL Msg ("14", "0", "0", "03", ir1, it, man2, team2) 'OUT! The gamble failed. ref2 = DataRef(ir2, it) 'Result2$ = "X-@3rd" INCR Assists(DataRef(WHOATGUY(WhoAtPos), id), id, WhoAtPos) m = 5 'who took throw? INCR PutOuts(DataRef(WHOATGUY(m), id), id, m) Result2$ = LTRIM$(STR$(WhoAtPos)) + "-" + LTRIM$(STR$(m)) Code2$ = "3" ir2 = 0 INCR iout END IF END IF END IF END IF END IF END IF END SUB SUB DoubleSwitch (DidIt, inplayer, outplayer) STATIC 'I am the defense's manager 'I have just brought in a relief pitcher 'Do I want to double-switch? DidIt = FALSE IF dh THEN EXIT SUB 'Find my pitcher's batting slot on offense ps = 0 DO INCR ps IF ps > 9 THEN x$ = "ERROR(DoubleSwitch): No Pitcher Found in Lineup" x$ = x$ + "|" + DataFil(id) CALL ErrorBox (x$) END IF LOOP UNTIL DataPos(ps, id) = 1 psOrg = ps 'Who is due up when we bat? DueUp = ibp(id) + 1 IF DueUp = 10 THEN DueUp = 1 'Is my reliever scheduled to bat among the first three batters next inning? PitcherBatsNextInning = FALSE p = DueUp FOR i = 0 TO 2 IF p = psOrg THEN PitcherBatsNextInning = TRUE: EXIT FOR INCR p IF p > 9 THEN p = 1 NEXT IF NOT PitcherBatsNextInning THEN EXIT SUB 'Find previous three batting slots PRIOR to the guy due up REDIM Player(3) p = DueUp - 1 FOR i = 1 TO 3 IF p < 1 THEN p = 9 Player(i) = p DECR p NEXT 'For each of these three players, compute OPS and compare to bench 'players who can play his position SmallestDiff! = 999. L1 = 0 FOR pp = 1 TO 3 p = Player(pp) PlayerOPS! = CalcOPS!(p, id) PlayerPos = DataPos(p, id) 'Get list of n unused players on bench who can play "PlayerPos" on defense 'Build DefList(n) GOSUB BuildList FOR i = 1 TO n b = DefList(i) SubOPS! = CalcOPS!(b, id) 'Randomize this so we don't pick the same guy every time x! = (6 - FRND(11)) / 50 ' -.1 to +.1 SubOPS! = SubOPS! + x! Diff! = PlayerOPS! - SubOPS! IF Diff! < SmallestDiff! THEN SmallestDiff! = Diff! L1 = p 'Guy in lineup now L2 = b 'Guy on bench OPOS = PlayerPos END IF NEXT NEXT 'If for some reason we didn't find anyone - get out IF L1 = 0 THEN EXIT SUB 'Swap Bench player into slot L1 x$ = "[SUB]" + FLASTNAME$(L2, id) + "(" + RTRIM$(Pos(OPOS)) _ + ") for " + FLASTNAME$(L1, id) CALL AddToScoreCrd (0, 0, "X", x$) CALL Switch(L1, L2, id) 'Mark bench spot L2 as used iused(L2, id) = TRUE 'Put new guy in right defensive position DataPos(L1, id) = OPOS 'Swap Pitcher into slot L1 - player into slot psOrg CALL Switch(L1, psOrg, id) 'Remove new pitcher from the slot he was in before we swapped 'in the RefByBO list. I.E. Remove DataRef(L1, id) from slot psOrg LL = LEN(RefByBO(psOrg, id)) IF LL > 2 THEN RefByBO(psOrg, id) = LEFT$(RefByBO(psOrg, id), LL-2) ELSE RefByBO(psOrg, id) = nulls$ END IF CALL AddToRefByBO (psOrg, id, DataRef(psOrg, id)) 'Player in slot psOrg CALL AddToRefByBO (L1, id, DataRef(L1, id)) 'Pitcher in slot L1 x$ = "[DBL-SW]" + FLASTNAME$(psOrg, id) + " bats #" + LTRIM$(STR$(psOrg)) CALL AddToScoreCrd (0, 0, "X", x$) x$ = " " + FLASTNAME$(L1, id) + " bats #" + LTRIM$(STR$(L1)) CALL AddToScoreCrd (0, 0, "X", x$) DidIt = TRUE inplayer = psOrg outplayer = L2 EXIT SUB BuildList: REDIM DefList(20) n = 0 k = PlayerPos FOR j = LastPiAd(id) + 1 TO MAXPLAYERS IF iused(j, id) = 0 AND DataName(j, id) > "!" THEN 'Can the sub guy (j) play position (k)? OK = FALSE 'Are we playing "strict" or "loose"? IF DataPosi(j, id, 1) > 0 THEN 'Strict IF FoundPosition (k, j, id) THEN OK = TRUE END IF ELSE subdefPos = DataPos(j, id) SELECT CASE k CASE 2 IF subdefPos = 2 THEN OK = TRUE CASE 3 IF subdefPos = 3 OR subdefPos = 5 THEN OK = TRUE CASE 4 IF subdefPos = 4 OR subdefPos = 6 THEN OK = TRUE CASE 5 IF subdefPos = 5 OR subdefPos = 6 THEN OK = TRUE CASE 6 IF subdefPos = 6 THEN OK = TRUE CASE 7, 8, 9 IF subdefPos = 7 OR subdefPos = 8 OR subdefPos = 9 THEN OK = TRUE END SELECT END IF 'Is the candidate's name identical to current or used pitcher? FOR i = 1 TO np(id) IF DataName(j, id) = DataName(iyp(i,id), id) THEN OK = FALSE NEXT IF OK THEN IF n < 20 THEN INCR n DefList(n) = j END IF END IF END IF NEXT RETURN END SUB SUB DumpList (List1() AS List1Type, ItemsInList, OutDevice$, ExtendIt) 'Dump a typed string array to Printer or File IF OutDevice$ < "!" THEN EXIT SUB IF LEFT$(OutDevice$, 3) = "LPT" THEN OPEN "~LIST.TMP" FOR OUTPUT AS #20 ELSE IF ExtendIt THEN OPEN OutDevice$ FOR APPEND AS #20 ELSE OPEN OutDevice$ FOR OUTPUT AS #20 END IF END IF PRINT #20, " " PRINT #20, DATE$; " "; TIME$; PRINT #20, " #"; SimGameCtr + 1; PRINT #20, STRING$(41, "-"); IF LEN(SCHDate$) THEN PRINT #20, " "; SCHDate$ ELSE PRINT #20, STRING$(10, "-"); " " END IF FOR i = 1 TO ItemsInList xS$ = RTRIM$(List1(i).ListItem) IF LEFT$(xS$, 1) = "~" THEN PRINT #20, MID$(xS$, 2) ELSE PRINT #20, xS$ END IF NEXT CLOSE #20 IF LEFT$(OutDevice$, 3) <> "LPT" THEN EXIT SUB 'Print Selected CALL PopMsg(13+rowO, 30+colO, "Launching WORDPAD.", errattr, 1, kc2) 'Launch WordPad SHELL WordPadSpec$ + " ~LIST.TMP" END SUB SUB EditRA(myfile$) 'TYPE BoxType ' row1 as long ' col1 as long ' row2 as long ' col2 as long 'END TYPE DIM ParentFrame AS BoxType DIM ChildFrame AS BoxType DIM Flit$(63) DIM Flitrow(63) AS LONG DIM Flitcol(63) AS LONG DIM Frow(63) AS LONG DIM Fcol(63) AS LONG DIM Fed$(63) DIM Flen(63) AS LONG DIM FPos(63) AS LONG myfile$ = RTRIM$(myfile$) FileNum = FREEFILE OPEN myfile$ FOR BINARY AS FileNum L& = LOF(FileNum) CLOSE FileNum IF L& = 0 THEN KILL file$ IF (L& MOD 430 = 0) OR (L& = 0) THEN RecLen = 430 Flds = 62 'Parent Frame: ParentFrame.row1 = 5 ParentFrame.col1 = 4 ParentFrame.row2 = 21 ParentFrame.col2 = 76 'Child Frame: ChildFrame.row1 = 4 ChildFrame.col1 = 20 ChildFrame.row2 = 22 ChildFrame.col2 = 57 ELSE RecLen = 210 Flds = 30 'Parent Frame: ParentFrame.row1 = 5 ParentFrame.col1 = 2 ParentFrame.row2 = 21 ParentFrame.col2 = 76 'Child Frame: ChildFrame.row1 = 4 ChildFrame.col1 = 20 ChildFrame.row2 = 18 ChildFrame.col2 = 57 END IF c = 1 FOR i = 1 TO Flds Flit$(i) = READ$(c) Flitrow(i) = VAL(READ$(c+1)) Flitcol(i) = VAL(READ$(c+2)) Frow(i) = VAL(READ$(c+3)) Fcol(i) = VAL(READ$(c+4)) Fed$(i) = READ$(c+5) Flen(i) = VAL(READ$(c+6)) FPos(i) = VAL(READ$(c+7)) c = c + 8 NEXT DATA "Date:", 05, 22, 05, 28, " X", 08, 03 DATA "Options:", 06, 43, 00, 00, " ", 00, 00 DATA "", 00, 00, 07, 22, " X", 08, 11 DATA "AT", 07, 31, 00, 00, " ", 00, 00 DATA "", 00, 00, 07, 34, " X", 08, 19 DATA "", 00, 00, 07, 43, " X", 12, 27 DATA "", 00, 00, 08, 22, " X", 08, 39 DATA "AT", 08, 31, 00, 00, " ", 00, 00 DATA "", 00, 00, 08, 34, " X", 08, 47 DATA "", 00, 00, 08, 43, " X", 12, 55 DATA "", 00, 00, 09, 22, " X", 08, 67 DATA "AT", 09, 31, 00, 00, " ", 00, 00 DATA "", 00, 00, 09, 34, " X", 08, 75 DATA "", 00, 00, 09, 43, " X", 12, 83 DATA "", 00, 00, 10, 22, " X", 08, 95 DATA "AT", 10, 31, 00, 00, " ", 00, 00 DATA "", 00, 00, 10, 34, " X", 08, 103 DATA "", 00, 00, 10, 43, " X", 12, 111 DATA "", 00, 00, 11, 22, " X", 08, 123 DATA "AT", 11, 31, 00, 00, " ", 00, 00 DATA "", 00, 00, 11, 34, " X", 08, 131 DATA "", 00, 00, 11, 43, " X", 12, 139 DATA "", 00, 00, 12, 22, " X", 08, 151 DATA "AT", 12, 31, 00, 00, " ", 00, 00 DATA "", 00, 00, 12, 34, " X", 08, 159 DATA "", 00, 00, 12, 43, " X", 12, 167 DATA "", 00, 00, 13, 22, " X", 08, 179 DATA "AT", 13, 31, 00, 00, " ", 00, 00 DATA "", 00, 00, 13, 34, " X", 08, 187 DATA "", 00, 00, 13, 43, " X", 12, 195 DATA "", 00, 00, 14, 22, " X", 08, 207 DATA "AT", 14, 31, 00, 00, " ", 00, 00 DATA "", 00, 00, 14, 34, " X", 08, 215 DATA "", 00, 00, 14, 43, " X", 12, 223 DATA "", 00, 00, 15, 22, " X", 08, 235 DATA "AT", 15, 31, 00, 00, " ", 00, 00 DATA "", 00, 00, 15, 34, " X", 08, 243 DATA "", 00, 00, 15, 43, " X", 12, 251 DATA "", 00, 00, 16, 22, " X", 08, 263 DATA "AT", 16, 31, 00, 00, " ", 00, 00 DATA "", 00, 00, 16, 34, " X", 08, 271 DATA "", 00, 00, 16, 43, " X", 12, 279 DATA "", 00, 00, 17, 22, " X", 08, 291 DATA "AT", 17, 31, 00, 00, " ", 00, 00 DATA "", 00, 00, 17, 34, " X", 08, 299 DATA "", 00, 00, 17, 43, " X", 12, 307 DATA "", 00, 00, 18, 22, " X", 08, 319 DATA "AT", 18, 31, 00, 00, " ", 00, 00 DATA "", 00, 00, 18, 34, " X", 08, 327 DATA "", 00, 00, 18, 43, " X", 12, 335 DATA "", 00, 00, 19, 22, " X", 08, 347 DATA "AT", 19, 31, 00, 00, " ", 00, 00 DATA "", 00, 00, 19, 34, " X", 08, 355 DATA "", 00, 00, 19, 43, " X", 12, 363 DATA "", 00, 00, 20, 22, " X", 08, 375 DATA "AT", 20, 31, 00, 00, " ", 00, 00 DATA "", 00, 00, 20, 34, " X", 08, 383 DATA "", 00, 00, 20, 43, " X", 12, 391 DATA "", 00, 00, 21, 22, " X", 08, 403 DATA "AT", 21, 31, 00, 00, " ", 00, 00 DATA "", 00, 00, 21, 34, " X", 08, 411 DATA "", 00, 00, 21, 43, " X", 12, 419 TopLiteral$ = "Highlight Record F2=Sort By Date" BotLiteral$ = "Hit <" + CHR$(196) + CHR$(217) + ", Ins, or ESC" FrameStyle = 0 CALL Drawfrm(ParentFrame.row1, ParentFrame.col1, ParentFrame.row2, ParentFrame.col2, defattr, TopLiteral$, BotLiteral$, 1, FrameStyle, 2) IF FrameStyle = 0 THEN x1$ = "µ": x2$ = "¶" ELSE x1$ = "Ñ": x2$ = "ã" r = 11 QPRINTs r, ParentFrame.col2, x1$, defattr QPRINTs r + 1, ParentFrame.col2, UpPtr$, defattr QPRINTs r + 2, ParentFrame.col2, DnPtr$, defattr QPRINTs r + 3, ParentFrame.col2, x2$, defattr CALL DisplayKeysAndEdit(ParentFrame, ChildFrame, myfile$, RecLen, Flds, Fpos(), Flen(), Flitrow(), Flitcol(), Flit$(), Frow(), Fcol(), Fed$()) END SUB SUB EditRandomRec (myfile$, RecNum, RecLen, Flds, Fpos(), Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol()) KeyEsc = 27 KeyRet = 13 KeyRtab = 9 KeyLtab = -15 KeyUp = -72 KeyDown = -80 KeyLeft = -75 KeyRight = -77 KeyBack = 8 KeyIns = -82 KeyDel = -83 KeyPgUp = -73 KeyPgDn = -81 COLOR dimfor, dimbac FileNum = FREEFILE OPEN myfile$ FOR BINARY AS FileNum NumberOfRecords = LOF(FileNum) \ RecLen IF RecNum <> 0 THEN ' LOCATE 24, 2: PRINT "Records: "; NumberOfRecords; ' Don't read past EoF! IF RecNum > NumberOfRecords THEN BEEP GOTO EditRandRecExit END IF SEEK #FileNum, (RecNum - 1) * RecLen + 1 GET$ #FileNum, RecLen, RecBuff$ ' Print field literals and field values FOR i = 1 TO Flds IF Flitrow(i) > 0 AND Flitrow(i) < 26 AND Flitcol(i) > 0 AND Flitcol(i) < 80 THEN QPRINTs Flitrow(i), Flitcol(i), Flit$(i), dimattr END IF IF Frow(i) > 0 AND Frow(i) < 26 AND Fcol(i) > 0 AND Fcol(i) < 80 THEN QPRINTs Frow(i), Fcol(i), MID$(RecBuff$, Fpos(i), Flen(i)), revattr END IF NEXT ELSE ' add a new record ' Add blank record at EoF RecBuff$ = STRING$(RecLen, " ") NumberOfRecords = NumberOfRecords + 1 RecNum = NumberOfRecords SEEK #FileNum, (RecNum - 1) * RecLen + 1 PUT$ #FileNum, RecBuff$ ' Print field literals and blanks FOR i = 1 TO Flds IF Flitrow(i) > 0 AND Flitrow(i) < 26 AND Flitcol(i) > 0 AND Flitcol(i) < 80 THEN QPRINTs Flitrow(i), Flitcol(i), Flit$(i), dimattr END IF IF Frow(i) > 0 AND Frow(i) < 26 AND Fcol(i) > 0 AND Fcol(i) < 80 THEN QPRINTs Frow(i), Fcol(i), STRING$(Flen(i), " "), revattr END IF NEXT END IF FldPtr = 0 GOSUB AdvanceField LOCATE Frow(FldPtr), Fcol(FldPtr) CsrSize = 100 CURSOR ON, CsrSize InsToggle = FALSE ' problem: you can never escape if you put your cursor in ' a field that edits to an error unless you fix it. ' only way to fix: remove esc from making changes to record ' so now you must hit return in order to take the update COLOR revfor, revbac DO ScanInput: msx = 0 msy = 0 KyS$ = WAITKEY$ s% = INSHIFT IF LEN(KyS$) = 1 THEN kc = ASC(KyS$) ELSEIF LEN(KyS$) = 2 THEN kc = -ASC(RIGHT$(KyS$, 1)) ELSEIF LEN(KyS$) = 4 THEN IF ASC(KyS$, 3) = 2 THEN DoubleClick = TRUE ELSE DoubleClick = FALSE END IF msx = MOUSEX msy = MOUSEY IF CHR$(SCREEN(msy, msx)) = CloseButton$ THEN 'ESC button (but accept input) kc = KeyEsc END IF IF CHR$(SCREEN(msy, msx)) = "—" THEN 'Abort button kc = KeyEsc EXIT DO END IF 'Did we click in an input field? FOR i = 1 TO Flds IF Frow(i) > 0 AND Fcol(i) > 0 AND Flen(i) > 0 THEN IF msx >= Fcol(i) AND msx < Fcol(i) + Flen(i) AND msy = Frow(i) THEN 'Process field at old location CALL ReadFromScreen (Frow(FldPtr), Fcol(FldPtr), Flen(FldPtr), field$, Fed$(FldPtr), valid$) IF valid$ = "Y" THEN MID$(RecBuff$, Fpos(FldPtr), Flen(FldPtr)) = field$ FldPtr = i LOCATE msy, msx 'FRow(FldPtr), Fcol(FldPtr) ELSE LOCATE msy, msx 'FRow(FldPtr), Fcol(FldPtr) BEEP END IF GOTO ScanInput END IF END IF NEXT END IF IF kc = 9 AND s% = 48 THEN kc = KeyLtab 'Support Shift-Tab KyS$ = UCASE$(KyS$) Recycle: IF kc = KeyEsc OR kc = KeyRet OR kc = KeyRtab OR kc = KeyDown OR (CURSORX = Fcol(FldPtr) + Flen(FldPtr)) THEN ' Escape or C/R or right tab or cursor reached end-of-field CALL ReadFromScreen (Frow(FldPtr), Fcol(FldPtr), Flen(FldPtr), field$, Fed$(FldPtr), valid$) IF valid$ = "Y" THEN MID$(RecBuff$, Fpos(FldPtr), Flen(FldPtr)) = field$ GOSUB AdvanceField LOCATE Frow(FldPtr), Fcol(FldPtr) ELSE LOCATE Frow(FldPtr), Fcol(FldPtr) BEEP END IF ELSEIF kc = KeyLtab OR kc = KeyUp OR CURSORX < Fcol(FldPtr) THEN ' Left tab or cursor up or cursor left beyond limit CALL ReadFromScreen (Frow(FldPtr), Fcol(FldPtr), Flen(FldPtr), field$, Fed$(FltPtr), valid$) IF valid$ = "Y" THEN MID$(RecBuff$, Fpos(FldPtr), Flen(FldPtr)) = field$ GOSUB RetreatField LOCATE Frow(FldPtr), Fcol(FldPtr) ELSE LOCATE Frow(FldPtr), Fcol(FldPtr) BEEP END IF ELSEIF kc = KeyDel THEN CALL ReadFromScreen (Frow(FldPtr), Fcol(FldPtr), Flen(FldPtr), field$, Fed$(FltPtr), valid$) screencol = CURSORX fieldcol = CURSORX - Fcol(FldPtr) + 1 IF fieldcol > 0 AND fieldcol <= Flen(FldPtr) THEN field$ = MID$(field$, 1, fieldcol - 1) + MID$(field$, fieldcol + 1) + " " LOCATE Frow(FldPtr), Fcol(FldPtr) PRINT field$; LOCATE Frow(FldPtr), screencol END IF ' Insert (Toggle) ELSEIF kc = KeyIns THEN InsToggle = NOT (InsToggle) IF InsToggle THEN CURSOR ON, CsrSize \ 2 ELSE CURSOR ON, CsrSize END IF ELSEIF kc = KeyLeft AND CURSORX > 1 THEN LOCATE Frow(FldPtr), CURSORX - 1 screencol = CURSORX IF screencol < Fcol(FldPtr) THEN GOTO Recycle ELSEIF kc = KeyRight AND CURSORX < 80 THEN LOCATE Frow(FldPtr), CURSORX + 1 screencol = CURSORX IF screencol = Fcol(FldPtr) + Flen(FldPtr) THEN GOTO Recycle ELSEIF kc = KeyBack THEN PRINT " "; LOCATE Frow(FldPtr), CURSORX - 2 screencol = CURSORX IF screencol < Fcol(FldPtr) THEN GOTO Recycle ELSEIF kc < 32 OR kc > 127 THEN BEEP ELSE IF InsToggle THEN ' Insert within field CALL ReadFromScreen (Frow(FldPtr), Fcol(FldPtr), Flen(FldPtr), field$, Fed$(FltPtr), Valid$) screencol = CURSORX fieldcol = CURSORX - Fcol(FldPtr) + 1 field$ = MID$(field$, 1, fieldcol - 1) + KyS$ + MID$(field$, fieldcol) CURSOR OFF LOCATE Frow(FldPtr), Fcol(FldPtr) PRINT LEFT$(field$, Flen(FldPtr)); CURSOR ON LOCATE , screencol + 1 ELSE PRINT KyS$; END IF screencol = CURSORX IF screencol = Fcol(FldPtr) + Flen(FldPtr) THEN GOTO Recycle END IF LOOP UNTIL kc = KeyEsc AND valid$ = "Y" SEEK #FileNum, (RecNum - 1) * RecLen + 1 PUT$ #FileNum, RecBuff$ EditRandRecExit: COLOR deffor, defbac CLOSE FileNum GOTO EditRandomRecExit AdvanceField: ' C/R will drop down to new line IsDone = FALSE LastPtr = FldPtr DO UNTIL IsDone INCR FldPtr IF FldPtr > Flds THEN FldPtr = 1 IF Frow(FldPtr) <> 0 AND Fcol(FldPtr) <> 0 THEN IF kc = KeyRet THEN IF Frow(FldPtr) <> Frow(LastPtr) THEN IsDone = TRUE ELSE IsDone = TRUE END IF END IF LOOP RETURN RetreatField: IsDone = FALSE DO UNTIL IsDone DECR FldPtr IF FldPtr < 1 THEN FldPtr = Flds IF Frow(FldPtr) <> 0 AND Fcol(FldPtr) <> 0 THEN IsDone = TRUE LOOP RETURN EditRandomRecExit: CURSOR OFF END SUB SUB Engine STATIC 'Set hitter adjustment factor - lefties/righties/switch-hitters: 'Assumes 3/4 of pitchers are right-handed 'Assumes 2/3 of batters are right-handed adjF! = 1.0 IF DataPlat(ib, it) > "!" AND DataHand(ib, it) <> UCASE$(DataHand(ip,id)) THEN adjF! = adjF! + 0 ELSEIF DataHand(ib, it) = "R" THEN IF UCASE$(DataHand(ip, id)) = "R" THEN adjF! = adjF! - .015 ELSE adjF! = adjF! + .045 END IF ELSEIF DataHand(ib, it) = "L" THEN IF UCASE$(DataHand(ip, id)) = "R" THEN adjF! = adjF! + .030 ELSE adjF! = adjF! - .090 END IF END IF 'Park Effects IF CmdParkEffects$ = "Y" THEN adjF! = adjF! + ParkBatAdj(it) adjF! = adjF! + ParkPitAdj(id) END IF 'Additional Home Field Advantage IF CmdHomeFieldAdv$ <> "N" THEN IF it = 2 THEN 'Home is up adjF! = adjF! + .030 ELSE 'Visitors bat more often so magnitude should be 94.4% of Home's 9/8.5 ' .03 * .9444 = .0283 adjF! = adjF! - .0285 END IF END IF 'Infield-In or Back IF Tight THEN adjF! = adjF! + .3000 'Adds ~80 points ELSE '1/50 measured tight/non-tight : .3 / 50 = .006 : 1 - .006 = .994 adjF! = adjF! - .0065 'Take ~1.6 points off avg END IF 'Pitcher Fatigue IF NewStyle(id) AND DataGames(ip, id) AND DataAB(ip, id) THEN 'New Style has "Games" and "Starts" FatFac! = nPitch(id) / ExpectedPitchCount(ip, id) adjF! = adjF! + (0.175 * FatFac! - 0.0965) ELSE 'Old style IF np(id) = 1 THEN adjF! = adjF! + (.005 * mpo(ip, id) - .05) 'Starters ELSE adjF! = adjF! + (.010 * mpo(ip, id) - .05) 'Relievers END IF END IF 'Extra Pitcher Fatigue if rest days are being overridden by human manager IF SimDaysOff(ip, id) < 0 THEN adjF! = adjF! + (SimDaysOff(ip, id) / -3) END IF 'Focusing HPowerAdjF! = 1! IF CmdFocus$ = "Y" AND CmdStat$ > "!" THEN HFadjF! = 0 OVadjF! = 0 PFadjF! = 0 xF! = RND IF xF! < .75 THEN Foc = 1 ELSE Foc = 0 'Hitter "focusing" IF Foc = 1 AND SimAtBats > 0 THEN IF SimAtBats > (DataAB(ib, it) \ 2) THEN IF SimTotHits > 0 AND DataHits(ib, it) > 0 THEN x1! = DataHits(ib, it) / DataAB(ib, it) 'DAT avg x2! = SimTotHits / SimAtBats 'SIM avg HFadjF! = (x1! - x2!) / x1! END IF IF SimTotHRs > 0 AND DataHR(ib, it) > 0 THEN x1! = DataHR(ib, it) / DataAB(ib, it) 'DAT avg x2! = SimTotHRs / SimAtBats 'SIM avg HPowerAdjF! = HPowerAdjF! + (x1! - x2!) / x1! END IF END IF END IF 'Hitter overuse performance penalty 'Season .DAT AB is under 350 and over-used by 50% or more IF BatterOveruse THEN IF SimAtBats THEN IF DataAB(ib, it) < 350 THEN IF SimAtBats > DataAB(ib, it) * 1.5! THEN OVadjF! = DataAB(ib, it) / SimAtBats OVadjF! = OVadjF! - 1! 'This will always be negative (hurts hitter) OVadjF! = OVadjF! * 0.5 'Magnif. factor IF OVadjF! > .25 THEN OVadjF! = .25 IF OVadjF! < -.25 THEN OVadjF! = -.25 END IF END IF END IF END IF 'Pitcher "focusing" IF Foc = 0 AND SimInn(ip, id) > (DataAB(ip, id) / 2) THEN IF SimHitsAlw(ip, id) THEN x1! = DataHits(ip, id) / DataAB(ip, id) 'DAT Hits/inn x2! = SimHitsAlw(ip, id) / SimInn(ip, id) 'SIM Hits/inn PFadjF! = (x1! - x2!) / x1! END IF END IF adjF! = adjF! + HFadjF! + OVadjF! + PFadjF! 'Add in the focusing adj END IF 'Normal adjF! is near 1.0 IF adjF! > 2 THEN adjF! = 2.0 IF adjF! < 0 THEN adjF! = 0 'Estimate Batters Faced by Pitcher bfF! = BattersFacedByPit!(DataAB(ip,id), DataHits(ip,id), DataBB(ip,id), DataSO(ip,id)) 'Estimate Plate Appearances by Batter 'See if there's special Hit-by-Pitch code 'Set HitByPitch "Percentage" hbF! = (DataBB(ip, id) / bfF!) * 0.08 xS$ = DataHP(ib, it) IF xS$ >= "A" THEN code = 74 - ASC(UCASE$(xS$)) 'A=9 B=8 C=7 D=6 E=5 F=4 G=3 H=2 I=1 IF code < 1 THEN code = 1 code = code - 4 'A=5 B=4 C=3 D=2 E=1 F=0 G=-1 H=-2 I=-3 IF code < 1 THEN xF! = 1 / (ABS(code) + 2) ELSE xF! = code 'A=5 B=4 C=3 D=2 E=1 F=1/2 G=1/3 H=1/4 hbF! = hbF! * xF! END IF 'Set Sacrifice Fly percentage '(ignore Sac-bunts: they aren't handled by "engine") 'Old-timer seasons (especially) with lots of speed play small-ball and sacrifice a lot 'So we need to crank up the plate appearances by increasing "sacF!" IF TeamSpeed(it) > 3.5 THEN sacF! = .015 * TeamSpeed(it) - .049 ELSE sacF! = .0035 END IF 'Batter's plate appearances: AB + BB + HPB + SACF paF! = DataAB(ib, it) + DataBB(ib, it) + (hbF! + sacF!) * DataAB(ib, it) IF paF! = 0 THEN paF! = 1 IF bfF! = 0 THEN bfF! = 1 phitsF! = DataHits(ip, id) / bfF! 'Home Runs h4bF! = (DataHR(ib, it) / paF!) * HPowerAdjF! 'Allow anyone remote possibility of hitting HR IF h4bF! < .001 THEN h4bF! = .001 IF pHRind(id) THEN p4bF! = DataHR(ip, id) / bfF! ELSE p4bF! = phitsF! * phit4bF(id) END IF 'Don't allow a pitcher to be invincible on HR's either! IF p4bF! < .0015 THEN p4bF! = .0015 'Triples h3bF! = Data3B(ib, it) / paF! 'Allow anyone remote possibility of hitting 3B IF h3bF! < .001 THEN h3bF! = .001 p3bF! = phitsF! * phit3bF(id) 'Doubles h2bF! = Data2B(ib, it) / paF! p2bF! = phitsF! * phit2bF(id) 'Singles hsinglF! = DataHits(ib, it) - (Data2B(ib, it) + Data3B(ib, it) + DataHR(ib, it)) h1bF! = hsinglF! / paF! p1bF! = phitsF! - (p2bF! + p3bF! + p4bF!) 'Walks hwalkF! = DataBB(ib, it) / paF! pwalkF! = DataBB(ip, id) / bfF! 'League-Rating factor IF LeagueRating(it) <> LeagueRating(id) THEN f! = LeagueRating(it) / LeagueRating(id) f! = 1 + (f! - 1) / 2 'Reduce the effect by 1/2 h1bF! = f! * h1bF! h2bF! = f! * h2bF! h3bF! = f! * h3bF! h4bF! = f! * h4bF! hwalkF! = f! * hwalkF! p1bF! = f! * p1bF! p2bF! = f! * p2bF! p3bF! = f! * p3bF! p4bF! = f! * p4bF! pwalkF! = f! * pwalkF! END IF 'Batter Normalization: 'Alter batting stats of the out-of-era team to that of the 'current era league IF (CmdEra$ = "H" AND it = 1) OR _ (CmdEra$ = "V" AND it = 2) OR _ (CmdEra$ = "B") OR _ p4baseNorm! > 0 THEN 'indicates a norm year/league forced '------------------------------------------------------------- ' Linear-Weights method '------------------------------------------------------------- NtvPlus! = LW!(LgTotHits(it), LgTot2B(it), LgTot3B(it), LgTotHR(it), LgTotBB(it)) NtvMinus! = LgTotInns(it) * 3 'Outs LWRN! = NtvPlus! / NtvMinus! IF p4baseNorm! > 0 THEN t = 3 ELSE t = id TgtPlus! = LW!(LgTotHits(t), LgTot2B(t), LgTot3B(t), LgTotHR(t), LgTotBB(t)) TgtMinus! = LgTotInns(t) * 3 'Outs LWRT! = TgtPlus! / TgtMinus! a! = LWRT! / LWRN! PA_org! = DataAB(ib,it) + DataBB(ib,it) PA_new! = a! * (DataHits(ib,it) + DataBB(ib,it)) + (DataAB(ib,it) - DataHits(ib,it)) f! = a! * (PA_org! / PA_new!) h1bF! = f! * h1bF! h2bF! = f! * h2bF! h3bF! = f! * h3bF! h4bF! = f! * h4bF! hwalkF! = f! * hwalkF! END IF 'Pitcher Normalization 'Alter pitching stats of out-of-era team to that of the 'current-era league IF (CmdEra$ = "H" AND it = 2) OR _ (CmdEra$ = "V" AND it = 1) OR _ (CmdEra$ = "B") OR _ p4baseNorm! > 0 THEN 'indicates a norm year/league forced '------------------------------------------------------------- ' Linear-Weights method '------------------------------------------------------------- NtvPlus! = LW!(LgTotHits(id), LgTot2B(id), LgTot3B(id), LgTotHR(id), LgTotBB(id)) NtvMinus! = LgTotInns(id) * 3 'Outs LWRN! = NtvPlus! / NtvMinus! IF p4baseNorm! > 0 THEN t = 3 ELSE t = it TgtPlus! = LW!(LgTotHits(t), LgTot2B(t), LgTot3B(t), LgTotHR(t), LgTotBB(t)) TgtMinus! = LgTotInns(t) * 3 'Outs LWRT! = TgtPlus! / TgtMinus! a! = LWRT! / LWRN! BF_org! = BattersFacedByPit!(DataAB(ip,id), DataHits(ip,id), DataBB(ip,id), DataSO(ip,id)) BF_new! = BattersFacedByPit!(DataAB(ip,id), DataHits(ip,id)*a!, DataBB(ip,id)*a!, DataSO(ip,id)) f! = a! * (BF_org! / BF_new!) p1bF! = f! * p1bF! p2bF! = f! * p2bF! p3bF! = f! * p3bF! p4bF! = f! * p4bF! pwalkF! = f! * pwalkF! END IF LastHR = FALSE IF SCx THEN IF LEFT$(SCRec(SCx).SCResult, 2) = "HR" THEN LastHR = TRUE END IF x1! = hwalkF! * pwalkF! / pwbaseF(id) walkF! = x1! / ( x1! + ( (1! - hwalkF!)*(1! - pwalkF!)/(1! - pwbaseF(id)) ) ) 'Walk adjustments IF PAround OR LastHR THEN IF ABS(1 - hbF! - walkF!) < .001 THEN walkF! = .3 IF PAround THEN nF! = 3.0 HF! = DataHits(ib, it) / paF! IF HF! < 0.1 THEN HF! = 0.1 mF! = (walkF! + HF! - (nF! * walkF!)) / HF! 'factor to decrease hits by 'this formula takes all additional walks from out of hits, so 'batting averages suffer ELSEIF LastHR THEN nF! = 1.2 mF! = (1 - hbF! - nF! * walkF!) / (1 - hbF! - walkF!) END IF IF mF! < 0.1 THEN mF! = 0.1 walkF! = walkF! * nF! 'adjust walks up h1bF! = h1bF! * mF! 'hits down -- hitter's or pitcher's -- makes no diff h2bF! = h2bF! * mF! h3bF! = h3bF! * mF! h4bF! = h4bF! * mF! IF LastHR THEN IF ABS(1 - walkF! - hbF!) < .001 THEN mF! = 1 ELSE mF! = (1 - walkF! - .03) / (1 - walkF! - hbF!) END IF hbF! = .03 'new assignment for hbF! Enter this value above. h1bF! = h1bF! * mF! 'hits down h2bF! = h2bF! * mF! h3bF! = h3bF! * mF! h4bF! = h4bF! * mF! END IF INCR zzzWalkAdj ELSE 'Nothing special going on, so reduce chance of walk to balance out the times we raise the chance. 'We also need to reduce because of intentional walks walkF! = walkF! * 0.985 INCR zzzNoWalkAdj END IF 'Adjust basic event probabilities by the "log5" method x1! = h1bF! * p1bF! / p1baseF(id) y1! = x1! / (x1! + ( (1 - h1bF!) * (1 - p1bF!) / (1 - p1baseF(id)) ) ) x2! = h2bF! * p2bF! / p2baseF(id) y2! = x2! / (x2! + ( (1 - h2bF!) * (1 - p2bF!) / (1 - p2baseF(id)) ) ) x3! = h3bF! * p3bF! / p3baseF(id) y3! = x3! / (x3! + ( (1 - h3bF!) * (1 - p3bF!) / (1 - p3baseF(id)) ) ) x4! = h4bF! * p4bF! / p4baseF(id) y4! = x4! / (x4! + ( (1 - h4bF!) * (1 - p4bF!) / (1 - p4baseF(id)) ) ) bp1F! = walkF! bp2F! = bp1F! + hbF! 'Now apply the adjustments and build the "break points" 'phit1bF(*) = % of hits that are singles in this league 'phit2bF(*) = % of hits that are doubles in this league 'phit3bF(*) = % of hits that are triples in this league 'phit4bF(*) = % of hits that are home runs in this league cadjF! = 1! - adjF! bp3F! = bp2F! + y1! * (1! - phit1bF(id) * cadjF!) bp4F! = bp3F! + y2! * (1! - phit2bF(id) * cadjF!) bp5F! = bp4F! + y3! * (1! - phit3bF(id) * cadjF!) bp6F! = bp5F! + y4! * (1! - phit4bF(id) * cadjF!) HitType = 0 xF! = RND 'Throw the dice! n = FRND(10) 'Pitch count distrubition IF fr7=401 THEN 'force a single HitType = 1 CALL SingleRoutine nPitch(id) = nPitch(id) + P33(n) fr7 = 0 EXIT SUB END IF IF HitAndRun THEN IF xF! < bp6F! THEN 'A base hit or walk CALL Msg ("25", "0", "0", "02", 0, it, 0, 0) 'Hit-and-run END IF END IF IF xF! > bp6F! THEN CALL OutOrError ' Out or Error IF Result$ = "K" THEN nPitch(id) = nPitch(id) + P48(n) ELSE nPitch(id) = nPitch(id) + P32(n) END IF ELSEIF xF! > bp5F! THEN IF DataSpeed(ib, it) > 5 AND RND < .05 THEN InsideThePark = TRUE IF inn >= RegInns AND it = 2 THEN RunnersOn = NUMBERON IF itruns(2) + RunnersOn > itruns(1) THEN InsideThePark = FALSE END IF HitType = 4 CALL HomeRunRoutine ' Home Run InsideThePark = FALSE nPitch(id) = nPitch(id) + P33(n) ELSEIF xF! > bp4F! THEN HitType = 3 CALL TripleRoutine ' Triple nPitch(id) = nPitch(id) + P33(n) ELSEIF xF! > bp3F! THEN HitType = 2 CALL DoubleRoutine ' Double nPitch(id) = nPitch(id) + P33(n) ELSEIF xF! > bp2F! THEN HitType = 1 CALL SingleRoutine ' Single nPitch(id) = nPitch(id) + P33(n) ELSEIF xF! > bp1F! THEN CALL HBRoutine ' HB nPitch(id) = nPitch(id) + P33(n) ELSE CALL WalkRoutine ' Walk nPitch(id) = nPitch(id) + P52(n) END IF END SUB SUB ErrorBox (ErrorMsg$) 'Use "|" as delimiter n = PARSECOUNT(ErrorMsg$, "|") TopRow = 9 TotL = LEN(ErrorMsg$) Lines = TotL / 60 + 1 IF n > 1 THEN Lines = MAX(Lines, n) BotRow = TopRow + Lines + 3 CALL GetScreen(Scr1$, TopRow+RowO, 8+ColO, BotRow+RowO, 71+ColO) IF Gfx THEN CALL GraphHole (32, TopRow+RowO, 8+ColO, BotRow+RowO, 71+ColO) CALL DrawFrm(TopRow+RowO, 8+ColO, BotRow+RowO, 71+ColO, defattr, nulls$, nulls$, 0, 0, 0) r = TopRow + 2 + RowO FOR i = 1 TO n x$ = PARSE$(ErrorMsg$, "|", i) QPRINTs r, 10+ColO, x$, defattr INCR r NEXT PauseIt CALL PutScreen(Scr1$, TopRow+RowO, 8+ColO, BotRow+RowO, 71+ColO) IF Gfx THEN CALL EliminateHole(32) GfxRefresh 0 END IF END SUB SUB ExitPickForDAT (List1() AS List1Type, Pick, RetKey) 'We don't allow no negative Retkey's in here! IF RetKey > 0 THEN yS$ = UCASE$(CHR$(RetKey)) ELSE yS$ = " " 'V view 'E edit 'N new 'A auxilliary IF yS$ = "V" OR yS$ = "E" OR yS$ = "N" OR yS$ = "A" THEN QPush IF yS$ = "V" THEN CALL ListFile(CurrentDir$ + RTRIM$(List1(Pick).ListItem)) ELSE IF yS$ = "N" THEN CALL Drawfrm(10+rowO, 10+colO, 14+rowO, 71+colO, defattr, nulls$, nulls$, 0, 0, 0) LOCATE 12+rowO, 12+colO: PRINT "Enter filename of NEW File: "; default$ = CmdPath$ + " " zS$ = MYINPUT$(FALSE, KeyEscape, CustomEscKey, KeyAccept, kc, revfor, revbac, 12+rowO, 40+colO, 20, "XR", 0, 0, default$, msx, msy) 'No mouse support here i = INSTR(zS$, ".") IF i THEN zS$ = LEFT$(zS$, i - 1) ELSE zS$ = RTRIM$(zS$) IF MenuOpt$ = "E" THEN zS$ = zS$ + ".SER" ELSE zS$ = zS$ + ".DAT" END IF zS$ = EditorSpec$ + zS$ ELSE IF yS$ = "E" THEN zS$ = EditorSpec$ + CurrentDir$ + RTRIM$(List1(Pick).ListItem) END IF IF yS$ = "A" THEN zS$ = AuxSpec$ + CurrentDir$ + RTRIM$(List1(Pick).ListItem) END IF END IF LOCATE 10+rowO, 10+colO ShowWindState& = 1 ConsoleShell zS$, ShowWindState& 'this will launch in separate window END IF COLOR deffor, defbac QPop RetKey = -99 END IF END SUB SUB ExitPickForSCH (List1() AS List1Type, Pick, RetKey) 'We don't allow no negative RetKey's here IF RetKey > 0 THEN yS$ = UCASE$(CHR$(RetKey)) ELSE yS$ = " " IF yS$ = "E" OR yS$ = "N" THEN QPush IF yS$ = "N" THEN CALL Drawfrm(10+rowO, 10+colO, 14+rowO, 71+colO, defattr, nulls$, nulls$, 0, 0, 0) LOCATE 12+rowO, 12+colO: PRINT "Enter filename of NEW Schedule File: "; default$ = CmdPath$ + " " zS$ = MYINPUT$(FALSE, KeyEscape, CustomEscKey, KeyAccept, kc, revfor, revbac, 12+rowO, 49+colO, 20, "XR", 0, 0, default$, msx, msy) 'no mouse support i = INSTR(zS$, ".") IF i THEN zS$ = LEFT$(zS$, i - 1) ELSE zS$ = RTRIM$(zS$) zS$ = zS$ + ".SCH" ELSE LOCATE 12+rowO, 40+colO zS$ = CurrentDir$ + RTRIM$(List1(Pick).ListItem) END IF CALL EditRA(zS$) COLOR deffor, defbac QPop IF yS$ <> "N" THEN RetKey = -99 'force another loop END IF END SUB SUB ExitPickForSTS (List1() AS List1Type, Pick, RetKey) IF RetKey = -83 THEN CALL Drawfrm(6+rowO, 25+colO, 8+rowO, 43+colO, defattr, nulls$, nulls$, 0, 0, 0) QPRINTs 7+rowO, 26+colO, " Are you sure? ", defattr LOCATE 7+rowO, 41+colO IF YESorNO$(7, 0, deffor, defbac, "N") = "N" THEN EXIT SUB zS$ = List1(Pick).ListItem i = INSTR(zS$, ".") zS$ = LEFT$(zS$, i - 1) xS$ = zS$ + ".STS" CALL KillIt (xS$) xS$ = zS$ + ".STB" CALL KillIt (xS$) xS$ = zS$ + ".STF" CALL KillIt (xS$) xS$ = zS$ + ".STP" CALL KillIt (xS$) xS$ = zS$ + ".STH" CALL KillIt (xS$) xS$ = zS$ + ".RES" CALL KillIt (xS$) xS$ = zS$ + ".ROT" CALL KillIt (xS$) xS$ = zS$ + ".STD" CALL KillIt (xS$) END IF END SUB SUB Fireworks (Bursts) kount = 1 wattr = CalcAttr(7, 0) DO UNTIL kount > Bursts DOWNx = RND * (ConsRows - 7) + 4 across = RND * (ConsCols - 15) + 8 QPRINTs DOWNx, across, "*", wattr '1=blue 2=green 3=skyb 4=red 5=purple 6=brown 7=white 8=grey '9=b.blu 10=b.grn 11=b.skyb 12=b.red 13=b.purple r = 2 '2 circles = RND * 5 + 5 '5 - 8 IF mon$ = "C" THEN k = RND * 6 + 10 ELSE k = 7 FOR c = 1 TO circles i = 0 IF c = 1 THEN xS$ = CHR$(250) cl = k ELSEIF c < 4 THEN xS$ = CHR$(249) cl = k ELSEIF c < circles THEN xS$ = CHR$(42) cl = k - 1 ELSE xS$ = CHR$(15) cl = k - 2 END IF attr = CALCATTR(cl, 0) FOR y = -.707 * r TO .707 * r STEP 1 x1 = SQR(r * r - y * y) x2 = -x1 lc1 = x1 + across lc2 = x2 + across lr = y * .4 + DOWNx INCR i IF lc1 > 0 AND lc1 < ConsCols AND lr > 0 AND lr < ConsRows THEN QPRINTs lr, lc1, xS$, attr END IF IF lc2 > 0 AND lc2 < ConsCols AND lr > 0 AND lr < ConsRows THEN QPRINTs lr, lc2, xS$, attr END IF NEXT FOR x = -.707 * r TO .707 * r STEP 1 y1 = SQR(r * r - x * x) * .4 y2 = -y1 lr1 = y1 + DOWNx lr2 = y2 + DOWNx lc = x + across INCR i IF lr1 > 0 AND lr1 < ConsRows AND lc > 0 AND lc < ConsCols THEN QPRINTs lr1, lc, xS$, attr END IF IF lr2 > 0 AND lr2 < ConsRows AND lc > 0 AND lc < ConsCols THEN QPRINTs lr2, lc, xS$, attr END IF NEXT INCR r NEXT c IF RND < .3 THEN SLEEP 50 INCR kount LOOP END SUB SUB Flash (p, blink) CALL DefCoordinates (p, r, c, ObsD, ObsY, ObsH, ObsTz, ObsTy) IF r > 0 AND c > 0 THEN k = WHOATGUY(p) leng = LEN(LASTNAME$(DataName(k, id))) IF p = 1 THEN leng = leng + 3 IF p = 5 THEN IF leng > 9 THEN leng = 9 'How many times to flash? IF DelFac > 2 THEN times = 8 ELSEIF DelFac = 2 THEN times = 6 ELSE times = 4 END IF CALL FlashField (r, c, leng, times, 140, 0) END IF END SUB SUB FlashField (r, c, leng, times, interval, forceattr) 'What is the current attribute at r, c? IF forceattr = 0 THEN currattr = SCREENATTR(r, c) ELSE currattr = forceattr END IF 'Compute the background of the current attribute: b = currattr \ 16 'Make tempattr with the foreground the same as the background of the current attribute tempattr = CALCATTR(b, b) attr = tempattr FOR i = 1 TO times 'must be even number to work correctly CALL ChangeAttribute(r, c, leng, attr) SLEEP interval IF attr = currattr THEN attr = tempattr ELSEIF attr = tempattr THEN attr = currattr END IF NEXT END SUB SUB Fly (DPsw, Dramatic, deep, t$) STATIC ON ERROR GOTO ERRORTRAP 'NOTE!: If no out is recorded, decrement mpo(ip, id) before returning wag = WHOATGUY(WhoAtPos) IF DPsw AND iout < 2 THEN 'Double play possibility - pending baserunners/outs i = 0 xF! = RND IF WhoAtPos = 3 OR WhoAtPos = 4 THEN IF ir2 THEN i = ir2 ir2 = 0 '3-6 & 4-6 j = 6 ELSEIF ir1 THEN i = ir1 ir1 = 0 '3-3 & 4-3 j = 3 END IF ELSEIF WhoAtPos = 5 THEN IF ir2 THEN i = ir2 '5-4 test ir2 = 0 j = 4 ELSEIF ir1 AND (xF! < .5 OR HitandRun = TRUE) THEN '5-3 test i = ir1 ir1 = 0 j = 3 END IF ELSEIF WhoAtPos = 6 THEN IF ir2 THEN i = ir2 '6-4 ir2 = 0 j = 4 ELSEIF ir1 AND (xF! < .5 OR HitandRun = TRUE) THEN '6-3 test i = ir1 ir1 = 0 j = 3 END IF END IF IF i THEN IF DelFac THEN CALL Msg ("29", "0", "0", "07", i, it, man2, team2) 'doubled-off CALL Msg ("40", "0", "0", "00", i, it, man2, team2) 'holy cow END IF iout = iout + 2 INCR mpo(ip, id) INCR dp(id) IF WhoAtPos = 3 AND j = 3 THEN Result$ = Result$ + "UN DP!" ELSE Result$ = Result$ + "-" + LTRIM$(STR$(j)) + " DP!" END IF INCR Assists(DataRef(wag, id), id, WhoAtPos) INCR PutOuts(DataRef(WHOATGUY(j), id), id, j) GOTO FLY999 END IF END IF 'No double play - reg:s=3 dram:s=4,5 wag = WHOATGUY(WhoAtPos) IF WhoAtPos < 7 THEN Dramatic = FALSE IF DelFac THEN IF Dramatic THEN CALL Msg ("07", "0", "4", t$, wag, id, man2, team2) CALL Msg ("07", "0", "5", t$, wag, id, man2, team2) ELSE CALL Msg ("06", "0", "3", "00", wag, id, man2, team2) END IF END IF 'Record the out INCR iout IF iout > 2 THEN GOTO FLY999 'Consider possible sacrifice fly shallow = FALSE '** RUNNER ON 3RD ** IF ir3 <> 0 THEN IF WhoAtPos < 7 THEN GOTO FLYHold IF DelFac THEN IF INSTR(Announcer(1).mgs, "eep") OR INSTR(Announcer(1).mgs, "ong") THEN GOSUB FLYScore GOTO FLY999 END IF IF INSTR(Announcer(1).mgs, "loop") OR INSTR(Announcer(1).mgs, "litt") OR _ INSTR(Announcer(1).mgs, "dump") OR INSTR(Announcer(1).mgs, "slap") OR _ INSTR(Announcer(1).mgs, "shot") THEN shallow = TRUE END IF ELSE IF deep THEN GOSUB FLYScore GOTO FLY999 END IF END IF ' if fr7 = 201 then shallow = TRUE IF amgr(it) = 0 AND AutoCoach = 0 THEN CALL PostAnnouncer (TRUE) ANx = 0 SLEEP 2000 IF shallow THEN i = 60: j = 3 ELSE i = 18: j = 2 x! = 1 - ( (i - (DataSpeed(ir3, it) * j)) / 100) x! = x! * 100 IF x! > 99.9 THEN x! = 99.9 x$ = " Tag-up at 3rd? [y/N] (" + FFORMAT$(x!, "##.#") + "%)" CALL PopMsg(10+rowO, 25+colO, x$, errattr, 0, kc) IF UCASE$(CHR$(kc)) <> "Y" THEN GOTO FLYHold END IF ELSE IF DataSpeed(ir3, it) + iout + FRND(10) < 8 THEN ' OUT:0 OUT:1 OUT:2 'sp adv% adv% adv% ' 1 40 50 60 ' 2 50 60 70 ' 3 60 70 80 ' 4 70 80 90 ' 5 80 90 100 ' 6 90 100 100 ' 7 100 100 100 ' 8 100 100 100 ' 9 100 100 100 GOTO FLYHold END IF END IF 'Normal Out chance: = (18 - (DataSpeed(ir3, it) * 2)) / 100 'Shallow Out chance: = (60 - (DataSpeed(ir3, it) * 3)) / 100 'sp out% shallow-out% ' 1 16 57 ' 2 14 54 ' 3 12 51 ' 4 10 48 ' 5 8 45 ' 6 6 42 ' 7 4 39 ' 8 2 36 ' 9 0 33 IF shallow THEN i = 60: j = 3 ELSE i = 18: j = 2 IF RND < (i - (DataSpeed(ir3, it) * j)) / 100 THEN GOSUB FLYNailed ELSE GOSUB FLYScore END IF ELSEIF ir2 <> 0 AND HitAndRun = FALSE THEN 'and nobody on third IF WhoAtPos > 7 THEN 'AND iout < 2 (no sense trying to adv w/2 out) i = 0 IF DelFac THEN IF INSTR(Announcer(1).mgs, "deep") OR _ INSTR(Announcer(1).mgs, "long") THEN i = 1 ELSE i = 2 END IF ELSE IF deep THEN i = 1 END IF END IF IF i > 0 THEN '1 or 2 IF amgr(it) = 0 AND AutoCoach = 0 THEN CALL PostAnnouncer (TRUE) ANx = 0 SLEEP 2000 ' x! = 1 - (.10*i - ( (DataSpeed(ir2, it) - 1) / 150)) x! = 1 - (.10*i + .15 - ( (DataSpeed(ir2, it) - 1) / 40)) '65%-85% for i=2 75%-95% for i=1 x! = x! * 100 IF x! > 99.9 THEN x! = 99.9 x$ = " Tag-up at 2nd? [y/N] (" + FFORMAT$(x!, "##.#") + "%)" CALL PopMsg(10+rowO, 25+colO, x$, errattr, 0, kc) IF UCASE$(CHR$(kc)) <> "Y" THEN GOTO FLY999 END IF ELSE IF (DataSpeed(ir2, it) + FRND(10) < 10) OR iout = 2 THEN 'sp adv attempt% ' 1 20% ' 2 30 ' 3 40 ' 4 50 ' 5 60 ' 6 70 ' 7 80 ' 8 90 ' 9 100 GOTO FLY999 'No advance attempt END IF END IF 'Attempt to advance IF DelFac THEN CALL Msg ("17", "0", "0", "02", ir2, it, man2, team2) 'tags @2nd 'Safe Chance: 1 - (.10*i + .15 - ( (DataSpeed(ir2, it) - 1) / 40)) IF RND < .10*i + .15 - ( (DataSpeed(ir2, it) - 1) / 40) THEN 'Thrown OUT at third! IF DelFac THEN CALL Msg ("14", "0", "0", "03", ir2, it, man2, team2) 'OUT @3 ' Result2$ = "X@3rd DP" INCR Assists(DataRef(wag, id), id, WhoAtPos) INCR PutOuts(DataRef(WHOATGUY(5), id), id, 5) ref2 = DataRef(ir2, it) Result2$ = LTRIM$(STR$(WhoAtPos)) + "-5 DP" Code2$ = "3" IF DelFac THEN CALL Msg ("29", "0", "0", "14", wag, id, man2, team2) 'nice throw ir2 = 0 INCR iout INCR mpo(ip, id) INCR dp(id) ELSE 'Advance Runner to third IF DelFac THEN AddToAnnouncer it, "He's in there safely..." ir3 = ir2 ir2 = 0 END IF END IF END IF ELSEIF HitAndRun THEN IF DelFac THEN i = 0 IF ir2 THEN i = ir2 ELSEIF ir1 THEN i = ir1 END IF IF i THEN CALL Msg ("31", "0", "0", "08", i, it, man2, team2) 'hurries back... END IF END IF END IF GOTO FLY999 FLYHold: '** HOLDS AT THIRD ** IF DelFac THEN CALL Msg ("16", "0", "0", "03", ir3, it, man2, team2) GOTO FLY999 FLYScore: '** Scores on SACRIFICE FLY ** IF DelFac THEN CALL Msg ("17", "0", "0", "03", ir3, it, man2, team2) CALL Msg ("17", "0", "0", "04", ir3, it, man2, team2) END IF RunAnnounced = TRUE IF ir2 > 0 AND ( WhoAtPos = 8 OR WhoAtPos = 9 ) AND RND < .4 THEN 'Advance both 2nd and 3rd IF DelFac THEN AddToAnnouncer it, "Runner on 2nd also advances..." CALL Advanc(0, 1, 1) ELSE 'Only advance 3rd CALL Advanc(0, 0, 1) END IF INCR mSacF(ref, it) mab(ref, it) = mab(ref, it) - 1 IF UCASE$(DataHand(ip, id)) = "L" THEN mabLHP(ref, it) = mabLHP(ref, it) - 1 ELSE mabRHP(ref, it) = mabRHP(ref, it) - 1 END IF Result$ = Result$ + " SACF" RETURN FLYNailed: '** THROWN OUT AT THE PLATE ** IF DelFac THEN CALL Msg ("17", "0", "0", "03", ir3, it, man2, team2) ref2 = DataRef(ir3, it) 'Result2$ = "X-@Home DP" Result2$ = LTRIM$(STR$(WhoAtPos)) + "-2 DP" Code2$ = "4" INCR Assists(DataRef(wag, id), id, WhoAtPos) INCR PutOuts(DataRef(WHOATGUY(2), id), id, 2) IF DelFac THEN CALL Msg ("14", "0", "0", "04", ir3, it, man2, team2) ir3 = 0 INCR iout INCR mpo(ip, id) INCR dp(id) CALL Advanc(1, 1, 0) 'Runner on 2nd always advances RETURN ErrorTrap: LOCATE 10, 30 PRINT "FLY_Error"; ERRCLEAR x$ = WAITKEY$ FLY999: END SUB SUB GetNextPitchers ' CmdVP$ or CmdHP$ will replace the method that's already in the table ' for the affected team. The method will remain in effect until the end ' of the simulation or until another CmdVP$ or CmdHP$ is issued. ' 'TYPE TotPctType ' PctOfTot AS SINGLE ' Slot AS INTEGER 'END TYPE REGISTER i AS INTEGER, j AS INTEGER, k AS INTEGER REDIM BrkTbl(25) AS TotPctType FOR tm = 1 TO 2 IF tm = 1 THEN IF CmdVP$ <> nulls$ THEN Method$ = CmdVP$ Repl$ = "Y" ELSE Method$ = CmdSP$ ' IF CmdVRot$ <> nulls$ THEN Method$ = CmdVRot$ Repl$ = "N" END IF CmdVP$ = nulls$ END IF IF tm = 2 THEN IF CmdHP$ <> nulls$ THEN Method$ = CmdHP$ Repl$ = "Y" ELSE Method$ = CmdSP$ ' IF CmdHRot$ <> nulls$ THEN Method$ = CmdHRot$ Repl$ = "N" END IF CmdHP$ = nulls$ END IF CALL AutoPitcher (tm, Method$, Repl$, N) 'Returns N OriginalSelection = N IF (tm = 1 AND CmdVSpot$ = "Y") OR _ (tm = 2 AND CmdHSpot$ = "Y") OR _ CmdSpot$ = "Y" THEN 'Possible Spot Starter ELSE 'No Spot Starter, we are done GOTO AssignPitcher END IF 'Possible Spot Starter NumInRot = VAL(MID$(Method$, 2, 1)) 'Calculate Total Starts by ALL Pitchers TotStarts = 0 FOR i = 10 TO LastPiAd(tm) TotStarts = TotStarts + DataGbyP(i, tm, 1) NEXT IF TotStarts = 0 THEN GOTO AssignPitcher xF! = RND IF xF! > ((DataGbyP(N, tm, 1) / TotStarts) * NumInRot) OR _ (DaysOffRule = TRUE AND GetDaysOff(N, tm) > 0) THEN 'Pitcher is tired 'Pick a Spot Starter r = ROTATIONLIST (DataFil(tm)) 'Find Rot record for this team IF r = 0 THEN x$ = "AutoPit: Spot Starter Error: " + DataFil(tm) CALL ErrorBox (x$) END IF 'Calculate starts by pitchers NOT in current rotation SpotStarts = 0 j = 0 FOR i = 10 TO LastPiAd(tm) 'Is "i" already in rotation? SkipIt = FALSE FOR k = 1 TO 5 IF RotRec(r).RotList(k) = i THEN SkipIt = TRUE NEXT IF NOT SkipIt THEN SpotStarts = SpotStarts + DataGbyP(i, tm, 1) INCR j BrkTbl(j).PctOfTot = 0 BrkTbl(j).Slot = 0 END IF NEXT IF SpotStarts = 0 THEN GOTO AssignPitcher 'For these pitchers not in the current rotation: 'Calculate percentage of "spot starts" they had j = 0 FOR i = 10 TO LastPiAd(tm) 'Is "i" already in rotation? SkipIt = FALSE FOR k = 1 TO 5 IF RotRec(r).RotList(k) = i THEN SkipIt = TRUE NEXT IF NOT SkipIt THEN INCR j BrkTbl(j).PctOfTot = DataGbyP(i, tm, 1) / SpotStarts BrkTbl(j).Slot = i END IF NEXT try = 1 TryAgain: xF! = RND N = 0 BaseP! = 0 FOR i = 1 TO j IF xF! < BaseP! + BrkTbl(i).PctOfTot THEN N = BrkTbl(i).Slot EXIT FOR END IF BaseP! = BaseP! + BrkTbl(i).PctOfTot NEXT IF N = 0 THEN N = BrkTbl(j).Slot 'Try to avoid tired pitchers IF CmdStat$ > "!" AND DaysOffRule = TRUE THEN IF GetDaysOff(N, tm) THEN 'He's tired! Try again. INCR try IF try < 5 THEN GOTO TryAgain N = OriginalSelection END IF END IF END IF AssignPitcher: ipa(tm) = N np(tm) = 1 iyp(1, tm) = N CALL AssignFatigue (tm) NEXT 'tm ERASE BrkTbl END SUB SUB GetScreen (ScrSave$, row1, col1, row2, col2) ScrSave$ = SPACE$((row2 - row1 + 1) * (col2 - col1 + 1) * 2) i = 1 FOR r = row1 TO row2 FOR c = col1 TO col2 b = SCREEN(r, c) a = SCREENATTR(r, c) x$ = CHR$(b) + CHR$(a) MID$(ScrSave$, i, 2) = x$ i = i + 2 NEXT NEXT END SUB SUB GetScrollKey (kc, RowOff, ColOff) Donex = FALSE DO KyS$ = WAITKEY$ KyS$ = UCASE$(KyS$) IF LEN(KyS$) = 1 THEN kc = ASC(KyS$) ELSEIF LEN(KyS$) = 2 THEN kc = -ASC(RIGHT$(KyS$, 1)) ELSEIF LEN(KyS$) = 4 THEN msx = MOUSEX msy = MOUSEY CALL FlashField (msy, msx, 1, 2, 100, 0) kc = SCREEN(msy, msx) IF kc = 118 THEN ' "v" KyS$ = CHR$(kc) ELSE KyS$ = UCASE$(CHR$(kc)) kc = ASC(KyS$) END IF SELECT CASE KyS$ CASE UpPtr$ kc = -72 CASE DnPtr$ kc = -80 CASE LPtr$ kc = -75 CASE RPtr$ kc = -77 CASE CloseButton$ 'normal escape kc = 27 CASE ELSE END SELECT END IF ' ESC IF kc = 27 THEN Donex = TRUE ' S (swap)/ M (more lineups) special cases ELSEIF kc = 83 OR kc = 77 THEN Donex = TRUE ' Left-arrow ELSEIF kc = -75 AND ColOff > 0 THEN ColOff = ColOff - 10 Donex = TRUE ' Right-arrow ELSEIF kc = -77 AND ColOff < 72 THEN ColOff = ColOff + 10 Donex = TRUE ' Up arrow ELSEIF kc = -72 AND RowOff > 0 THEN DECR RowOff Donex = TRUE ' Down arrow ELSEIF kc = -80 AND RowOff < 30 THEN 'sets maximum number "downs" (was 10) INCR RowOff Donex = TRUE 'Emergency escape for testing ' ELSEIF kc = 32 THEN ' Donex = TRUE ELSE MyBeep END IF LOOP UNTIL Donex LOCATE 1, 1 'EXIT SUB 'FlashMouse: 'CALL FlashField (msy, msx, 1, 2, 100, 0) 'RETURN END SUB SUB Gone i = 12 COLOR i, 0 IF Gfx THEN CALL GraphHole(30, 6+rowO, 16+colO, 22+rowO, 65+colO) CALL Drawfrm(6+rowO, 16+colO, 22+rowO, 65+colO, linattr, nulls$, nulls$, 0, 0, 0) redattr = CALCATTR(i, 0) r = 7 + rowO c = 17 + colO tempattr = CALCATTR(0, 0) 'black on black attr = redattr FOR n = 1 TO 5 'should be odd number QPRINTs r, c, " ", attr QPRINTs r+1, c, " áêêá áêêá êêêêêêêê êêêê êêêê êêêêêêê ", attr QPRINTs r+2, c, " êê êê êê êê êê êššê êê êê á ", attr QPRINTs r+3, c, " êêêêêêêê êê êê êê êê êê êêêêê ", attr QPRINTs r+4, c, " êê êê êê êê êê êê êê š ", attr QPRINTs r+5, c, " šêêš šêêš êêêêêêêê šêêš šêêš êêêêêêê ", attr QPRINTs r+6, c, " ", attr QPRINTs r+7, c, " êêêêêêêê áêêá áêêá êêêš êê ", attr QPRINTs r+8, c, " êê êê êê êê êê êê êê ", attr QPRINTs r+9, c, " êêêêêêêê êê êê êê ê êê ", attr QPRINTs r+10,c, " êê ê êê êê êê êê êê ", attr QPRINTs r+11,c, " êê êê êêêêêêêê êê áêêê ", attr QPRINTs r+12,c, " ", attr QPRINTs r+13,c, " ", attr QPRINTs r+14,c, " ", attr SLEEP 200 IF attr = redattr THEN attr = tempattr ELSEIF attr = tempattr THEN attr = redattr END IF NEXT QPRINTs 20+rowO, 35+colO, "...by " + FULLNAME$(DataName(ib, it)), redattr IF CmdFireworks$ = "Y" THEN SLEEP 2000 CALL Fireworks(6) ELSE SLEEP 3000 END IF IF Gfx THEN CALL EliminateHole(30) CALL UnfreezeAndRefresh END IF COLOR fldfor, fldbac END SUB SUB Ground STATIC ON ERROR GOTO ERRORTRAP 'If an out is not recorded must decrement mpo(ip, id) wag = WHOATGUY(WhoAtPos) Dramatic = (RND < .11) 'Sets of dramatic outs BasesLoaded = (ir1 <> 0 AND ir2 <> 0 AND ir3 <> 0) IF WhoAtPos = 1 OR WhoAtPos = 3 OR WhoAtPos = 5 THEN AtFactor = 0 ELSE AtFactor = 10 END IF 'Close Game AND its getting late AND there's a guy on third DefAhead = itruns(id) - itruns(it) IF (DefAhead < 2 AND DefAhead > -4) AND (DefAhead + RegInns - 3 < inn) AND ir3 <> 0 THEN '01/11/00 GameSituation = TRUE ' Def situation Game Situation '--------------- -------------- ' Up 2 or more never ' Up 1 8th inn + ' Tied 7th inn + ' Down 1 6th inn + ' Down 2 5th inn + ' Down 3 4th inn + ELSE GameSituation = FALSE END IF 'The smaller the number the more likely the runner holds at 3rd. 'Tight (when set) is -1 IF ir3 THEN HoldFactor = AtFactor + DataSpeed(ir3, it) + (Tight * 10) + (iout * 5) + FRND(5) ELSE HoldFactor = 0 END IF p$ = LTRIM$(STR$(WhoAtPos)) t$ = LTRIM$(STR$(RND(1, 4))) t$ = PADZEROS$(t$, 2) IF ir1 THEN GOTO GROnFirst IF (ir2 <> 0 AND ir3 <> 0) OR (ir3 <> 0) THEN GOTO GROnThird '** NOBODY ON BASE -OR- LONE RUNNER on Second ** GOSUB DidFBCatchThrow IF DelFac THEN IF Dramatic THEN IF SoundOn THEN IF t$ = "04" THEN CALL WavSoftGrounder ELSE CALL WavRegularGrounder END IF END IF CALL Msg ("03", p$, "1", t$, wag, id, man2, team2) CALL Msg ("03", p$, "2", t$, wag, id, man2, team2) CALL Msg ("03", p$, "3", t$, wag, id, man2, team2) IF FBDropped THEN CALL Msg ("30", "0", "0", "05", bm1, id, man2, team2) CALL Msg ("30", "0", "0", "09", bm1, id, man2, team2) 'error ELSE CALL Msg ("03", p$, "4", t$, wag, id, man2, team2) END IF ELSE IF SoundOn THEN CALL WavRegularGrounder CALL Msg ("02", p$, "1", "00", wag, id, man2, team2) CALL Msg ("02", p$, "2", "00", wag, id, man2, team2) IF FBDropped THEN CALL Msg ("30", "0", "0", "05", bm1, id, man2, team2) CALL Msg ("30", "0", "0", "09", bm1, id, man2, team2) 'error ELSE CALL Msg ("02", p$, "3", "00", ib, it, man2, team2) END IF END IF END IF IF FBDropped THEN GOTO GR999 INCR iout IF ir2 <> 0 THEN IF WhoAtPos = 3 OR WhoAtPos = 4 THEN CALL Advanc(0, 1, 0) END IF END IF UnAssistedPct! = .67 Result$ = Result$ + "-3" INCR Assists(DataRef(wag, id), id, WhoAtPos) INCR PutOuts(DataRef(WHOATGUY(3), id), id, 3) GOTO GR999 GROnThird: '** RUNNER at 3rd OR (2nd AND 3rd) ' OR (1st AND 3rd OR BASES LOADED, Tight/GameSituation from GROnFirst routine) 'Send regular 1st line IF DelFac THEN IF SoundOn THEN CALL WavRegularGrounder CALL Msg ("02", p$, "1", "00", wag, id, man2, team2) END IF GROnThird2: IF iout = 2 THEN GOSUB DidFBCatchThrow GOTO GRHoldAt3rd END IF 'Try to guess whether guy on third will try to score (less than 2 out) IF HoldFactor < 18 THEN 'hold the runner(s) OLDir3 = ir3 GOSUB DidFBCatchThrow GOTO GRHoldAt3rd ELSEIF Tight THEN 'infield in GOTO GRThrowHomeOut ELSEIF GameSituation THEN 'desperate sit. for def. IF FRND(5) + AtFactor > 12 THEN GOTO GRThrowHomeSafe '60 safe if @4 or @6 ELSE GOTO GRThrowHomeOut END IF ELSE GOSUB DidFBCatchThrow 'defense not concerned GOTO GRIgnoreHomeThrow1st END IF GROnFirst: ' ** RUNNER ON 1ST, 1ST AND 2ND, 1ST AND 3RD, OR BASES LOADED ********* ' if the following situation exists don't even CONSIDER a d.p. because ' a critical run would score even if successful! ' 1st & 3rd with 0 out AND (Tight or GameSituation): IF ir3 <> 0 AND ir2 = 0 AND iout = 0 AND (GameSituation OR Tight) THEN GOTO GROnThird END IF ' Is batter a slow runner? ' The SMALLER dpF!, the GREATER the chance of a double play) ' The BIGGER dpF!, the SMALLER the chance of a double play) ' So, to get more double-plays make the denominator larger ' to get fewer double-plays make the denominator smaller dpF! = (DataSpeed(ib, it) + 5!) / 17 '4.6 + IF dpF! < .375 THEN dpF! = .375 'Reduce chances of DP under following conditions: IF HitAndRun THEN dpF! = 1! 'Infield tight IF Tight THEN dpF! = .96 'Ball hit to first-baseman: IF WhoAtPos = 3 THEN dpF! = dpF! + (1.0 - dpF!) / 2.0 'Ball hit to catcher: IF WhoAtPos = 2 THEN dpF! = .99 'DOUBLE PLAY? c = 0 IF RND > dpF! AND iout < 2 THEN 'Yes - DP t$ = LTRIM$(STR$(RND(1, 3))) 'don't want to do announcer track 4 here t$ = PADZEROS$(t$, 2) IF DelFac THEN IF Dramatic THEN 'Sometimes don't want other tracks also IF RND < .9 THEN IF p$ = "4" AND t$ = "02" THEN IF RND < .5 THEN t$ = "01" ELSE t$ = "03" END IF IF p$ = "6" AND t$ = "01" THEN IF RND < .5 THEN t$ = "02" ELSE t$ = "03" END IF END IF IF SoundOn THEN IF t$ = "04" THEN CALL WavSoftGrounder ELSE CALL WavRegularGrounder END IF END IF CALL Msg ("03", p$, "1", t$, wag, id, man2, team2) CALL Msg ("03", p$, "2", t$, wag, id, man2, team2) ELSE IF SoundOn THEN CALL WavRegularGrounder CALL Msg ("02", p$, "1", "00", wag, id, man2, team2) END IF END IF GOTO GRDoublePlay END IF 'NO DOUBLE PLAY IF Dramatic THEN x! = RND IF x! < .25 THEN 'no "at-em" balls in announcer track t$ = "01" 'left ELSEIF x! < .5 THEN t$ = "02" 'right ELSE t$ = "04" 'slow END IF IF DelFac THEN IF SoundOn THEN IF t$ = "04" THEN CALL WavSoftGrounder ELSE CALL WavRegularGrounder END IF END IF CALL Msg ("03", p$, "1", t$, wag, id, man2, team2) CALL Msg ("03", p$, "2", t$, wag, id, man2, team2) END IF ELSE IF DelFac THEN IF SoundOn THEN CALL WavRegularGrounder CALL Msg ("02", p$, "1", "00", wag, id, man2, team2) END IF END IF 'Special Case: GameSituation OR Tight ForceFailedDP = FALSE IF iout < 2 AND (GameSituation OR Tight) THEN IF BasesLoaded THEN IF iout = 0 THEN IF Tight THEN 'Tight: Always a force out GOTO GRForceAtHome ELSE 'Game Sit: Play at Plate IF FRND(5) + AtFactor > 12 THEN GOTO GRThrowHomeSafe '60 safe if @4 or @6 ELSE GOTO GRForceAtHome END IF END IF END IF IF iout = 1 THEN IF Tight THEN 'Tight: Always a force out GOTO GRForceAtHome ELSE r1F! = RND 'Game Sit: IF AtFactor = 0 THEN 'At 1,3,5 IF r1F! < .95 THEN GOTO GRForceAtHome ELSE ForceFailedDP = TRUE END IF ELSE 'At 4,6 IF r1F! < .78 THEN '.5 GOTO GRForceAtHome ELSEIF r1F! < .82 THEN '.75 GOTO GRThrowHomeSafe ELSE ForceFailedDP = TRUE END IF END IF END IF END IF ELSEIF ir3 THEN '1st & 3rd GOTO GROnThird2 END IF END IF 'GameSituation or Tight w/less than 2 out 'Is There a FORCE AT 2ND or 3RD -OR- Is ONLY PLAY at 1ST? GoSecond = FALSE GoThird = FALSE UnAssisted = FALSE r1F! = RND IF NOT HitAndRun AND NOT Tight THEN IF WhoAtPos < 4 THEN 'at 1, 2 or 3 IF iout < 2 THEN IF r1F! < .4 OR BasesLoaded THEN '1/11/00 = .4 'if we're going to second, we don't want 'the announcer to be describing a "dramatic" 'slow ground ball. So, we'll backtrack and put 'different words in his mouth. GOSUB ChangeAnnouncer GoSecond = TRUE IF WhoAtPos = 2 THEN GoSecond = FALSE END IF END IF ELSE 'at 4, 5 or 6 IF iout < 2 THEN IF r1F! < .7 OR BasesLoaded THEN '1/11/00 = .7 FORCE 70% GOSUB ChangeAnnouncer GoSecond = TRUE IF WhoAtPos = 5 AND ir2 <> 0 AND RND < .2 THEN 'TEST GoSecond = FALSE GoThird = TRUE END IF END IF ELSE IF r1F! < .3 THEN 'with 2 out, sometimes go to 2nd GOSUB ChangeAnnouncer GoSecond = TRUE IF WhoAtPos = 5 AND ir2 <> 0 AND RND < .5 THEN 'TEST GoSecond = FALSE GoThird = TRUE END IF END IF END IF END IF END IF IF GoSecond OR GoThird OR ForceFailedDP THEN 'Go to Second or Third for Force Out 'Decide if it's an unassisted force or not IF GoThird THEN UnAssisted = TRUE ELSE 'Ball must be hit to short or second IF WhoAtPos = 4 THEN IF Dramatic THEN IF t$ = "01" AND RND < .25 THEN UnAssisted = TRUE ELSE IF RND < .15 THEN UnAssisted = TRUE END IF END IF IF WhoAtPos = 6 THEN IF Dramatic THEN IF t$ = "02" AND RND < .25 THEN UnAssisted = TRUE ELSE IF RND < .15 THEN UnAssisted = TRUE END IF END IF END IF IF DelFac THEN IF ForceFailedDP THEN IF GoThird THEN AddToAnnouncer id, "He steps on third..." ELSE IF UnAssisted THEN AddToAnnouncer id, "He steps on 2nd for the force..." ELSE CALL Msg ("08", "0", "1", "00", 0, id, man2, team2) 'over to 2nd END IF END IF ELSEIF Dramatic THEN IF GoThird THEN AddToAnnouncer id, "He races to 3rd - steps on the bag..." ELSE IF UnAssisted THEN AddToAnnouncer id, "He steps on 2nd for the force..." ELSE AddToAnnouncer id, "He fires to second..." END IF END IF ELSE IF iout = 2 THEN IF GoThird THEN AddToAnnouncer id, "He steps on third for the force..." ELSE IF UnAssisted THEN AddToAnnouncer id, "He steps on 2nd for the force..." ELSE AddToAnnouncer id, "He flips to 2nd..." END IF END IF ELSE IF GoThird THEN AddToAnnouncer id, "He steps on third for the force..." ELSE IF UnAssisted THEN AddToAnnouncer id, "He steps on 2nd for one..." ELSE CALL Msg ("08", "0", "1", "00", 0, id, man2, team2) 'over to 2nd...got one there END IF END IF END IF END IF END IF 'Possibility of Dropped Throw by middle infielder 'Middle-man pos is "n" IF UnAssisted THEN tt$ = LTRIM$(STR$(WhoAtPos)) ELSE IF WhoAtPos > 4 THEN tt$ = "4" ELSE tt$ = "6" END IF n = VAL(tt$) nn = WHOATGUY(n) defperF! = DEFPCT!(nn) IF NOT UnAssisted THEN zF! = (1.0 - defperF!) * .8 'Decrease constant for more errors IF RND > (defperF! + zF!) THEN 'Dropped throw at second! INCR iterrs(id) INCR inne i = DataRef(nn, id) INCR GpPos(i, id, n) INCR merr(i, id) INCR SumErrors(n) IF DelFac THEN CALL Msg ("30", "0", "0", "05", nn, id, man2, team2) AddToAnnouncer it, "Everybody's safe!" CALL Msg ("30", "0", "0", "09", nn, id, man2, team2) 'error END IF Errorx = TRUE CALL Advanc(1, 1, 1) Errorx = FALSE ir1 = ib mpp(ib) = ip IF mpp(ir2) > 0 THEN mpp(ir2) = -mpp(ir2) 'Flip to negative to show runner got on via error END IF Result$ = Result$ + "/E-" + tt$ mpo(ip, id) = mpo(ip, id) - 1 'No out recorded anywhere! GOTO GR999 END IF END IF INCR iout 'Got the force out IF ForceFailedDP THEN 'Bases-Loaded situation IF DelFac THEN 'Back to 1st... CALL Msg ("08", "0", "2", "00", 0, id, man2, team2) AddToAnnouncer it, "SAFE!! Not in time! He beat it!" END IF ELSEIF Dramatic THEN IF DelFac THEN AddToAnnouncer id, "OUT on a close play!" ELSE IF iout = 3 THEN IF DelFac THEN AddToAnnouncer it, "Side out!" ELSEIF RND < .5 THEN ' .5 TEST IF DelFac THEN AddToAnnouncer it, "Force out there -- no play at 1st." ELSE 'Back to 1st... IF DelFac THEN CALL Msg ("08", "0", "2", "00", 0, id, man2, team2) 'Possibility of bad relay throw to first after a force out zF! = (1.0 - defperF!) * .6 'Increase constant for fewer errors IF RND > (defperF! + zF!) THEN WildThrow = TRUE IF DelFac THEN IF NOT WildThrow THEN AddToAnnouncer it, "Not in time! He beat it." ELSE AddToAnnouncer id, "Wild throw! Into the dugout!" IF NUMBERON > 1 THEN AddToAnnouncer it, "Everybody gets an extra base!" END IF END IF END IF END IF END IF IF GoThird THEN CALL Advanc(1, 0, 1) 'Force out at 3rd Does this work??? ELSE CALL Advanc(0, 1, 1) 'Force out at 2nd END IF ir1 = ib mpp(ib) = ip IF UnAssisted THEN Result$ = Result$ + "UN F" ELSE Result$ = Result$ + "-" + tt$ + " F" INCR Assists(DataRef(wag, id), id, WhoAtPos) END IF n = VAL(tt$) INCR PutOuts(DataRef(WHOATGUY(n), id), id, n) IF WildThrow THEN INCR iterrs(id) INCR inne INCR innadverr i = DataRef(WHOATGUY(n), id) INCR GpPos(i, id, n) INCR merr(i, id) INCR SumErrors(n) Errorx = TRUE CALL Advanc(1, 1, 1) 'Everybody advances one extra base Errorx = FALSE Result$ = Result$ + "/E-" + tt$ WildThrow = FALSE END IF ELSE 'No Force Out -- Runners Advance INCR iout IF iout < 3 AND DelFac > 0 THEN AddToAnnouncer id, "No play at second..." END IF IF DelFac THEN IF Dramatic THEN CALL Msg ("03", p$, "3", t$, wag, id, man2, team2) '*throw to 1st CALL Msg ("03", p$, "4", t$, ib, it, man2, team2) 'OUT ELSE CALL Msg ("02", p$, "2", "00", wag, id, man2, team2) '* throw to 1st CALL Msg ("02", p$, "3", "00", ib, it, man2, team2) 'OUT END IF END IF CALL Advanc(1, 1, 1) 'advance all runners one base ir1 = 0 UnAssistedPct! = .67 Result$ = Result$ + "-3" INCR Assists(DataRef(wag, id), id, WhoAtPos) INCR PutOuts(DataRef(WHOATGUY(3), id), id, 3) END IF GOTO GR999 GRHoldAt3rd: 'HOLDS AT THIRD - batter out (probably) IF DelFac THEN IF iout <> 2 THEN 'problem: FBDropped routine has already advanced ir3 CALL Msg ("16", "0", "0", "03", OLDir3, it, man2, team2) 'holds at 3rd END IF CALL Msg ("02", p$, "2", "00", wag, id, man2, team2) 'here's the throw IF FBDropped THEN CALL Msg ("30", "0", "0", "05", bm1, id, man2, team2) CALL Msg ("30", "0", "0", "09", bm1, id, man2, team2) 'error ELSE CALL Msg ("02", p$, "3", "00", ib, it, man2, team2) '*'s out at 1st END IF END IF IF FBDropped THEN GOTO GR999 INCR iout IF ir1 > 0 AND ir2 = 0 THEN CALL Advanc(1, 0, 0) UnAssistedPct! = .85 Result$ = Result$ + "-3" INCR Assists(DataRef(wag, id), id, WhoAtPos) INCR PutOuts(DataRef(WHOATGUY(3), id), id, 3) GOTO GR999 GRForceAtHome: 'Less than TWO OUT & Bases Loaded - THROW HOME and FORCE RUNNER IF DelFac THEN CALL Msg ("29", "0","0", "01", 0, id, man2, team2) 'throw comes home CALL Msg ("29", "0","0", "02", 0, id, man2, team2) 'force out at home CALL Msg ("29", "0","0", "03", ib, it, man2, team2) '* is on END IF ir3 = 0 INCR iout CALL Advanc(1, 1, 0) ir1 = ib mpp(ib) = ip Result$ = Result$ + "-2 FO" INCR Assists(DataRef(wag, id), id, WhoAtPos) INCR PutOuts(DataRef(WHOATGUY(2), id), id, 2) GOTO GR999 GRThrowHomeOut: ' THROWN OUT AT HOME - batter safe on FC IF DelFac THEN CALL Msg ("29", "0","0", "04", ir3, it, man2, team2) 'trying to score CALL Msg ("29", "0","0", "05", 0, id, man2, team2) 'here comes throw CALL Msg ("14", "0","0", "04", ir3, it, man2, team2) 'OUT at plate! END IF ir3 = 0 INCR iout CALL Advanc(1, 1, 0) ir1 = ib mpp(ib) = ip Result$ = Result$ + "-2 FC" INCR Assists(DataRef(wag, id), id, WhoAtPos) INCR PutOuts(DataRef(WHOATGUY(2), id), id, 2) GOTO GR999 GRThrowHomeSafe: ' RUNNER SCORES - batter safe on FC IF DelFac THEN CALL Msg ("29", "0","0", "04", ir3, it, man2, team2) 'trying to score CALL Msg ("29", "0","0", "05", 0, id, man2, team2) 'here comes throw CALL Msg ("15", "0","0", "05", 0, it, man2, team2) 'safe! CALL Msg ("29", "0","0", "03", ib, it, man2, team2) '* is on END IF CALL Advanc(1, 1, 1) ir1 = ib mpp(ib) = ip mpo(ip, id) = mpo(ip, id) - 1 'No out recorded anywhere! Result$ = "Safe on FC" GOTO GR999 GRIgnoreHomeThrow1st: ' RUNNER SCORES - batter out (probably) IF DelFac THEN CALL Msg ("29", "0","0", "06", 0, id, man2, team2) 'goto 1st for sure one IF FBDropped THEN CALL Msg ("30", "0", "0", "05", bm1, id, man2, team2) CALL Msg ("30", "0", "0", "09", bm1, id, man2, team2) 'error ELSE CALL Msg ("02", p$, "3", "00", ib, it, man2, team2) 'batter is out END IF END IF IF FBDropped THEN GOTO GR999 INCR iout CALL Advanc(1, 1, 1) UnAssistedPct! = .75 Result$ = Result$ + "-3" INCR Assists(DataRef(wag, id), id, WhoAtPos) INCR PutOuts(DataRef(WHOATGUY(3), id), id, 3) GOTO GR999 ' DOUBLE-PLAY GRDoublePlay: DPsw = TRUE iout = iout + 2 INCR mpo(ip, id) INCR dp(id) ref = DataRef(ib, it) INCR mGDP(ref, it) 'Chance of a step-on-the-bag DP StepOn2nd = FALSE IF WhoAtPos = 4 AND t$ = "01" THEN IF RND < .15 THEN StepOn2nd = TRUE END IF IF WhoAtPos = 6 AND t$ <> "01" THEN IF RND < .20 THEN StepOn2nd = TRUE END IF StepOn3rd = FALSE IF ir2 <> 0 AND WhoAtPos = 5 AND t$ = "01" THEN 'Hit down the line IF RND < .30 THEN StepOn3rd = TRUE END IF IF BasesLoaded = FALSE THEN IF StepOn3rd THEN GOSUB DPStepOn3rd ELSE 'Around 2nd DP GOSUB DPAround2nd END IF ELSE ' BASES LOADED DOUBLE PLAY ' IS D.P. AROUND HOME OR AROUND 2ND? IF (GameSituation = TRUE AND iout = 0) OR (WhoAtPos = 1) THEN 'D.P. Around Home: IF DelFac THEN AddToAnnouncer id, "They throw to the plate for one..." CALL Msg ("08", "0","2", "00", 0, id, man2, team2) 'back to 1st AddToAnnouncer id, "OUT! Double Play" END IF CALL Advanc(1, 1, 0) ir1 = 0 Result$ = Result$ + "-2-3 DP!" INCR Assists(DataRef(wag, id), id, WhoAtPos) INCR PutOuts(DataRef(WHOATGUY(2), id), id, 2) INCR Assists(DataRef(WHOATGUY(2), id), id, 2) INCR PutOuts(DataRef(WHOATGUY(3), id), id, 3) ELSE GOSUB DPAround2nd END IF END IF DPsw = FALSE GOTO GR999 DPStepOn3rd: IF DelFac THEN AddToAnnouncer id, "He steps on the bag for one..." CALL Msg ("08", "0","2", "00", 0, id, man2, team2) 'back to 1st CALL Msg ("08", "0","3", "00", 0, id, man2, team2) 'Double play END IF CALL Advanc(1, 0, 1) 'Hope this works? Result$ = Result$ + "UN-3 DP" INCR PutOuts(DataRef(WHOATGUY(5), id), id, 5) INCR Assists(DataRef(WHOATGUY(5), id), id, 5) INCR PutOuts(DataRef(WHOATGUY(3), id), id, 3) RETURN DPAround2nd: IF DelFac THEN IF NOT StepOn2nd THEN CALL Msg ("08", "0","1", "00", 0, id, man2, team2) 'over to 2nd ELSE CALL Msg ("08", "0","4", "00", 0, id, man2, team2) 'steps on the bag END IF CALL Msg ("08", "0","2", "00", 0, id, man2, team2) 'back to 1st CALL Msg ("08", "0","3", "00", 0, id, man2, team2) 'Double play END IF CALL Advanc(0, 1, 1) ir1 = 0 IF WhoAtPos = 5 THEN Result$ = Result$ + "-4-3 DP" n = 4 END IF IF WhoAtPos = 6 THEN IF StepOn2nd = FALSE THEN Result$ = Result$ + "-4-3 DP" n = 4 ELSE Result$ = Result$ + "UN-3 DP" n = 6 END IF END IF IF WhoAtPos = 4 OR WhoAtPos = 3 THEN IF StepOn2nd = FALSE THEN Result$ = Result$ + "-6-3 DP" n = 6 ELSE Result$ = Result$ + "UN-3 DP" n = 4 END IF END IF IF NOT StepOn2nd THEN INCR Assists(DataRef(wag, id), id, WhoAtPos) INCR PutOuts(DataRef(WHOATGUY(n), id), id, n) INCR Assists(DataRef(WHOATGUY(n), id), id, n) INCR PutOuts(DataRef(WHOATGUY(3), id), id, 3) RETURN ChangeAnnouncer: IF DelFac THEN IF Dramatic THEN a$ = UCASE$(Announcer(1).mgs) i = INSTR(a$, "SLOW") i = i + INSTR(a$, "CHOP") i = i + INSTR(a$, "DRIBBLE") i = i + INSTR(a$, "SQUIB") i = i + INSTR(a$, "KNUB") i = i + INSTR(a$, "TAP") IF i THEN ANx = ANx - 2 t$ = LTRIM$(STR$(RND(1, 2))) '1 or 2 only t$ = PADZEROS$(t$, 2) CALL Msg ("03", p$, "1", t$, wag, id, man2, team2) CALL Msg ("03", p$, "2", t$, wag, id, man2, team2) END IF END IF END IF RETURN DidFBCatchThrow: FBDropped = FALSE IF MID$(Result$, 1, 1) = "3" THEN RETURN 'Error on 1st baseman? bm1 = WHOATGUY(3) defper1bF! = DEFPCT!(bm1) zF! = (1.0 - defper1bF!) * .9 'was .8 'Decrease constant for more errors IF RND > (defper1bF! + zF!) THEN '1st baseman mishandles throw FBDropped = TRUE Errorx = TRUE INCR iterrs(id) INCR inne r1 = DataRef(bm1, id) INCR GpPos(r1, id, 3) INCR merr(r1, id) INCR SumErrors(3) CALL Advanc(1, 1, 1) Errorx = FALSE ir1 = ib mpp(ir1) = ip mpp(ir1) = -mpp(ir1) 'Flip to negative to show runner got on via error Result$ = Result$ + "/E-3" mpo(ip, id) = mpo(ip, id) - 1 'No out recorded anywhere! END IF RETURN GR999: IF Result$ = "3-3" THEN Result$ = "3UN" IF DelFac THEN FOR i = 2 TO 4 xS$ = UCASE$(Announcer(i).mgs) IF INSTR(xS$, "HE FLIPS") THEN Result$ = "3-1" NEXT ELSE IF RND > UnAssistedPct! THEN Result$ = "3-1" END IF END IF IF Result$ = "3-1" THEN 'Take back the putout I already gave the 1st-baseman 'and give it to the pitcher instead IF PutOuts(DataRef(WHOATGUY(3), id), id, 3) > 0 THEN DECR PutOuts(DataRef(WHOATGUY(3), id), id, 3) END IF INCR PutOuts(ip, id, 1) ELSE 'Remove the assist I gave the 1st-baseman IF Assists(DataRef(WHOATGUY(3), id), id, 3) > 0 THEN DECR Assists(DataRef(WHOATGUY(3), id), id, 3) END IF END IF END IF EXIT SUB ErrorTrap: LOCATE 10, 30 PRINT "ERROR: Ground "; ERRCLEAR LOCATE 11, 30 PRINT "wag:";wag;"WhoAPos:";WhoAtPos; x$ = WAITKEY$ END SUB SUB GroundRulesIO (Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) CALL Drawfrm(2+rowO, 5+colO, 15+rowO, 76+colO, defattr, "Manager Options and other Preferences", "ESC (or close window) to Continue", 1, 0, 1) DATA 03,07,"Automatic Manager: ", 00,00,00," " DATA 04,07," Visitor [Y/N] ", 04,32,01,"XR" DATA 05,07," Home [Y/N] ", 05,32,01,"XR" DATA 07,07,"Delay seconds: ", 00,00,00," " DATA 08,07,"[This determines how quickly the play-by-play progresses]",00,00,00," " DATA 09,07," Delay [0-7] ", 09,32,01,"NR" DATA 11,07,"Sound Effects [y/n] ", 11,32,01,"XR" DATA 11,39,"Background Picture ", 11,58,15,"X " DATA 13,07,"Cross-Era Normalization ", 13,32,05,"X " DATA 13,39,"Performance Focusing [y/N]",13,66,01,"XR" QPRINTs rowO+11, colO+74, "+", revattr Flds = 10 c = 1 FOR i = 1 TO Flds Flitrow(i) = VAL(READ$(c)) IF Flitrow(i) > 0 THEN Flitrow(i) = Flitrow(i) + rowO Flitcol(i) = VAL(READ$(c+1)) IF Flitcol(i) > 0 THEN Flitcol(i) = Flitcol(i) + colO Flit$(i) = READ$(c+2) Frow(i) = VAL(READ$(c+3)) IF Frow(i) > 0 THEN Frow(i) = Frow(i) + rowO Fcol(i) = VAL(READ$(c+4)) IF Fcol(i) > 0 THEN Fcol(i) = Fcol(i) + colO Flen(i) = VAL(READ$(c+5)) Fed$(i) = READ$(c+6) c = c + 7 NEXT 'Set Defaults REDIM FContents$(13) FContents$(2) = "N" FContents$(3) = "N" FContents$(6) = LTRIM$(STR$(DelFac)) 'Delay FContents$(7) = CmdSound$ 'Sound IF LEN(DIR$("STADIUM.TXT")) THEN ' FContents$(8) = CmdPic$ 'Default Graphics FContents$(8) = BackgroundPic$ 'Default Graphics 'Load Contents of Stadium.txt to an array FileLimit = 200 REDIM List1(1 TO FileLimit) AS List1Type CALL LoadStadiumToList (List1(), choices) ELSE FContents$(8) = "" choices = 0 END IF IF Year(1) <> Year(2) THEN 'Normalization FContents$(9) = "H" ELSE FContents$(9) = "" END IF FContents$(10) = "N" 'Focusing IF CmdStat$ < "!" THEN FLen(10) = -1 CursorPtr = 2 DO GroundRuleLoop: CustomEscKey = -62 'F4 CALL ScreenIO(Keyed, KeyEsc, CustomEscKey, KeyEsc, Flds, CursorPtr, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) IF Keyed = CustomEscKey THEN 'F4 - Browse/Select Graphics File IF LEN(DIR$("STADIUM.TXT")) THEN CALL SelectPhotoIO(List1(), choices, Selection$) FContents$(8) = Selection$ GOTO GroundRuleLoop END IF END IF 'Edit Field Contents Error1$ = "N" IF FContents$(2) <> "Y" AND FContents$(2) <> "N" THEN Error1$ = "Y": CursorPtr = 2: CALL MyBeep: GOTO GroundRuleLoop END IF IF FContents$(3) <> "Y" AND FContents$(3) <> "N" THEN Error1$ = "Y": CursorPtr = 3: CALL MyBeep: GOTO GroundRuleLoop END IF IF FContents$(6) < "0" OR FContents$(6) > "9" THEN Error1$ = "Y": CursorPtr = 6: CALL MyBeep: GOTO GroundRuleLoop END IF IF FContents$(7) <> "Y" AND FContents$(7) <> "N" THEN Error1$ = "Y": CursorPtr = 7: CALL MyBeep: GOTO GroundRuleLoop END IF x$ = RTRIM$(FContents$(9)) y$ = "Response must be [H, V, B] or [####L] where ####=Year L=League" LL = LEN(x$) IF LL = 1 THEN IF x$ <> "H" AND x$ <> "V" AND x$ <> "B" THEN CALL PopMsg (14+rowO, 7+colO, y$, errattr, 5, kc) Error1$ = "Y": CursorPtr = 9: GOTO GroundRuleLoop END IF END IF IF LL = 5 THEN x1$ = MID$(x$, 1, 4) x2$ = MID$(x$, 5, 1) IF NUMERIC(x1$, 0, 0) AND (x2$ >= "A" AND x2$ <= "Z") THEN ELSE CALL PopMsg (14+rowO, 7+colO, y$, errattr, 5, kc) Error1$ = "Y": CursorPtr = 9: GOTO GroundRuleLoop END IF END IF IF LL > 1 AND LL < 5 THEN CALL PopMsg (14+rowO, 7+colO, y$, errattr, 5, kc) Error1$ = "Y": CursorPtr = 9: GOTO GroundRuleLoop END IF IF FContents$(10) <> "Y" AND FContents$(10) <> "N" THEN Error1$ = "Y": CursorPtr = 10: CALL MyBeep: GOTO GroundRuleLoop END IF IF FContents$(2) = "N" OR FContents$(3) = "N" THEN IF FContents$(6) = "0" THEN Error1$ = "Y" CursorPtr = 6 CALL MyBeep QPRINTs 12+rowO, 7+colO,"Do not choose Delay = 0 UNLESS the computer is managing BOTH sides!", defattr SLEEP 3000 QPRINTs 12+rowO, 7+colO, SPACE$(68), defattr GOTO GroundRuleLoop END IF END IF LOOP WHILE Error1$ = "Y" CURSOR OFF 'turn off cursor ERASE List1 amgr(1) = (FContents$(2) = "Y") amgr(2) = (FContents$(3) = "Y") DelFac = VAL(FContents$(6)) SoundOn = (FContents$(7) = "Y") CmdEra$ = RTRIM$(FContents$(9)) CmdFocus$ = FContents$(10) IF DelFac = 0 THEN SoundOn = FALSE END SUB SUB HBRoutine IF DelFac THEN IF SoundOn THEN CALL WavPopMitt CALL Msg ("29", "0", "0", "16", ib, it, man2, team2) CALL Msg ("29", "0", "0", "17", ib, it, man2, team2) END IF IF ir3 <> 0 AND ir2 <> 0 AND ir1 <> 0 THEN 'Bases Loaded CALL Advanc(1, 1, 1) ELSEIF ir1 THEN 'Runner on First IF ir2 THEN 'Also on Second CALL Advanc(1, 1, 0) ELSE 'Nobody on Second CALL Advanc(1, 0, 0) END IF END IF ' ** PUT BATTER ON 1ST ** ir1 = ib mpp(ib) = ip DECR mab(ref, it) IF UCASE$(DataHand(ip, id)) = "L" THEN DECR mabLHP(ref, it) ELSE DECR mabRHP(ref, it) END IF INCR mhb(ref, it) INCR mphb(ip, id) Result$ = "HBP" xS$ = PADZEROS$(LTRIM$(STR$(ip)), 2) + PADZEROS$(LTRIM$(STR$(ref)), 2) HitByPit(id) = HitByPit(id) + xS$ END SUB SUB HomeOptions (Pick) REDIM List1(1 TO 10) AS List1Type IF it = 2 THEN CALL Drawfrm(10+rowO, 42+colO, 20+rowO, 72+colO, defattr, RTRIM$(Names(2)), "", 0, 0, 2) List1(1).ListItem = " Pinch Hit " List1(2).ListItem = " Pinch Run " List1(3).ListItem = " View Lineup " List1(4).ListItem = " View Opponent " List1(5).ListItem = " Call Bullpen " IF WarmUpRule = FALSE THEN List1(5).ListItem = "%" + List1(5).ListItem List1(6).ListItem = STRING$(27,"Ž") List1(7).ListItem = " Steal " List1(8).ListItem = " Bunt/Squeeze " List1(9).ListItem = " Hit and Run " CALL PickFromList(List1(), 9, 9, 1, 27, 10+rowO, 42+colO, 20+rowO, 72+colO, dimattr, revattr, Pick, RetKey, nulls$, mous, ms$) SELECT CASE Pick CASE 1 PH = TRUE CASE 2 PRun = TRUE CASE 3 ViewHome = TRUE CASE 4 ViewVisi = TRUE CASE 5 BullO = TRUE CASE 7 Steal = TRUE CASE 8 Bunt = TRUE CASE 9 HitAndRun = TRUE CASE ELSE END SELECT ELSE CALL Drawfrm(10+rowO, 42+colO, 21+rowO, 72+colO, defattr, RTRIM$(Names(2)), "", 0, 0, 2) List1(1).ListItem = " Visit Mound " List1(2).ListItem = " Player Substitution " List1(3).ListItem = " Swap Positions " List1(4).ListItem = " View Line-up " List1(5).ListItem = " View Opponent " List1(6).ListItem = STRING$(27,"Ž") List1(7).ListItem = " Intentional Walk " List1(8).ListItem = " Infield Tight " List1(9).ListItem = " Pitch-Out " List1(10).ListItem =" Pitch-Around " CALL PickFromList(List1(), 10, 10, 1, 27, 10+rowO, 42+colO, 21+rowO, 72+colO, dimattr, revattr, Pick, RetKey, nulls$, mous, ms$) SELECT CASE Pick CASE 1 BullD = TRUE CASE 2 SubX = TRUE CASE 3 SwPos = TRUE CASE 4 ViewHome = TRUE CASE 5 ViewVisi = TRUE CASE 7 IWalk = TRUE CASE 8 Tight = TRUE CASE 9 POut = TRUE CASE 10 PAround = TRUE CASE ELSE END SELECT END IF ERASE List1 END SUB SUB HomeRunRoutine ppF! = FindPP! WhoAtPos = OUTFIELDWHOAT(ppF!) wag = WHOATGUY(WhoAtPos) IGone = TRUE IF DelFac THEN IF SoundOn THEN CALL WavBigFly IF InsideThePark THEN CALL TripleDialog (wag) CALL Msg ("10", "0", "4", "00", ib, it, man2, team2) 'he's not stopping CALL Msg ("31", "0", "0", "01", ib, it, man2, team2) 'rounds third... CALL Msg ("31", "0", "0", "06", ib, it, man2, team2) 'he slides... CALL Msg ("15", "0", "0", "04", ib, it, man2, team2) 'SAFE... ELSE IF RND < .1 THEN t$ = "02" ELSE t$ = "01" CALL Msg ("09", "0", "1", "01", 0, it, man2, team2) 'long drive CALL Msg ("09", "0", "2", t$, wag, id, man2, team2) '* going back CALL Msg ("09", "0", "3", t$, 0, id, man2, team2) 'gone END IF END IF CALL Advanc(3, 2, 1) INCR itruns(it) INCR innr INCR iScoreBd(it, innct) IF inn < 31 THEN INCR iScore(it, inn) INCR mpr(ip, id) INCR mphr(ip, id) IF inne - innadverr + iout < 3 THEN INCR mper(ip, id) CALL CreditHit INCR mruns(ref, it) INCR mhr(ref, it) IF UCASE$(DataHand(ip, id)) = "L" THEN INCR mhrLHP(ref, it) ELSE INCR mhrRHP(ref, it) END IF INCR mrbi(ref, it) IF itruns(it) = itruns(id) THEN 'Score now tied? Erase "pitcher-of-record" WPteam = 0: WPpit = 0: LPteam = 0: LPpit = 0: SPteam = 0: SPpit = 0 'Check for Blown Save IF QualSave1IP OR QualSave2IP THEN QualSave1IP = 0 QualSave1ID = 0 QualSave2IP = 0 QualSave2ID = 0 IF inn > (RegInns - 3) THEN INCR mpBS(ip, id) END IF ELSEIF itruns(it) - itruns(id) = 1 THEN WPteam = it: WPpit = ipa(it) LPteam = id: LPpit = ip END IF Result$ = "HR" END SUB SUB Innsum (r, c) QPRINTs r, c,"Inning.......", defattr QPRINTs r, c+13, STR$(inn), defattr QPRINTs r+2, c,"Runs.........", dimattr QPRINTs r+2, c+13, STR$(innr), dimattr QPRINTs r+3, c,"Hits.........", dimattr QPRINTs r+3, c+13, STR$(innh), dimattr QPRINTs r+4, c,"Errors.......", dimattr QPRINTs r+4, c+13, STR$(inne), dimattr QPRINTs r+5, c,"LOB..........", dimattr QPRINTs r+5, c+13, STR$(innLOB), dimattr QPRINTs r+7, c,"'" + LEFT$(Names(1), 12) + LFORMAT$(itruns(1), "##"), defattr QPRINTs r+8, c,"'" + LEFT$(Names(2), 12) + LFORMAT$(itruns(2), "##"), defattr END SUB SUB KillIt (xS$) yS$ = CmdWritePath$ + xS$ IF LEN(DIR$(yS$)) THEN KILL yS$ END SUB SUB Lineup (ii, rv) DIM Llitrow(3), Llitcol(3), Llit$(3), Lrow(3), Lcol(3), Llen(3), Led$(3), LContents$(3) DATA 23,36,"",23,37,02,"X " DATA 23,42,"",23,43,02,"X " Flds = 2 c = 1 FOR i = 1 TO Flds Llitrow(i) = VAL(READ$(c)) + rowO IF ConsRows > 25 THEN INCR Llitrow(i) Llitcol(i) = VAL(READ$(c+1)) + colO Llit$(i) = READ$(c+2) Lrow(i) = VAL(READ$(c+3)) + rowO IF ConsRows > 25 THEN INCR Lrow(i) Lcol(i) = VAL(READ$(c+4)) + colO Llen(i) = VAL(READ$(c+5)) Led$(i) = READ$(c+6) c = c + 7 NEXT LastDS = 0 r1 = (ConsRows - 23) \ 2 r2 = r1 + 24 c1 = (ConsCols - 78) \ 2 c2 = c1 + 79 IF ConsRows > 25 AND ConsCols > 81 THEN sr2 = 1 sc2 = 2 shad = 1 ELSE sr2 = 0 sc2 = 0 shad = 0 END IF IF Gfx THEN CALL GraphHole(30, r1, c1, r2+sr2, c2+sc2) CALL Drawfrm(r1, c1, r2, c2, defattr, "Lineup for '" + RTRIM$(Names(ii)), ARROWS$ + ":SCROLL [S]wap [M]ore Lineups ESC:Continue", shad, 0, 1) QPRINTs r2-4, c1+1, STRING$(c2-c1-1, "Ž"), defattr QPRINTs r2-4, c1+36, " " + LPtr$ + " " + RPtr$ + " Ç", defattr QPRINTs MidRow+3, c2, "µ", defattr QPRINTs MidRow+4, c2, UpPtr$, defattr QPRINTs MidRow+5, c2, DnPtr$, defattr QPRINTs MidRow+6, c2, "¶", defattr LU5: RowOff = 0: ColOff = 0 CALL BuildTeamWin (ii, 1, MAXPLAYERS, TRUE, pend) DO '1st Vir elem, # of elem, roff, coff, scrn-line, scrn-col, lockrows, lockcol, collimit '(p1, maxLines, RowOff, ColOff, startline, startcol, rowlock, collock, collimit) CALL ShowVirtWin (1, 10, RowOff, ColOff, r1+2, c1+2, 10, 20, c2-c1-3) x$ = STRING$(35,"Ž") + " Bench " + STRING$(36, "Ž") QPRINTs r1+12, c1+1, x$, defattr CALL ShowVirtWin (LastPiAd(ii) + 4, r2-r1-17, RowOff, ColOff, r1+13, c1+2, 0, 20, c2-c1-3) GOSUB ShowOpposingPitcher GOSUB Check4PitInBO 'Is pitcher also playing in the field? CALL GetScrollKey (kc, RowOff, ColOff) IF kc = 27 THEN rv = 0 GOTO LU999 END IF LOOP UNTIL kc = 83 OR kc = 77 ' "S"wap or "M"ore 'AutoLineup [M] IF kc = 77 THEN IF inn = 0 THEN CALL AutoLineup(ii, c) CALL AdjustBattingOrder(ii) ELSE xS$ = " Sorry. Can't use this feature after the game has started. " CALL PopMsg(r2-4, 10+colO, xS$, errattr, 2, kc) END IF GOTO LU5 END IF LU100: IF ConsRows > 25 THEN rr1 = 23+rowO cc1 = 23+colO rr2 = 25+rowO cc2 = 61+colO ELSE rr1 = 22+rowO cc1 = 23+colO rr2 = 24+rowO cc2 = 61+colO END IF CALL GetScreen(Scr1$, rr1, cc1, rr2, cc2) IF Gfx THEN CALL GraphHole(32, rr1, cc1, rr2, cc2) CALL Drawfrm(rr1, cc1, rr2, cc2, defattr, "Player Numbers to Swap", "ESC:Continue F3:Cancel", 0, 0, 2) QPRINTs rr1+1, 40+colO, xLPtr$ + xRPtr$, defattr LContents$(1) = " " LContents$(2) = " " CursorPtr = 1 DO CALL ScreenIO(Keyed, KeyF3, 0, KeyEsc, Flds, CursorPtr, Llen(), Lrow(), Lcol(), Led$(), Llit$(), Llitrow(), Llitcol(), LContents$()) 'Cancel IF Keyed = KeyF3 THEN BEEP CALL PutScreen(Scr1$, rr1, cc1, rr2, cc2) IF Gfx THEN CALL EliminateHole(32) CALL UnfreezeAndRefresh END IF GOTO LU5 END IF 'Edit Field Contents Error1$ = "N" IF LContents$(1) = SPACE$(2) AND LContents$(2) = SPACE$(2) THEN rv = 0 CALL PutScreen(Scr1$, rr1, cc1, rr2, cc2) IF Gfx THEN CALL EliminateHole(32) GOTO LU999 END IF M10 = VAL(LContents$(1)) M20 = VAL(LContents$(2)) CursorPtr = 1 IF M10 < 1 OR (M10 > 9 AND M10 <= LastPiAd(ii)) OR M10 > pend THEN xS$ = " Out of range! " CALL PopMsg(rr1-1, 33+colO, xS$, errattr, 2, kc) Error1$ = "Y" GOTO L100Cont END IF IF M20 < 1 OR (M20 > 9 AND M20 <= LastPiAd(ii)) OR M20 > pend THEN xS$ = " Out of range! " CALL PopMsg(rr1-1, 33+colO, xS$, errattr, 2, kc) Error1$ = "Y" CursorPtr = 2 GOTO L100Cont END IF IF inn > 0 AND M10 < 10 AND M20 < 10 THEN xS$ = " Can't change the batting order after the game starts! " CALL PopMsg(rr1-1, 11+colO, xS$, errattr, 2, kc) Error1$ = "Y" GOTO L100Cont END IF IF iused(M10, ii) OR iused(M20, ii) THEN xS$ = " You already sent that player to the showers. Try again. " CALL PopMsg(rr1-1, 15+colO, xS$, errattr, 2, kc) Error1$ = "Y" GOTO L100Cont END IF IF (DataPos(M10, ii) = 1 AND M20 > 9) OR (DataPos(M20, ii) = 1 AND M10 > 9) THEN xS$ = " Select [Bullpen] option to change pitchers! " CALL PopMsg(rr1-1, 15+colO, xS$, errattr, 2, kc) Error1$ = "Y" GOTO L100Cont END IF 'Find bench guy you're about to swap in: bn = 0 lu = 0 IF M10 > LastPiAd(ii) AND M20 > LastPiAd(ii) THEN bn = 0 lu = 0 ELSEIF M10 > LastPiAd(ii) THEN bn = M10 lu = M20 ELSEIF M20 > LastPiAd(ii) THEN bn = M20 lu = M10 END IF IF bn THEN 'Does this guy have identical name to a current or used pitcher? FOR nn = 1 TO np(ii) IF DataName(bn, ii) = DataName(iyp(nn, ii), ii) THEN Error1$ = "Y" xS$ = " The bench player seems to be a used pitcher. Try again. " CALL PopMsg(rr1-1, 15+colO, xS$, errattr, 2, kc) GOTO L100Cont END IF NEXT END IF 'Former position of check4pitinBO L100Cont: LOOP WHILE Error1$ = "Y" CURSOR OFF 'turn off cursor IF M10 < 10 THEN IOPOS = DataPos(M10, ii) IF M20 < 10 THEN IOPOS = DataPos(M20, ii) LUSwitchEm: IF inn > 0 THEN 'Prevent adding to scorecard after a double-switch IF (M10 > 9 OR M20 > 9) AND bn > 0 THEN x$ = "[SUB]" + FLASTNAME$(bn, ii) + "(" + RTRIM$(Pos(IOPOS)) _ + ") for " + FLASTNAME$(lu, ii) CALL AddToScoreCrd (0, 0, "X", x$) END IF END IF 'Switch attributes of player M10 and M20 on team ii CALL Switch(M10, M20, ii) rv = -1 CALL PutScreen(Scr1$, rr1, cc1, rr2, cc2) IF Gfx THEN CALL EliminateHole(32) CALL UnfreezeAndRefresh END IF IF M10 < 10 AND M20 < 10 THEN GOTO LU5 'Double-switch exit IF M10 < 10 THEN DataPos(M10, ii) = IOPOS IF M20 < 10 THEN DataPos(M20, ii) = IOPOS IF inn > 0 THEN IF M10 < 10 AND M20 > 10 THEN iused(M20, ii) = TRUE IF M20 < 10 AND M10 > 10 THEN iused(M10, ii) = TRUE IF M10 < 10 THEN LastDS = M10 IF M20 < 10 THEN LastDS = M20 'Add new player to lineup batting slot CALL AddToRefByBO (LastDS, ii, DataRef(LastDS, ii)) 'bat-pos, team, ref END IF 'Double-Switch Option IF LastDS > 0 AND NOT dh AND HotBull THEN CALL Drawfrm(12+rowO, 13+colO, 14+rowO, 67+colO, defattr, nulls$, nulls$, 1, 0, 0) QPRINTs 13+rowO, 15+colO, "Want to Double-Switch with the new pitcher? [y/N]", defattr LOCATE 13+rowO, 65+colO IF YESorNO$(revfor, revbac, deffor, defbac, "N") = "Y" THEN M10 = LastDS ps = 0 DO INCR ps IF ps > 9 THEN x$ = "ERROR(LineUp): No Pitcher Found in Lineup" x$ = x$ + "|" + DataFil(ii) CALL ErrorBox (x$) END IF LOOP UNTIL DataPos(ps, id) = 1 M20 = ps HotBull = FALSE 'so will not prompt again 'Remove new player from M10 slot in RefByBO L = LEN(RefByBO(M10, ii)) IF L > 2 THEN RefByBO(M10, ii) = LEFT$(RefByBO(M10, ii), L-2) ELSE RefByBO(M10, ii) = nulls$ END IF 'Remove new pitcher from M20 slot L = LEN(RefByBO(M20, ii)) IF L > 2 THEN RefByBO(M20, ii) = LEFT$(RefByBO(M20, ii), L-2) ELSE RefByBO(M20, ii) = nulls$ END IF 'Add new player to M20 slot (they haven't been switched yet) CALL AddToRefByBO (M20, ii, DataRef(M10, ii)) 'bat-pos, team, ref 'Add new pitcher to M10 slot (they haven't been switched yet) CALL AddToRefByBO (M10, ii, DataRef(M20, ii)) 'bat-pos, team, ref x$ = "[DBL-SW]" + FLASTNAME$(M10, ii) + " bats #" + LTRIM$(STR$(M20)) CALL AddToScoreCrd (0, 0, "X", x$) x$ = " " + FLASTNAME$(M20, ii) + " bats #" + LTRIM$(STR$(M10)) CALL AddToScoreCrd (0, 0, "X", x$) GOTO LUSwitchEm END IF END IF GOTO LU5 ShowOpposingPitcher: ij = 3 - ii IF ipa(ij) THEN x$ = "Opposing Pitcher W L ERA SIM: W L ERA" ELSE x$ = "Opposing Pitcher not determined" END IF CALL Drawfrm(r2-3, c1+1, r2-1, c2-1, defattr, x$, nulls$, 0, 0, 0) IF ipa(ij) THEN p = ipa(ij) a$ = SPACE$(69) MID$(a$, 1, 12) = RTRIM$(Names(ij)) xS$ = DataName(p, ij) MID$(a$, 14, 20) = FULLNAME$(xS$) MID$(a$, 35, 1) = DataHand(p, ij) MID$(a$, 37, 2) = LFORMAT$(DataDef(p, ij), "##") MID$(a$, 40, 2) = LFORMAT$(DataSB(p, ij), "##") xF! = DataRBI(p, ij) / 100 MID$(a$, 43, 5) = FFORMAT$(xF!, "#0.##") IF CmdStat$ > "!" AND DaysOffRule = TRUE THEN m = GetDaysOff (p, ij) IF m THEN MID$(a$, 53, 1) = LFORMAT$(m, "#") END IF END IF CALL PitchersWLS (ij, p, w, l, s, era!) MID$(a$, 56, 3) = LFORMAT$(w, "###") MID$(a$, 60, 3) = LFORMAT$(l, "###") MID$(a$, 64, 5) = FFORMAT$(era!, "#0.##") QPRINTs r2-2, c1+5, a$, dimattr END IF RETURN Check4PitInBO: 'Is there a pitcher in the batting order? ps = 0 i = 1 DO IF DataPos(i, ii) = 1 THEN ps = i : EXIT DO INCR i LOOP UNTIL i > 9 IF ps THEN 'There is - Is the pitcher's name anywhere else in the batting order? FOR i = 1 TO 9 IF i <> ps THEN IF DataName(i, ii) = DataName(ps, ii) THEN Error1$ = "Y" xS$ = " WARNING: The current pitcher is also in the lineup! Please correct. " CALL PopMsg(20+rowO, 6+colO, xS$, errattr, 4, kc) EXIT FOR END IF END IF NEXT END IF RETURN LU999: ERASE VirtualWin IF Gfx THEN CALL EliminateHole(30) END IF END SUB SUB ListFile (FileN$) ' TYPE BufType ' BufferItem AS STRING * 210 ' END TYPE MaxPasses = 1000 REDIM PassPosD(MaxPasses) AS LONG 'Check if File Exists IF LEN(DIR$(FileN$)) = 0 THEN PRINT FileN$; " not found in the current directory." EXIT SUB END IF MaxLinesInPass = 815 REDIM Buffer(1 TO MaxLinesInPass) AS BufType ' Read through entire file, figure out positions in file when we ' need a "pass break". Go ahead and put first pass into memory. D& = 1 LastPass = 0 ErrorSw = 0 File = 70 OPEN FileN$ FOR INPUT AS #File DO UNTIL EOF(File) IF D& MOD MaxLinesInPass THEN CurrPass = INT(D& / MaxLinesInPass) + 1 ELSE CurrPass = INT(D& / MaxLinesInPass) END IF IF CurrPass > MaxPasses THEN CurrPass = CurrPass - 1 ErrorSw = -1 EXIT DO END IF IF CurrPass <> LastPass THEN PassPosD(CurrPass) = SEEK(File) LastPass = CurrPass END IF IF CurrPass = 1 THEN LINE INPUT #File, xS$ Buffer(D&).BufferItem = xS$ ELSE xS$ = "" LINE INPUT #File, xS$ END IF INCR D& LOOP LastLineInFileD& = D& - 1 TotalPasses = CurrPass 'find the last \ l = LEN(FileN$) i = l DO IF MID$(FileN$, i, 1) = "\" THEN EXIT DO i = i - 1 LOOP WHILE i > 0 IF i = 0 THEN short$ = FileN$ ELSE short$ = MID$(FileN$, i + 1) COLOR dimfor, dimbac attr = CalcAttr(0, 7) CURSOR OFF ' 30 31 17 16 24 25 '       a$ = "[X]:Close [ ]:PageUp/Dn [< >] [u d] [T]op [B]ot [P]rint [S]aveAs ü" + short$ MID$(a$, 2, 1) = CloseButton$ MID$(a$,12, 1) = UpPtr$ MID$(a$,14, 1) = DnPtr$ MID$(a$,29, 1) = LPtr$ MID$(a$,31, 1) = RPtr$ MID$(a$,35, 1) = xUpPtr$ MID$(a$,37, 1) = xDnPtr$ a$ = PADRIGHT$(a$, ConsCols) QPRINTs ConsRows, 1, a$, attr LastPass = 1 begD& = 1 startcol = 1 MouseDown = FALSE MOUSE 3, DOUBLE, DOWN, UP Cnt = 0 DO IF ConsRows = 25 THEN BeginBuffer DO 'Experiment - Loop while MouseDown INCR Cnt FOR linenoD& = begD& TO begD& + (ConsRows-2) 'Find the current pass in the file for line you are about to display IF linenoD& MOD MaxLinesInPass THEN CurrPass = INT(linenoD& / MaxLinesInPass) + 1 ELSE CurrPass = INT(linenoD& / MaxLinesInPass) END IF 'Always keep the right pass of the file in the buffer memory IF CurrPass <> LastPass AND CurrPass <= TotalPasses THEN REDIM Buffer(1 TO MaxLinesInPass) AS BufType '64K or 32 screens SEEK #File, PassPosD(CurrPass) LastPass = CurrPass FOR n = 1 TO MaxLinesInPass LINE INPUT #File, Buffer(n).BufferItem IF EOF(File) THEN EXIT FOR NEXT END IF 'Find the memory slot in Buffer for linenoD& i = linenoD& - (CurrPass - 1) * MaxLinesInPass IF linenoD& > LastLineInFileD& THEN IF ErrorSw THEN QPRINTs linenoD& - begD& + 1, 1, "", defattr ELSE QPRINTs linenoD& - begD& + 1, 1, "" + SPACE$(ConsCols-13), defattr n = linenoD& - begD& + 2 DO WHILE n < ConsRows QPRINTs n, 1, SPACE$(ConsCols), dimattr INCR n LOOP END IF EXIT FOR ELSEIF MID$(Buffer(i).BufferItem, 1, 1) = CHR$(12) THEN QPRINTs linenoD& - begD& + 1, 1, "", defattr ELSEIF MID$(Buffer(i).BufferItem, 1, 1) = "~" THEN QPRINTs linenoD& - begD& + 1, 1, MID$(Buffer(i).BufferItem, startcol + 1, ConsCols), revattr ELSE QPRINTs linenoD& - begD& + 1, 1, MID$(Buffer(i).BufferItem, startcol, ConsCols), dimattr END IF NEXT IF MouseDown AND Cnt = 1 THEN SLEEP 200 'slow down so hopefully inkey will detect the "up" END IF x$ = INKEY$ 'Exp IF LEN(x$) THEN ' LOCATE 10, 30: PRINT "INPUT DETECTED";: SLEEP 200 MouseDown = FALSE ELSEIF MouseDown THEN ' LOCATE 10, 30: PRINT "MD/NO INPUT "; SLEEP 180 IF kc = -81 THEN ' Pg down IF begD& + (ConsRows-1) <= LastLineInFileD& THEN begD& = begD& + (ConsRows-1) END IF IF kc = -73 THEN ' PgUp IF begD& > ConsRows-1 THEN begD& = begD& - (ConsRows-1) ELSE begD& = 1 END IF IF kc = -72 THEN ' Up Arrow IF begD& > 1 THEN begD& = begD& - 1 END IF IF kc = -80 THEN ' Down Arrow IF begD& + 1 <= LastLineInFileD& THEN begD& = begD& + 1 END IF END IF LOOP WHILE MouseDown IF ConsRows = 25 THEN EndBuffer ListerWait: KyS$ = WAITKEY$ OrgKyS$ = KyS$ Cnt = 0 mous = 0 msx = 0 msy = 0 MouseDown = FALSE IF LEN(KyS$) = 1 THEN kc = ASC(KyS$) KyS$ = UCASE$(KyS$) ELSEIF LEN(KyS$) = 2 THEN kc = -ASC(RIGHT$(KyS$, 1)) ELSEIF LEN(KyS$) = 4 THEN mous = TRUE msx = MOUSEX msy = MOUSEY 'read a character from the screen kc = SCREEN(msy, msx) KyS$ = CHR$(kc) ' 30 31 25 24 17 16 '       IF KyS$ = CloseButton$ THEN kc = 27 IF KyS$ = DnPtr$ THEN kc = -81 IF KyS$ = UpPtr$ THEN kc = -73 IF KyS$ = xDnPtr$ THEN kc = -80 ' IF KyS$ = xUpPtr$ THEN kc = -72 ' IF KyS$ = LPtr$ THEN kc = -75 IF KyS$ = RPtr$ THEN kc = -77 IF ASC(OrgKyS$, 3) = 2 THEN MouseDown = TRUE IF ASC(OrgKyS$, 3) = 4 THEN MouseDown = TRUE IF msy = ConsRows THEN GOSUB FlashMouse END IF IF ASC(OrgKyS$, 3) = 8 THEN GOTO ListerWait 'Button Release IF kc = -81 THEN ' PgDn IF begD& + (ConsRows-1) <= LastLineInFileD& THEN begD& = begD& + (ConsRows-1) ELSE CALL MyBeep: GOTO ListerWait END IF IF kc = -73 THEN ' PgUp IF begD& = 1 THEN CALL MyBeep: GOTO ListerWait IF begD& > ConsRows-1 THEN begD& = begD& - (ConsRows-1) ELSE begD& = 1 END IF IF kc = -80 THEN ' Down IF begD& + 1 <= LastLineInFileD& THEN begD& = begD& + 1 ELSE CALL MyBeep: GOTO ListerWait END IF IF kc = -72 THEN ' Up IF begD& > 1 THEN begD& = begD& - 1 ELSE CALL MyBeep: GOTO ListerWait END IF IF kc = -75 THEN ' Left IF startcol - 10 > 0 THEN startcol = startcol - 10 END IF IF kc = -77 THEN ' Right 'l=121:42 'l=155:75 'l=175:95 'l=175-ConsCols IF startcol + 10 < (210 - ConsCols) THEN startcol = startcol + 10 END IF IF KyS$ = "T" OR KyS$ = "t" THEN begD& = 1 END IF IF KyS$ = "B" OR KyS$ = "b" THEN IF LastLineInFileD& - (ConsRows-2) > 0 THEN begD& = LastLineInFileD& - (ConsRows-2) ELSE begD& = 1 END IF IF KyS$ = "P" OR KyS$ = "p" THEN CALL PopMsg(13+rowO, 30+colO, "Launching WORDPAD.", errattr, 1, kc2) 'Launch WordPad CLOSE #File SLEEP 500 SHELL WordPadSpec$ + " " + FileN$ SLEEP 500 OPEN FileN$ FOR INPUT AS #File MouseDown = FALSE END IF IF KyS$ = "S" OR KyS$ = "s" THEN 'Save As CALL Drawfrm(12+rowO, 22+colO, 14+rowO, 58+colO, defattr, "Save As...", "ENTER:Save ESC:Cancel", 1, 0, 0) OldFile$ = RTRIM$(FileN$) NewFile$ = RTRIM$(MYINPUT$(FALSE, EscKey, CustomEscKey, 13, kc2, revfor, revbac, 13+rowO, 24+colO, 32, " E", 0, 0, OldFile$, msx, msy)) MouseDown = FALSE 'No mouse support IF kc2 = KeyEsc THEN GOTO ListerTestLoop IF UCASE$(RTRIM$(NewFile$)) = UCASE$(RTRIM$(FileN$)) THEN GOTO ListerTestLoop IF NewFile$ < "!" THEN GOTO ListerTestLoop CLOSE #File SLEEP 500 FILECOPY RTRIM$(FileN$), NewFile$ SLEEP 500 OPEN FileN$ FOR INPUT AS #File END IF ListerTestLoop: LOOP UNTIL kc = 27 'Escape MOUSE 3, DOUBLE, DOWN CLOSE #File ERASE Buffer ERASE PassPosD EXIT SUB FlashMouse: CALL FlashField (msy, msx, 1, 2, 100, revattr) RETURN END SUB SUB LoadFilesToList1 (FileMask$, List1() AS List1Type, Limit, n) f$ = UCASE$(DIR$(FileMask$)) DO IF f$ > "!" THEN Reject = FALSE 'Win 2K/XP patch IF FileMask$ = "*. " THEN L = LEN(f$) IF MID$(f$, L-3, 1) = "." THEN Reject = TRUE END IF IF NOT Reject THEN INCR n IF n <= Limit THEN List1(n).ListItem = f$ ELSE x$ = "Exceeded program limits on number of files" CALL ErrorBox (x$) EXIT SUB END IF END IF END IF f$ = UCASE$(DIR$) LOOP WHILE f$ > "!" END SUB SUB LoadPbyP ON ERROR GOTO LPP_ErrorTrap DIM CurrClass$(10) DIM CurrPos$(10) DIM CurrSeq$(10) DIM CurrTrk$(20) ndx = 0 OPEN "baseball.msg" FOR INPUT AS #1 DO UNTIL EOF(1) LINE INPUT #1, rec$ c1$ = MID$(rec$, 1, 1) IF c1$ = ";" THEN IF EOF(1) THEN EXIT DO ELSE ITERATE DO END IF END IF IF c1$ = "C" THEN cc = 0 cp = 0 cs = 0 ct = 0 GOSUB ParseRec FOR i = 1 TO n CurrClass$(i) = PARSE$(x$, i) NEXT cc = n ELSEIF c1$ = "P" THEN cp = 0 cs = 0 ct = 0 GOSUB ParseRec FOR i = 1 TO n CurrPos$(i) = PARSE$(x$, i) NEXT cp = n ELSEIF c1$ = "S" THEN cs = 0 ct = 0 GOSUB ParseRec FOR i = 1 TO n CurrSeq$(i) = PARSE$(x$, i) NEXT cs = n ELSEIF c1$ = "D" THEN ct = 0 GOSUB ParseRec FOR i = 1 TO n CurrTrk$(i) = PARSE$(x$, i) NEXT ct = n ELSEIF c1$ = " " THEN ccc = 1 DO cpc = 1 DO csc = 1 DO ctc = 1 DO INCR ndx IF ndx > 1500 THEN PRINT "Too many Play-by-Play lines!" SLEEP 1000 EXIT SUB END IF IF cc > 0 THEN PbyP(ndx).class = PADZEROS$(CurrClass$(ccc), 2) ELSE PbyP(ndx).class = "00" END IF IF cp > 0 THEN PbyP(ndx).pos = CurrPos$(cpc) ELSE PbyP(ndx).pos = "0" END IF IF cs > 0 THEN PbyP(ndx).seq = CurrSeq$(csc) ELSE PbyP(ndx).seq = "0" END IF IF ct > 0 THEN PbyP(ndx).trk = PADZEROS$(CurrTrk$(ctc), 2) ELSE PbyP(ndx).trk = "00" END IF PbyP(ndx).pndx = " " PbyP(ndx).text = MID$(rec$, 7) INCR ctc LOOP UNTIL ctc > ct INCR csc LOOP UNTIL csc > cs INCR cpc LOOP UNTIL cpc > cp INCR ccc LOOP UNTIL ccc > cc END IF LOOP CLOSE #1 REDIM PRESERVE PbyP(ndx) AS GLOBAL PbyPType PbyP_Cnt = ndx ARRAY SORT PbyP(1) FOR PbyP_Cnt, FROM 1 TO 6, ASCEND 'PRINT "PbyP_Cnt: "; PbyP_Cnt 'Stick in the "tie-breaker index" i = 1 key$ = PbyP(1).class + PbyP(1).pos + PbyP(1).seq + PbyP(1).trk DO UNTIL i > PbyP_Cnt savekey$ = key$ IDX = 0 DO UNTIL key$ <> savekey$ OR i > PbyP_Cnt INCR IDX x$ = LTRIM$(STR$(IDX)) x$ = PADZEROS$(x$, 3) PbyP(i).pndx = x$ INCR i IF i <= PbyP_Cnt THEN key$ = PbyP(i).class + PbyP(i).pos + PbyP(i).seq + PbyP(i).trk END IF LOOP LOOP EXIT SUB ParseRec: s = INSTR(rec$, " ") IF s THEN x$ = MID$(rec$, 3, s - 3) ELSE x$ = MID$(rec$, 3) END IF n = PARSECOUNT(x$) RETURN LPP_ErrorTrap: LOCATE 10, 30 PRINT "LPP_Error"; ERRCLEAR x$ = WAITKEY$ END SUB SUB LoadScoreCardToList1 (List1() AS List1Type, j) 'j will return actual # of entries i = 1 j = 0 LastTeam = 2 DO WHILE i <= SCx IF SCRec(i).SCTeam <> LastTeam _ AND SCRec(i).SCCode <> "X" _ AND SCRec(i).SCCode <> "0" THEN LastTeam = SCRec(i).SCTeam IF j < 300 THEN INCR j zS$ = ": " + Names(LastTeam) List1(j).ListItem = "~ Inn." + STR$(SCRec(i).SCInn) + zS$ END IF END IF IF SCRec(i).SCRef > 0 THEN player = SCRec(i).SCRef team = SCRec(i).SCTeam GOSUB SCGetName 'in yS$ ELSE yS$ = "" END IF IF SCRec(i).SCCode = " " THEN 'normal' xS$ = PADRIGHT$(yS$, 18) ELSEIF SCRec(i).SCCode = "X" THEN 'free format xS$ = SCRec(i).SCResult GOTO SCINC ELSEIF SCRec(i).SCCode = "9" THEN 'PH/PR replacement xS$ = "*EX:" + yS$ + " " + _ LEFT$(SCRec(i).SCResult, 10) GOTO SCINC ELSEIF SCRec(i).SCCode = "8" THEN 'PH xS$ = "*PH:" + PADRIGHT$(yS$, 14) ELSEIF SCRec(i).SCCode = "7" THEN xS$ = "*PR:" + yS$ 'PR GOTO SCINC ELSEIF SCRec(i).SCCode = "6" THEN 'SB xS$ = "*SB:" + PADRIGHT$(yS$, 14) ELSEIF SCRec(i).SCCode = "5" THEN xS$ = PADRIGHT$(yS$, 18) 'WP/PB ELSEIF SCRec(i).SCCode = "4" THEN xS$ = "X@4:" + PADRIGHT$(yS$, 14) 'X4 ELSEIF SCRec(i).SCCode = "3" THEN xS$ = "X@3:" + PADRIGHT$(yS$, 14) 'X3 ELSEIF SCRec(i).SCCode = "2" THEN xS$ = "X@2:" + PADRIGHT$(yS$, 14) 'X2 ELSEIF SCRec(i).SCCode = "1" THEN xS$ = "X@1:" + PADRIGHT$(yS$, 14) 'X1 PK-OFF ELSEIF SCRec(i).SCCode = "0" THEN xS$ = PADRIGHT$(yS$, 17) + " " 'Starting Lineup xS$ = xS$ + LEFT$(SCRec(i).SCResult, 10) GOTO SCINC ELSEIF SCRec(i).SCCode = "A" THEN 'Flip teams for special case. 'Completely special case for listing pitchers on other side 'and defensive people swaped in in a double-switch. player = SCRec(i).SCRef team = 3 - SCRec(i).SCTeam GOSUB SCGetName xS$ = RTRIM$(SCRec(i).SCResult) + " " + yS$ GOTO SCINC ELSE xS$ = "- " + PADRIGHT$(yS$, 16) END IF xS$ = xS$ + LEFT$(SCRec(i).SCResult, 10) + _ SCRec(i).SCBase3 + _ SCRec(i).SCBase2 + _ SCRec(i).SCBase1 + _ SCRec(i).SCBase4 SCINC: IF j < 300 THEN INCR j List1(j).ListItem = xS$ END IF INCR i LOOP EXIT SUB SCGetName: 'input: team, ref yS$ = FLASTNAMER$(player, team) RETURN END SUB SUB LoadSIMData (tm) i = 1 DO WHILE i <= MAXPLAYERS xS$ = DataName(i, tm) ref = DataRef(i, tm) IF i > LastPiAd(tm) THEN IF xS$ < "!" THEN EXIT DO END IF IF ref < 1 OR ref > MAXPLAYERS THEN x$ = "Reference ptr out of bounds in LoadSIMData.|Ref:" x$ = x$ + STR$(ref) + " Max:" + STR$(MAXPLAYERS) MyBEEP CALL ErrorBox (x$) END IF 'Look up everybody's hitting record, including pitchers FoundAt = 0 Find$ = League(tm) Find$ = Find$ + PADRIGHT$(Names(tm), 12) Find$ = Find$ + PADRIGHT$(xS$, 16) TotalRecs = BSum(0).BGameCtr CALL BinarySearchB (BSum(), 1, 29, 1, TotalRecs, Find$, FoundAt, mini) IF FoundAt = 0 THEN BSum(FoundAt).BGames = 0 BSum(FoundAt).BABs = 0 BSum(FoundAt).BHits = 0 BSum(FoundAt).BBBs = 0 BSum(FoundAt).BKs = 0 BSum(FoundAt).BHRs = 0 BSum(FoundAt).BRBIs = 0 BSum(FoundAt).BStreak = 0 END IF SimGames(ref, tm) = BSum(FoundAt).BGames SimAB(ref, tm) = BSum(FoundAt).BABs SimHits(ref, tm) = BSum(FoundAt).BHits SimBB(ref, tm) = BSum(FoundAt).BBBs SimSO(ref, tm) = BSum(FoundAt).BKs SimHR(ref, tm) = BSum(FoundAt).BHRs SimRBI(ref, tm) = BSum(FoundAt).BRBIs SimBStreak(ref, tm) = BSum(FoundAt).BStreak IF ref > 9 AND ref <= LastPiAd(tm) THEN IF ref < 10 OR ref > TopPitLim THEN x$ = "Reference ptr not in pitcher range.|Ref:" + STR$(ref) BEEP CALL ErrorBox (x$) END IF 'A Pitcher's Reference Number, so look up pitching history FoundAt = 0 Find$ = League(tm) Find$ = Find$ + PADRIGHT$(Names(tm), 12) + PADRIGHT$(xS$, 16) TotalRecs = PSum(0).PGameCtr CALL BinarySearchP (PSum(), 1, 29, 1, TotalRecs, Find$, FoundAt, mini) IF FoundAt = 0 THEN PSum(FoundAt).PInns = 0 PSum(FoundAt).P3rds = 0 PSum(FoundAt).PWin = 0 PSum(FoundAt).PLoss = 0 PSum(FoundAt).PERuns = 0 PSum(FoundAt).PHits = 0 PSum(FoundAt).PBBs = 0 PSum(FoundAt).PSOs = 0 PSum(FoundAt).PSave = 0 PSum(FoundAt).PDaysOff = 0 END IF SimInn(ref, tm) = PSum(FoundAt).PInns + PSum(FoundAt).P3rds / 3 SimWins(ref, tm) = PSum(FoundAt).PWin SimLosses(ref, tm) = PSum(FoundAt).PLoss SimHitsAlw(ref, tm) = PSum(FoundAt).PHits SimERuns(ref, tm) = PSum(FoundAt).PERuns SimBBAlw(ref, tm) = PSum(FoundAt).PBBs SimSO_P(ref, tm) = PSum(FoundAt).PSOs SimSaves(ref, tm) = PSum(FoundAt).PSave DaysOff = PSum(FoundAt).PDaysOff IF CmdSch$ > "!" THEN Now = JDATE(SchDate$) Last = PSum(FoundAt).PJDate DaysOff = DaysOff - (Now - Last) + 1 IF DaysOff < 0 THEN DaysOff = 0 IF DaysOff > 4 THEN DaysOff = 4 END IF SimDaysOff(ref, tm) = DaysOff END IF INCR i LOOP END SUB SUB LoadStadiumToList (List1() AS List1Type, choices) FileLimit = 200 REDIM List1(1 TO FileLimit) AS List1Type OPEN "STADIUM.TXT" FOR INPUT AS #1 LEN = 128 n = 1 List1(n).ListItem = "--NONE--" DO WHILE NOT EOF(1) LINE INPUT #1, rec$ rec$ = UCASE$(rec$) IF MID$(rec$, 1, 1) <> "*" THEN INCR n fn$ = MID$(rec$, 1, 20) st$ = RTRIM$(MID$(rec$, 53, 26)) cy$ = RTRIM$(MID$(rec$, 80, 20)) cr$ = RTRIM$(MID$(rec$, 100, 16)) x$ = fn$ + PADRIGHT$(st$ + ", " + cy$, 35) + cr$ List1(n).ListItem = x$ END IF LOOP CLOSE #1 choices = n END SUB SUB Logo (zS$) c1 = (ConsCols - 57) \ 2 '75 65 c2 = ConsCols - c1 r1 = (ConsRows - 21) \ 2 r2 = ConsRows - r1 IF Gfx THEN CALL GraphHole(32, r1, c1, r2, c2) CALL ShowGfx END IF 'attr = CalcAttr (7, 1) attr = dimattr CALL Drawfrm(r1, c1, r2, c2, defattr, "Copyright 1988-2008 ----------------", "", 0, 0, 0) xS$ = "David B. Schmidt" IF CODESUM(xS$) <> 1380 THEN QPRINTs r1+13, c1+19, "TAMPERING DETECTED!!!", defattr SLEEP 3000 zS$ = "Q" END IF QPRINTs r1, c1+31, xS$, defattr c = c1 + 2 r = r1 + 2 IF ConsRows = 25 THEN BeginBuffer QPRINTs r+ 5, c, " * *", attr QPRINTs r+ 6, c, " * *", attr QPRINTs r+ 7, c, " * *", attr QPRINTs r+ 8, c, " ", attr QPRINTs r+ 9, c, " * *", attr QPRINTs r+10, c, " * *", attr QPRINTs r+11, c, " * * *", attr QPRINTs r+12, c, " * * * *", attr QPRINTs r+13, c, " * * * *", attr QPRINTs r+14, c, " * SBS *", attr QPRINTs r+15, c, " * *", attr QPRINTs r+16, c, " * *", attr QPRINTs r+17, c, " *", attr QPRINTs r+19, c+14, "Version 4.9 2008.02.10", attr QPRINTs r, c+7 , " ÖÖ ÖÓÖ ÖÖ¯ ÖÖ¯ ÖÓÖ ÖÖ ÖÖ¯ Ó Ö¯ ", attr QPRINTs r+1,c+7 , " ÔÖ¯ § ÞÖÓ¬ ÞÖÖû § ÞÖÖ § Ö¯ § § ", attr QPRINTs r+2,c+7 , " ÖÖ¬ Ò Ò Ò Ò Ò Ò ÔÖÖ ÔÖÖ¬ Ò ÔÖ¬ ", attr '223 222 221 220 219 218 217 216 215 214 213 212 211 210 209 208 207 206 205 204 ' á è í š ê é ë ž ™ å â à ã ¥ Ñ Ø × Ö Þ '203 202 201 200 199 198 197 196 195 194 193 192 191 190 189 188 187 186 185 184 183 ' Ó Ò Ô € ’ Ž Ç ¶ µ · ¨ ó « ¬ ¯ § û ú '183 182 181 180 179 178 ' ú ô æ ü ý QPRINTs r+4, c+1, " êáááš êáááê êááê êáááê êáááš êáááê ê ê ", attr QPRINTs r+5, c+1, " êšššê êšššê êššš êššš êšššê êšššê ê ê ", attr QPRINTs r+6, c+1, " ê ê ê ê ê ê ê ê ê ê ê ê ", attr QPRINTs r+7, c+1, " êšššá ê ê êššê êšššê êšššá ê ê êššê êššê ", attr QPRINTs r+9, c+20, "S I M U L A T O R", attr IF ConsRows = 25 THEN EndBuffer LOCATE 1, 1 CURSOR OFF CALL ClearInpBuffer IF zS$ <> "Q" THEN zS$ = UCASE$(WAITKEY$) END SUB SUB Manage (mo, md, runner) STATIC 'May return an offensive or defensive player ON ERROR GOTO ERRORTRAP REDIM PHList(1 TO 9) AS PHType mo = 0 md = 0 runner = 0 RunnersOn = NUMBERON IF amgr(id) = FALSE THEN GOTO SU200 ' -------------------------------------------------------------- ' Defensive Maneuvers ' -------------------------------------------------------------- ' ** Shall I pull in the Infield? ** RunsAhead = itruns(id) - itruns(it) IF iout < 2 AND ir3 <> 0 THEN 'guy on 3rd IF inn <= RegInns - 3 THEN 'early in game IF ir1 = 0 OR (ir1 > 0 AND iout = 0) THEN IF (inn - RunsAhead) >= (RegInns - 3) THEN Tight = TRUE 'RunsAhead Inning ' tied 6 ' -1 5 ' -2 4 ' -3 3 ' -4 2 END IF ELSE '7th inning on: IF RunsAhead < 2 THEN Tight = TRUE END IF END IF 'SP Normal Late Inn ' ** Shall I Pitch-Out? ** ' (@+30) (@+40) IF RunsAhead <= 2 AND RunsAhead >= -4 THEN 'Not in the 9th inning if defense has a lead > 1 run IF inn > (RegInns - 1) AND ABS(RunsAhead) > 1 THEN GOTO SU100 'Find Lead Runner (if any) LR = 0 IF ir3 = 0 THEN IF ir2 = 0 THEN IF ir1 <> 0 THEN LR = ir1 ELSE LR = ir2 END IF ELSE LR = ir3 END IF 'Bail out if no appropriate lead runner IF LR = 0 OR LR = ir3 THEN GOTO SU100 'Check team and player attempt totals runref = DataRef(LR, it) POBoost = 0 IF StealAttemptsTeam(it) > 4 THEN POBoost = POBoost + 10 END IF IF StealAttemptsPlayer(runref, it) > 2 THEN POBoost = POBoost + 20 END IF IF LR = ir1 THEN IF DataSpeed(ir1, it) < 5 THEN '4 0% i = 140 ELSEIF DataSpeed(ir1, it) = 5 THEN '5 15% i = 135 ELSEIF DataSpeed(ir1, it) = 6 THEN '6 25% i = 135 ELSEIF DataSpeed(ir1, it) = 7 THEN '7 25% i = 145 ELSEIF DataSpeed(ir1, it) = 8 THEN '8 30% i = 150 ELSE '9 25% i = 165 END IF 'Limit POuts during same At-Bat i = i + BatPOut * 20 'Increase Pitchouts if limits are exceeded i = i - POBoost IF BatPOut < 2 THEN 'Will not pitch-out more than twice IF (DataSpeed(ir1, it) * 10) + FRND(100) > i THEN POut = TRUE END IF 'Late innings, close game situation: IF inn > (RegInns - 2) AND ABS(RunsAhead) < 2 THEN IF DataSpeed(ir1, it) > 5 THEN IF BatPOut < 2 AND FRND(10) > 5 THEN POut = TRUE END IF END IF END IF IF LR = ir2 THEN 'Pitchout when trying to steal third? 'Not gonna steal/PO 3rd with potential winning run IF RunsAhead = 0 AND inn > (RegInns - 2) THEN GOTO SU100 IF iout = 0 THEN i = 160 IF iout = 1 THEN i = 140 IF iout = 2 THEN i = 180 IF UCASE$(DataHand(ip, id)) = "R" THEN i = i + 20 'Limit POuts during same At-Bat i = i + BatPOut * 20 'Increase Pitchouts if limits are exceeded i = i - POBoost IF BatPOut < 2 THEN 'Will not pitch-out more than twice IF (DataSpeed(ir2, it) * 10) + FRND(100) > i THEN POut = TRUE END IF END IF END IF SU100: ' ** Shall I Pass this guy? ** ' [Check for Desperate Situation - Message and Walk Switch] ' Home team batting in the ninth or later with score tied and ' winning run on third with less than two out IF inn >= RegInns AND it = 2 THEN IF RunsAhead = 0 THEN IF iout < 2 THEN IF ir3 > 0 AND (ir1 = 0 OR ir2 = 0) THEN IWalk = TRUE IF DelFac THEN AddToAnnouncer id, "A tense situation now!" AddToAnnouncer id, "They're gonna load 'em up!" END IF INCR zzziwalk1 GOTO CheckPitcher END IF END IF END IF END IF ' Other Intentional Walk Situations IF inn >= (RegInns - 3) THEN IF ir1 = 0 AND (ir2 > 0 OR ir3 > 0) THEN IF RunsAhead < 6 THEN IF RunsAhead > RunnersOn + 1 THEN 'Won't put tying run on base i = ib + 1 IF i > 9 THEN i = 1 IF DataPos(i, it) = 1 THEN 'If we're thinking about getting to the pitcher xF! = .06 'No. 8 guy has to be pretty good ELSE xF! = .04 'Not so strict about getting to other players END IF IF RND < .8 THEN IF HITRATING!(ib, it) - HITRATING!(i, it) > xF! THEN IWalk = TRUE 'gonna pitch around * 'to get to @ IF DelFac THEN CALL Msg ("29", "0", "0", "18", ib, it, man2, team2) CALL Msg ("29", "0", "0", "19", i, it, man2, team2) END IF IF xF! > .059 THEN INCR zzziwalk2 ELSE INCR zzziwalk3 END IF END IF END IF END IF END IF END IF '** Check Bullpen status ** CheckPitcher: CALL CountAvPitchers (id, Av, LastGuy) '(The current pitcher is not counted) IF Av < 1 THEN GOTO SU200 'A Bullpen pitcher is available...check on your current pitcher IF PitchersPerGame(id) < 2.5 THEN i = 11 - (2 * PitchersPerGame(id)) IF PitchersPerGame(id) < 1.2 THEN i = 10 j = i - 2 k = i - 3 ELSE i = 5 j = 3 k = 2 END IF 'If given up 5+ runs in less than his first 2 innings of work get the hook: IF mpr(ip, id) > i - 1 AND mpo(ip, id) < 6 THEN BullD = TRUE IF np(id)=1 THEN INCR RemoveReason(1) GOTO SU999 END IF 'Get hook if given up 7-8+ runs IF mpr(ip, id) + INT(RunnersOn / 2) > (i + 2) THEN BullD = TRUE IF np(id)=1 THEN INCR RemoveReason(2) GOTO SU999 END IF IF RunnersOn + 6 > ABS(RunsAhead) THEN 'was +4 IF np(id) = 1 THEN 'Starter is still in the game 'Starter is gone if gives up: 'Normal: Old-Time: 'Runs On-Base Runs On-Base ' 6+ nobody on 7+ nobody on ' 5 2+on 6 2+on IF mpr(ip, id) + INT(RunnersOn / 2) > i THEN BullD = TRUE INCR RemoveReason(3) GOTO SU999 END IF ELSE 'Reliever in 1st 5 innings gone if gives up: 'Runs On-Base ' 3+ 2-on or loaded IF inn < 6 THEN IF mpr(ip, id) + INT(RunnersOn / 2) > j THEN BullD = TRUE: GOTO SU999 ELSE 'Reliever in 6th inning or later gone if gives up: 'Runs On-Base ' 2+ 2-on or loaded IF mpr(ip, id) + INT(RunnersOn / 2) > k THEN BullD = TRUE: GOTO SU999 END IF END IF END IF 'Have we over-extended the current pitcher? 'Only check at start of an inning (sort of) 'The bigger FatRnd is, the more durable the pitcher IF iout = 0 AND RunnersOn = 0 THEN IF ithits(it) > 1 THEN IF itruns(it) > 0 THEN IF DataGames(ip, id) THEN IF nPitch(id) > ExpectedPitchCount(ip, id) * FatRnd(id) THEN BullD = TRUE IF np(id)=1 THEN INCR RemoveReason(4) GOTO SU999 END IF END IF END IF END IF END IF 'Cut down on complete games IF Av > 2 THEN 'Reliver Available IF PitcherBatted(id) = FALSE THEN 'Pitcher didn't bat last inning IF inn = 8 AND iout = 0 AND RunnersOn = 0 THEN 'Beginning of 8th inning IF np(id) = 1 THEN 'Starter still in game IF DataGames(ip, id) THEN IF nPitch(id) > .90 * ExpectedPitchCount(ip, id) THEN IF ithits(it) > 2 THEN x! = PitchersPerGame(id) CG_Per_162GSeason! = 330.17 - 206.33*x! + 42.39*x!*x! - 2.84*x!*x!*x! y! = CG_Per_162GSeason! / 162 y! = 1.0 - y! 'Chance of NOT pitching a complete game IF y! < .01 THEN y! = .01 IF y! > .99 THEN y! = .99 IF RND < (y! / 2.2) THEN 'Remove pitcher % of the time! BullD = TRUE INCR RemoveReason(5) GOTO SU999 END IF END IF END IF END IF END IF END IF END IF END IF 'Bring in the closer in the late innings? 'Closer must not already be pitching 'Closer must be available IF inn > 7 THEN 'Old-Style managers are not concerned with "closers", so we make up 'some criteria to decide if we want to look for a closer IF PitchersPerGame(id) > 2.1 AND HiSaves(id) > 9 AND LastPiAd(id) > 16 THEN IF CloserIn(id) = FALSE THEN 'Is this a Closer-Situation? 'Do not pull a pitcher with no-hitter or 1-hitter 'Defense must be between tied and 3 runs ahead '8th inning: 2-3 run lead and tying run on base '9+ inning: tied; runner on; at least one out: 20 chance for closer ' 1-3 run lead; tying run at plate or at start of inning ClsSit = FALSE IF ithits(it) > 1 THEN IF RunsAhead > -1 AND RunsAhead < 4 THEN x! = RND IF StrictCloserRule THEN IF inn > 8 AND RunsAhead > 1 AND ( (RunnersOn + 2 > RunsAhead) OR (iout = 0 AND RunnersOn = 0 AND x! < (1.0 - .10 * RunsAhead) ) ) THEN ClsSit = TRUE IF inn > 8 AND RunsAhead = 1 AND ( (RunnersOn + 1 > RunsAhead) OR (iout = 0 AND RunnersOn = 0 AND x! < (1.0 - .10 * RunsAhead) ) ) THEN ClsSit = TRUE ELSE IF inn = 8 AND RunsAhead > 1 AND ( (RunnersOn + 2 > RunsAhead) AND iout > 0 AND mpo(ip, id) > 1 AND x! < .8) THEN ClsSit = TRUE IF inn = 8 AND RunsAhead = 1 AND ( (RunnersOn + 1 > RunsAhead) AND iout > 0 AND mpo(ip, id) > 1 AND x! < .8) THEN ClsSit = TRUE IF inn > 8 AND RunsAhead > 1 AND ( (RunnersOn + 2 > RunsAhead) OR (iout = 0 AND RunnersOn = 0 AND x! < (1.0 - .10 * RunsAhead) ) ) THEN ClsSit = TRUE IF inn > 8 AND RunsAhead = 1 AND ( (RunnersOn + 1 > RunsAhead) OR (iout = 0 AND RunnersOn = 0 AND x! < (1.0 - .10 * RunsAhead) ) ) THEN ClsSit = TRUE IF inn > 8 AND RunsAhead = 0 AND RunnersOn > 0 AND x! < .3 THEN ClsSit = TRUE END IF 'Turn indicator off for shutouts unless opponent is knocking at the door IF itruns(it) = 0 AND np(id) = 1 AND RunnersOn - 1 < RunsAhead THEN ClsSit = FALSE 'Turn indicator off if pitcher batted last inning. 'Manager would look dumb if he brought in a closer now. IF PitcherBatted(id) = TRUE AND (iout + RunnersOn) < 2 THEN ClsSit = FALSE IF ClsSit = TRUE THEN 'This code doesn't check for the possibility of a duplicate- 'name problem, but CountAvPitchers guarantees that SOMEONE is 'available. IF NewStyleWithSaves(id) THEN 'Somebody with "Saves" available? AvCls = 0 FOR i = 10 TO LastPiAd(id) IF i <> ip AND iused(i, id) = 0 AND DataCS(i, id) > 0 THEN IF SimDaysOff(i, id) = 0 OR DaysOffRule = FALSE THEN INCR AvCls END IF END IF NEXT IF AvCls THEN BullD = TRUE GOTO SU999 END IF ELSE j = MIN&(15, LastPiAd(id)) 'usually 15 unless not that many pitchers IF iused(j, id) = 0 AND ip <> j THEN IF SimDaysOff(j, id) = 0 OR DaysOffRule = FALSE THEN BullD = TRUE GOTO SU999 END IF END IF END IF END IF END IF END IF END IF END IF END IF '10 inning limit IF mpo(ip, id) > 29 THEN BullD = TRUE: GOTO SU999 ' ------------------------------------------------------------ ' Offensive Maneuvers ' ------------------------------------------------------------ SU200: IF amgr(it) = FALSE THEN GOTO SU999 RunsBehind = itruns(id) - itruns(it) RunsAhead = itruns(it) - itruns(id) RealPitcherUp = FALSE IF DataPos(ib, it) = 1 THEN LastRealPitcher$ = DataName(iyp(np(it), it), it) IF DataName(ib, it) = LastRealPitcher$ THEN RealPitcherUp = TRUE END IF END IF ' ** Consider a Pinch Hitter ** ' Conditions to consider a pinch hitter: ' RunsBehind + Inning + RunnersOn - Outs > 7 ' Weak hitter ' Available hitters on bench ' Another pitcher available if pinch-hitting for pitcher 'Is your pitcher up now? Make sure its a real pitcher and not a pinch-hitter already... PullPitcher = FALSE 'IF DataPos(ib, it) = 1 AND DataRef(ib, it) <= LastPiAd(it) THEN IF RealPitcherUp THEN 'Are there any more pitchers? CALL CountAvPitchers (it, Av, LastGuy) IF Av < 1 THEN GOTO SU250 'No more pitchers -- cannot Pinch hit! IF ithits(id) = 0 THEN GOTO SU250 'No-hitter going! -- don't do it! 'Are you going to pull him at the start of the next inning anyway? 'Compare outs recorded by the pitcher this game with his average 'outs recorded per game. If he has exceeded them by 40 (starter) 'or 25 (reliever) he will be pulled the next inning unless he's 'a starter working on a no-hitter j = ipa(it) 'PH for him because he'll be over-extended next inning: IF DataGames(j, it) THEN IF nPitch(it) + 7 > ExpectedPitchCount(j, it) * FatRnd(it) THEN PullPitcher = TRUE END IF END IF 'PH for him if likelyhood of C.G is low and starter is still in IF inn = (RegInns - 2) THEN '7th inn IF np(it) = 1 THEN x! = PitchersPerGame(it) CG_Per_162GSeason! = 330.17 - 206.33*x! + 42.39*x!*x! - 2.84*x!*x!*x! y! = CG_Per_162GSeason! / 162 y! = 1.0 - y! 'Chance of NOT pitching a complete game IF y! > .99 THEN y! = .99 IF RND < (y! / 2.2) THEN PullPitcher = TRUE INCR RemoveReason(6) END IF END IF END IF 'PH for him if he'll probably be lifted for the closer next inning anyway: IF PitchersPerGame(it) > 2.1 AND LastPiAd(it) > 16 AND HiSaves(it) > 9 THEN IF CloserIn(it) = FALSE THEN 'He's not the closer IF inn > (RegInns - 2) THEN '8th inn or more IF RunsAhead > -1 AND RunsAhead < 4 THEN '0 - 3 ahead IF mpo(j, it) > 0 THEN 'Retired at least 1 batter PullPitcher = TRUE IF np(it) = 1 THEN INCR RemoveReason(7) END IF END IF END IF END IF END IF 'Change my mind sometimes: 'If starter is still in, go ahead and try for a shutout IF np(it) = 1 THEN IF mpo(j, it) < 27 THEN IF itruns(id) = 0 AND RunsAhead > 0 THEN PullPitcher = FALSE END IF END IF END IF IF inn > RegInns THEN Inning = RegInns ELSE Inning = inn 'Give more "weight" for runners in scoring position iOn = RunnersOn IF iOn = 1 THEN IF ir2 OR ir3 THEN iOn = 2 END IF 'We rarely pinch-hit for the pitcher in old-time scenarios IF RealPitcherUp AND PitchersPerGame(it) < 2.5 THEN i = 11 - (3 * PitchersPerGame(it)) j = 2 * PitchersPerGame(it) - 2.3 ' - 3 ELSE i = 2 j = 2 END IF IF (Inning > i AND (RunsBehind + Inning + iOn - iout > (RegInns - j))) OR PullPitcher THEN 'Are there any pinch hitters available on the bench? 'Build list of eligible hitters with their rating - pay attention to defense Av = 0 Def1 = DataPos(ib, it) 'Batter's defensive position FOR i = LastPiAd(it) + 1 TO MAXPLAYERS 'Scan each player on bench IF DataName(i, it) > "!" THEN 'If bench-player's name is non-blank IF iused(i, it) = FALSE THEN 'If bench-player hasn't been in the game IF DataRef(i, it) > LastPiAd(it) OR DataRef(i, it) < 10 THEN 'Bench player's a non-pitcher 'Is potential PH's name identical to the current or previously used pitcher? ie = 0 FOR ii = 1 TO np(it) IF DataName(i, it) = DataName(iyp(ii, it), it) THEN ie = -1 NEXT 'If NOT PH'ing for the pitcher, is the candidate also the last 'available pitcher (if cloned pitchers are involved)? IF DupNameTeam(it) THEN IF Def1 <> 1 THEN CALL CountAvPitchers(it, AvP, LastGuy) IF AvP = 1 AND DataName(LastGuy, it) = DataName(i, it) THEN ie = -1 END IF END IF END IF IF ie = 0 THEN IF DataGbyP(i, it, 1) > 0 AND DataPosi(i, it, 1) > 0 THEN 'strict SELECT CASE Def1 CASE 1, 10 GOSUB AddToPHList 'If current batter is pitcher, anyone will do CASE ELSE 'Otherwise only add similar defensive players IF FoundPosition(Def1, i, it) THEN GOSUB AddToPHList END SELECT ELSE 'old style - we're not so strict SELECT CASE Def1 CASE 1 GOSUB AddToPHList 'If current batter is pitcher, anyone will do CASE 2 IF DataPos(i, it) = 2 THEN GOSUB AddToPHList CASE 3 IF DataPos(i, it) = 3 OR DataPos(i, it) = 5 THEN GOSUB AddToPHList CASE 4 IF DataPos(i, it) = 4 OR DataPos(i, it) = 6 THEN GOSUB AddToPHList CASE 5 IF DataPos(i, it) = 5 OR DataPos(i, it) = 6 THEN GOSUB AddToPHList CASE 6 IF DataPos(i, it) = 6 THEN GOSUB AddToPHList CASE 7 TO 9 IF DataPos(i, it) > 6 AND DataPos(i, it) < 10 THEN GOSUB AddToPHList CASE 10 GOSUB AddToPHList CASE ELSE END SELECT END IF END IF END IF END IF END IF NEXT IF Av > 0 THEN 'If the list is not empty 'Sort the PH List by the hitting rating ARRAY SORT PHList(1) FOR Av, FROM 1 TO 4, DESCEND 'Convert top PH candidate's rating back to float highF! = VAL(PHList(1).Criteria1) / 1000 'Compute Rating for our current hitter in the lineup xF! = HITRATING!(ib, it) 'Set a threshhold value for our next equation based on 'the current inning. If its early in the game make the value 'higher so not many pinch hitters will occur SELECT CASE inn CASE 1 TO 3 yF! = .205 '.155 CASE 4 yF! = .165 '.135 CASE 5 yF! = .155 CASE 6 yF! = .145 CASE 7 yF! = .135 CASE ELSE IF RealPitcherUp THEN yF! = .040 ELSE yF! = .070 END IF END SELECT 'If our potential PH's hit-rating is greater than the current hitter's 'hit-rating by the threshhold value, or we're going to pull the pitcher 'anyway, go ahead and pinch hit IF (highF! - xF! > yF!) OR PullPitcher THEN 'We know there are good hitters on the bench but now 're-sort giving boost to low AB/Game Ratio, R/L, and place in .DAT ARRAY SORT PHList(1) FOR Av, FROM 5 TO 8, DESCEND 'Usually pick the top candidate but sometimes the 2nd or 3rd guy zF! = RND IF Av = 1 THEN i = 1 ELSEIF Av = 2 THEN IF zF! < .75 THEN i = 1 ELSE i = 2 ELSE IF zF! < .70 THEN i = 1 ELSEIF zF! < .85 THEN i = 2 ELSE i = 3 END IF END IF PH = TRUE mo = PHList(i).Slot IF RealPitcherUp AND np(it) = 1 THEN INCR RemoveReason(8) INCR zzzPH GOTO SU999 END IF END IF END IF SU250: 'If we did *not* PH for pitcher, mark it. IF RealPitcherUp THEN PitcherBatted(it) = TRUE ' ** Shall I Bunt? ** IF DataPos(ib, it) = 1 THEN 'Pitcher Bunts almost all the time 'Make sure its an actual pitcher, not a PH IF RealPitcherUp THEN IF ir3 = 0 AND ir1 <> 0 AND iout < 2 AND RND < .80 THEN IF inn < (RegInns - 1) OR RunsBehind < 2 THEN Bunt = TRUE: GOTO SU999 END IF END IF ELSE GOTO SU260 'Pinch-hitters for pitcher don't bunt END IF ELSE 'Non-Pitcher IF ir3 = 0 AND ir1 <> 0 THEN ' 3 ' .4 IF iout = 0 AND ABS(RunsBehind) < 2 AND DataHR(ib, it) < 20 AND inn > (RegInns - 3) AND RND < .7 THEN Bunt = TRUE: GOTO SU999 'Normal Bunt Situation END IF END IF END IF 'Anyone can try a squeeze IF ir3 <> 0 AND ir2 = 0 THEN IF iout = 1 AND ABS(RunsBehind) < 2 AND DataHR(ib, it) < 20 AND RND < .25 THEN Bunt = TRUE: GOTO SU999 'Try Squeeze Play END IF END IF SU260: ' ** Shall I ATTEMPT a Steal? ** IF ir3 = 0 AND ir2 = 0 AND ir1 = 0 THEN GOTO SU270 'Nobody on IF ir3 <> 0 AND ir2 <> 0 THEN GOTO SU270 '2nd & 3rd or loaded IF ir3 <> 0 AND ir2 = 0 AND ir1 = 0 THEN GOTO SU270 '3rd only ' That leaves only four possible steal situations: ' 1st base only ' 2nd base only ' 1st & 2nd ' 1st & 3rd IF ir2 THEN IL = ir2 ELSE IL = ir1 'Lead runner (for steal) 'Reject: IF IL = ir2 AND iout <> 1 THEN GOTO SU265 'Only try to steal 3rd with 1 out IF IL = ir2 AND RunsBehind = 0 AND inn > (RegInns - 2) THEN GOTO SU270 'don't risk stealing 3rd with potential winning run IF RunsBehind > 2 THEN GOTO SU270 'Behind by 3 or more (10/2/99) IF RunsAhead > 4 THEN GOTO SU270 'Ahead by more than 4 IF RunsBehind > 1 AND inn > (RegInns - 2) THEN GOTO SU270 'Don't steal in late innings if behind by 2 or more 'Don't steal if pitcher is up and 0 or 2 out IF RealPitcherUp AND iout <> 1 THEN GOTO SU270 IF ib < 9 THEN nxt = ib + 1 ELSE nxt = 1 'Don't steal if pitcher is next unless it's very late in game IF DataPos(nxt, it) = 1 AND inn < (RegInns - 1) THEN GOTO SU270 'Determine SB Attempts 'a. No CS data IF DataCS(IL, it) = 0 THEN i = DataSpeed(IL, it) IF i = 1 THEN yF! = .01 IF i = 2 THEN yF! = .03 IF i = 3 THEN yF! = .06 IF i = 4 THEN yF! = .09 IF i = 5 THEN yF! = .12 IF i = 6 THEN yF! = .16 IF i = 7 THEN yF! = .22 IF i = 8 THEN yF! = .30 IF i = 9 THEN yF! = .42 ELSE 'b. Have SB/CS data singles = DataHits(IL, it) - DataHR(IL, it) - Data2B(IL, it) - Data3B(IL, it) IF singles = 0 THEN singles = 1 yF! = (DataSB(IL, it) + DataCS(IL, it)) / (singles + DataBB(IL, it)) 'Be more aggressive with 8 and 9's i = DataSpeed(IL, it) IF i = 7 THEN yF! = yF! * 1.05 IF i = 8 THEN yF! = yF! * 1.10 IF i = 9 THEN yF! = yF! * 1.15 END IF 'If runner is a pitcher, cut attempts IF DataPos(IL, it) = 1 THEN yF! = yF! * .33 'Cut down prob. of attempting to steal 3rd, etc. IF ir2 <> 0 THEN IF UCASE$(DataHand(ip, id)) = "R" THEN yF! = yF! * .20 ELSE yF! = yF! * .80 END IF ELSEIF UCASE$(DataHand(ip, id)) = "L" THEN yF! = yF! * .40 ELSE yF! = yF! * 1.1 '1.03 1.01 1.04 1.25 1.15 1.35 1.30 .90 .80 .85 END IF 'Raise probability of steal attempt in late innings of close games with a good runner IF inn > (RegInns - 2) AND ABS(RunsBehind) < 2 AND yF! > .25 THEN yF! = yF! * 1.5 IF RND < yF! THEN Steal = TRUE IF DataPos(IL, it) = 1 THEN INCR zzsabp GOTO SU999 END IF SU265: ' ** Hit and Run ' The "reject" rules on stolen bases apply here too. (Branched to SU270) IF ir1 <> 0 THEN IF ir3 = 0 THEN IF iout < 2 THEN IF ir2 THEN IL = ir2 ELSE IL = ir1 'Lead runner (for steal) IF DataSpeed(IL, it) > 3 THEN yF! = (DataAB(ib, it) - DataHR(ib, it) - DataSO(ib, it)) / DataAB(ib, it) xF! = RND IF Year(it) < "1920" THEN zF! = .15 ELSE zF! = 0 IF yF! > .90 THEN IF xF! > .65 + zF! THEN HitAndRun = TRUE '.60 ELSEIF yF! > .80 THEN IF xF! > .80 + zF! THEN HitAndRun = TRUE '.75 ELSEIF yF! > .70 THEN IF xF! > .90 + zF! THEN HitAndRun = TRUE '.90 END IF END IF END IF END IF END IF SU270: ' ** Consider a Pinch Runner (for some combination of baserunners) ** IF inn > RegInns - 3 THEN IF ABS(RunsBehind) < 3 THEN 'was < 4 LL = 100 runner = 0 IF ir1 <> 0 AND ir2 = 0 THEN runner = ir1 IF ir1 <> 0 AND ir2 <> 0 THEN runner = ir2 IF ir1 = 0 AND ir2 <> 0 THEN runner = ir2 IF runner THEN 'Are there any pinch runners available on the bench? 'Find eligible players - pay attention to defense - save fastest SaveFastest = 0 SaveI = 0 Def1 = DataPos(runner, it) 'runner's current defensive position IF Def1 <> 1 THEN 'No running for pitchers 'Scan each player on bench FOR i = LastPiAd(it) + 1 TO MAXPLAYERS 'Scan each player on bench IF DataName(i, it) > "A" THEN 'If bench-player's name is non-blank IF iused(i, it) = FALSE THEN 'If bench-player hasn't been in the game IF DataRef(i, it) > LastPiAd(it) OR DataRef(i, it) < 10 THEN 'Bench-player is a non-pitcher 'Fix 2/23/05 'Is potential PH's name identical to the current or previously used pitcher? OK1 = TRUE FOR ii = 1 TO np(it) IF DataName(i, it) = DataName(iyp(ii, it), it) THEN OK1 = FALSE NEXT 'Is the candidate also the last available pitcher '(if cloned pitchers are involved)? IF OK1 THEN OK2 = TRUE IF DupNameTeam(it) THEN CALL CountAvPitchers(it, AvP, LastGuy) 'LastGuy is a pitcher's number 'Does his name match the candidate's name? IF AvP = 1 AND DataName(LastGuy, it) = DataName(i, it) THEN OK2 = FALSE END IF END IF END IF IF OK1 AND OK2 THEN IF DataSpeed(i, it) - DataSpeed(runner, it) >= 3 THEN 'Found a faster guy 'Does he play the correct position? OK = FALSE FOR ii = 1 TO 4 IF DataPosi(i, it, ii) = Def1 THEN OK = TRUE: EXIT FOR NEXT IF OK THEN IF DataSpeed(i, it) > SaveFastest THEN SaveFastest = DataSpeed(i, it) SaveI = i END IF END IF END IF END IF END IF END IF END IF NEXT END IF IF SaveI > 0 THEN 'The fastest elegible player IF RND < .80 THEN '2007 - reduce pinching-running by manager slightly PRun = TRUE mo = SaveI GOTO SU999 END IF END IF END IF END IF END IF GOTO SU999 AddToPHList: 'in:[i] 'Uses n, xF!, h$, zF! IF Av < 9 THEN '1. Hit-rating xF! = HITRATING!(i, it) INCR Av PHList(Av).Criteria1 = FLOAT2STR$(xF!) '2. Boost hitters with lots of "unaccounted" games IF DataGames(i, it) > 0 AND DataAB(i, it) > 40 THEN GamesAllPos = 0 FOR n = 1 TO 4 '4 possible games by position IF DataPosi(i, it, n) > 1 THEN GamesAllPos = GamesAllPos + DataGbyP(i, it, n) END IF NEXT IF GamesAllPos > 0 THEN zF! = ((DataGames(i, it) - GamesAllPos) / DataGames(i, it)) / 5 IF zF! > .040 THEN zF! = .040 'bracket added 2008 xF! = xF! + zF! END IF END IF '3. Boost hitters who are either switch hitters or opposite hand from pitcher h$ = DataHand(i, it) IF h$ = "S" OR h$ = "B" OR h$ <> UCASE$(DataHand(ip, id)) THEN xF! = xF! + .060 ' + .030 END IF '4. Give preference to first three listed on the bench in .DAT IF DataRef(i, it) > LastPiAd(it) AND DataRef(i, it) < LastPiAd(it) + 4 THEN xF! = xF! + .030 ' + .040 END IF PHList(Av).Criteria2 = FLOAT2STR$(xF!) PHList(Av).Slot = i END IF RETURN ErrorTrap: LOCATE 10, 30 PRINT "ERROR: Manage "; ERRCLEAR LOCATE 11, 30 PRINT "Av:";Av;"i:";i;"it:";it;"id:";id;"ip:";ip; x$ = WAITKEY$ SU999: END SUB SUB MoreOptionsIO (row, Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) IF MenuOpt$ = "T" THEN r = row + 12 ELSE r = row + 16 CALL Drawfrm(row+rowO, 21+colO, r+rowO, 63+colO, defattr, "More Simulation Options", "ESC (or close window) to Continue", 1, 0, 1) DATA 02,23,"Cross-Era Normalization [YYYYL] ",02,57,05,"X " DATA 04,23,"Performance Focusing? [y/N] ",04,57,01,"XR" DATA 06,23,"Pause after every game? [y/N] ",06,57,01,"XR" DATA 08,23,"Pause after date change? [y/N] ",08,57,01,"XR" DATA 10,23,"Delay Factor [0-7] ",10,57,01,"N " DATA 12,23,"Auto-Lineup? [Y/n] ",12,57,01,"XR" DATA 14,23,"Optimize Batting Order? [Y/n/c] ",14,57,01,"XR" IF MenuOpt$ = "T" THEN Flds = 5 ELSE Flds = 7 c = 1 FOR i = 1 TO Flds Flitrow(i) = VAL(READ$(c)) + row + rowO Flitcol(i) = VAL(READ$(c+1)) + colO Flit$(i) = READ$(c+2) Frow(i) = VAL(READ$(c+3)) + row + rowO Fcol(i) = VAL(READ$(c+4)) + colO Flen(i) = VAL(READ$(c+5)) Fed$(i) = READ$(c+6) c = c + 7 NEXT 'Set Defaults REDIM FContents$(13) FContents$(1) = "" IF MenuOpt$ = "T" THEN IF Year(1) <> Year(2) THEN 'Batter Normalization FContents$(1) = "H" END IF END IF FContents$(2) = "N" FContents$(3) = "N" FContents$(4) = "N" FContents$(5) = "0" FContents$(6) = "Y" FContents$(7) = "Y" IF MenuOpt$ <> "S" THEN Flen(4) = -1 IF LEN(CmdFavTeam$) THEN Flen(4) = -1 IF LEN(CmdFavLeague$) THEN Flen(4) = -1 IF CmdStat$ < "!" THEN Flen(2) = -1 CursorPtr = 1 DO MoreOptLoop: CALL ScreenIO(Keyed, KeyF3, 0, KeyEsc, Flds, CursorPtr, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) IF Keyed = KeyF3 THEN EXIT SUB END IF 'Edit Field Contents Error1$ = "N" x$ = RTRIM$(FContents$(1)) y$ = "Response must be [H, V, B] or [####L] where ####=Year L=League" LL = LEN(x$) IF LL = 1 THEN IF x$ <> "H" AND x$ <> "V" AND x$ <> "B" THEN CALL PopMsg (row+3+rowO, 7+colO, y$, errattr, 5, kc) Error1$ = "Y": CursorPtr = 1: GOTO MoreOptLoop END IF END IF IF LL = 5 THEN x1$ = MID$(x$, 1, 4) x2$ = MID$(x$, 5, 1) IF NUMERIC(x1$, 0, 0) AND (x2$ >= "A" AND x2$ <= "Z") THEN ELSE CALL PopMsg (row+3+rowO, 7+colO, y$, errattr, 5, kc) Error1$ = "Y": CursorPtr = 1: GOTO MoreOptLoop END IF END IF IF LL > 1 AND LL < 5 THEN CALL PopMsg (row+3+rowO, 7+colO, y$, errattr, 5, kc) Error1$ = "Y": CursorPtr = 1: GOTO MoreOptLoop END IF IF INSTR("YN", FContents$(2)) = 0 THEN Error1$ = "Y" CursorPtr = 2 GOTO MoreOptLoop END IF IF INSTR("YN", FContents$(3)) = 0 THEN Error1$ = "Y" CursorPtr = 3 GOTO MoreOptLoop END IF IF INSTR("YN", FContents$(4)) = 0 THEN Error1$ = "Y" CursorPtr = 4 GOTO MoreOptLoop END IF IF INSTR("0123456789", FContents$(5)) = 0 THEN Error1$ = "Y" CursorPtr = 5 GOTO MoreOptLoop END IF IF INSTR("YN", FContents$(6)) = 0 THEN Error1$ = "Y" CursorPtr = 6 END IF IF INSTR("YNC", FContents$(7)) = 0 THEN Error1$ = "Y" CursorPtr = 7 END IF LOOP WHILE Error1$ = "Y" CmdEra$ = RTRIM$(FContents$(1)) CmdFocus$ = FContents$(2) CmdPauseAftGame$ = FContents$(3) CmdPauseAftDate$ = FContents$(4) DelFac = VAL(FContents$(5)) OrgSimDelFac = DelFac IF MenuOpt$ <> "T" THEN AutoLineupSw(1) = (FContents$(6) = "Y") AutoLineupSw(2) = AutoLineupSw(1) AdjustBO(1) = FContents$(7) AdjustBO(2) = AdjustBO(1) END IF END SUB SUB MovePitHitStats (pl, tm) IF pl < 1 OR pl > MAXPLAYERS OR tm < 1 OR tm > 2 THEN BEEP EXIT SUB END IF r = ipa(tm) DataRef(pl, tm) = r 'Pitcher's address takes over reference number DataPos(pl, tm) = 1 DataName(pl, tm) = DataName(r, tm) 'Does pitcher's name exist on bench? SearchName$ = DataName(pl, tm) n = SearchDAT (LastPiAd(tm)+1, MAXPLAYERS, tm, SearchName$, 0) IF n THEN CALL CopyStats(n, pl, tm) EXIT SUB END IF DataAB(pl, tm) = 100 xS$ = UCASE$(DataCode(r, tm)) code = ASC(xS$) - 64 IF code < 1 OR code > 5 THEN IF RND < .5 THEN DataHits(pl, tm) = 16 ELSE DataHits(pl, tm) = 17 END IF ELSE DataHits(pl, tm) = 30 - (5 * code) END IF '1 A = .250 '2 B = .200 '3 C = .150 or .165 '4 D = .100 '5 E = .050 DataHR(pl, tm) = DataHits(pl, tm) * .025 DataSO(pl, tm) = 49.1 - DataHits(pl, tm) * 0.9 DataBB(pl, tm) = 5 IF DataPBatAB(r, tm) > 0 THEN DataAB(pl, tm) = DataPBatAB(r, tm) DataHits(pl, tm) = DataPBatHi(r, tm) DataHR(pl, tm) = DataPBatHR(r, tm) DataBB(pl, tm) = DataPBatBB(r, tm) DataSO(pl, tm) = DataPBatSO(r, tm) END IF Data2B(pl, tm) = DataHits(pl, tm) * .14 Data3B(pl, tm) = DataHits(pl, tm) * .02 DataRBI(pl, tm) = DataHits(pl, tm) / 2.4 IF DataHand(ipa(tm), tm) = "r" THEN DataHand(pl, tm) = "L" ELSEIF DataHand(ipa(tm), tm) = "l" THEN DataHand(pl, tm) = "R" ELSE DataHand(pl, tm) = DataHand(ipa(tm), tm) END IF DataDef(pl, tm) = 0 DataSB(pl, tm) = 1 'was 3 DataCS(pl, tm) = 1 'was 2 DataSpeed(pl, tm) = 3 FOR i = 1 TO 4 DataPosi(pl, tm, i) = 0 DataGByP(pl, tm, i) = 0 NEXT END SUB SUB MovePtrVisi (param$, row, col) QPRINTs row + VisiPtr, col, " ", defattr IF param$ = "U" THEN IF VisiPtr > 1 THEN DECR VisiPtr IF it = 1 THEN IF VisiPtr = 7 THEN DECR VisiPtr IF WarmUpRule = FALSE THEN IF VisiPtr = 6 THEN DECR VisiPtr END IF ELSE IF VisiPtr = 7 THEN DECR VisiPtr END IF ELSEIF param$ = "D" THEN IF it = 1 THEN IF VisiPtr < 10 THEN INCR VisiPtr IF WarmUpRule = FALSE THEN IF VisiPtr = 6 THEN INCR VisiPtr END IF IF VisiPtr = 7 THEN INCR VisiPtr ELSE IF VisiPtr < 11 THEN INCR VisiPtr IF VisiPtr = 7 THEN INCR VisiPtr END IF END IF QPRINTs row + VisiPtr, col, CHR$(175), defattr END SUB SUB MovePtrHome (param$, row, col) QPRINTs row + HomePtr, col, " ", defattr IF param$ = "U" THEN IF HomePtr > 1 THEN DECR HomePtr IF it = 2 THEN IF HomePtr = 7 THEN DECR HomePtr IF WarmUpRule = FALSE THEN IF HomePtr = 6 THEN DECR HomePtr END IF ELSE IF HomePtr = 7 THEN DECR HomePtr END IF ELSEIF param$ = "D" THEN IF it = 2 THEN IF HomePtr < 10 THEN INCR HomePtr IF WarmUpRule = FALSE THEN IF HomePtr = 6 THEN INCR HomePtr END IF IF HomePtr = 7 THEN INCR HomePtr ELSE IF HomePtr < 11 THEN INCR HomePtr IF HomePtr = 7 THEN INCR HomePtr END IF END IF QPRINTs row + HomePtr, col, CHR$(175), defattr END SUB SUB Msg (c$, p$, s$, t$, man, team, man2, team2) STATIC 'Retrieve specified message, enhance with name, add to Announcer 'STATIC work$, xS$, fS$ DIM MsgList$(15) Find$ = c$ + p$ + s$ + t$ + "001" CALL SearchPbyP (PbyP(), 1, 9, 1, PbyP_Cnt, Find$, FoundAt, mini) IF FoundAt = 0 THEN work$ = "PbyP not found:" + Find$ GOTO MessagAdd END IF 'We have found the first message, now get the rest of them i = FoundAt j = 0 DO INCR j IF j < 16 THEN MsgList$(j) = PbyP(i).text OldStuff$ = PbyP(i).class + PbyP(i).pos + PbyP(i).seq + PbyP(i).trk INCR i IF i <= PbyP_Cnt THEN NewStuff$ = PbyP(i).class + PbyP(i).pos + PbyP(i).seq + PbyP(i).trk ELSE EXIT DO END IF LOOP WHILE NewStuff$ = OldStuff$ n = RND(1, j) work$ = MsgList$(n) IF DelFac = 0 AND amgr(1) AND amgr(2) THEN GOTO MessagAdd hh = INSTR(work$, "@") 'full name ii = INSTR(work$, "*") 'last name jj = INSTR(work$, "#") 'position kk = 0 IF (ii > 0 OR hh > 0) AND man > 0 THEN xS$ = LASTNAME$(DataName(man, team)) 'Last name now in xS$ 'Stick first name in front of it for special cases @ j = INSTR(DataName(man, team), ",") IF hh > 0 AND j > 0 THEN xS$ = FULLNAME$(DataName(man, team)) END IF IF hh THEN kk = hh IF ii THEN kk = ii END IF IF jj > 0 THEN xS$ = PosDesc(WhoAtPos) kk = jj END IF IF kk > 0 THEN 'Replace "*/#/@/%" with name xS$ or position nn = kk GOSUB InsertString END IF 'Check for 2nd name % mm = INSTR(work$, "%") IF mm > 0 AND man2 > 0 THEN xS$ = LASTNAME$(DataName(man2, team2)) nn = mm GOSUB InsertString END IF MessagAdd: IF LEFT$(work$, 1) <> "~" THEN work$ = LEFT$(work$, 38 + colO) CALL AddToAnnouncer(team, work$) END IF EXIT SUB InsertString: L = LEN(work$) IF nn = L THEN work$ = MID$(work$, 1, nn - 1) + xS$ ELSEIF nn > 1 AND nn < L THEN work$ = MID$(work$, 1, nn - 1) + xS$ + MID$(work$, nn + 1) ELSEIF nn = 1 THEN work$ = xS$ + MID$(work$, 2) END IF RETURN END SUB SUB MyBeep BEEP END SUB SUB OptionSetup (row, Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), _ Flitcol(), FContents$()) DATA 08,24,"Quick-Play game: [Y/N] ",08,52,01,"X " DATA 09,24,"Auto Manager: ",00,00,00," " DATA 10,24," Visitor [Y/N] ",10,52,01,"XR" DATA 11,24," Home [Y/N] ",11,52,01,"XR" DATA 12,24,"Delay (Play-by-Play) [0-7] ",12,52,01,"NR" DATA 13,24,"Color Scheme [1-6] ",13,52,01,"NR" DATA 14,24,"Change Background [Y/N] ",14,52,01,"XR" DATA 15,24,"Sound [Y/N] ",15,52,01,"XR" DATA 16,24,"Focusing [Y/N] ",16,52,01,"XR" DATA 17,24,"Pause After Each Game [Y/N] ",17,52,01,"XR" DATA 18,24,"Pause After Each Date [Y/N] ",18,52,01,"XR" Flds = 11 row = 0 c = 1 FOR i = 1 TO Flds Flitrow(i) = VAL(READ$(c)) + rowO Flitcol(i) = VAL(READ$(c+1)) + colO Flit$(i) = READ$(c+2) Frow(i) = VAL(READ$(c+3)) IF Frow(i) > 0 THEN Frow(i) = Frow(i) + rowO Fcol(i) = VAL(READ$(c+4)) IF Fcol(i) > 0 THEN Fcol(i) = Fcol(i) + colO Flen(i) = VAL(READ$(c+5)) Fed$(i) = READ$(c+6) c = c + 7 NEXT IF CmdStat$ > "!" THEN Flen(9) = 1 ELSE Flen(9) = -1 IF MenuOpt$ <> "M" THEN Flen(10) = 1 ELSE Flen(10) = -1 IF MenuOpt$ = "S" THEN Flen(11) = 1 ELSE Flen(11) = -1 IF LEN(CmdFavTeam$) THEN Flen(11) = -1 IF LEN(CmdFavLeague$) THEN Flen(11) = -1 IF ConsRows = 25 AND ConsCols = 80 THEN Flen(7) = -1 IF amgr(1) AND amgr(2) THEN IF DelFac = 0 THEN Flen(1) = -1 END IF END IF REDIM FContents$(13) END SUB SUB OptionWindow (Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) IF Flen(1) = -1 THEN CursorPtr = 3 ELSE CursorPtr = 1 'Set Defaults FContents$(1) = "N" IF amgr(1) THEN FContents$(3) = "Y" ELSE FContents$(3) = "N" IF amgr(2) THEN FContents$(4) = "Y" ELSE FContents$(4) = "N" FContents$(5) = RIGHT$(STR$(DelFac), 1) FContents$(6) = LTRIM$(STR$(ColorScheme)) FContents$(7) = "N" IF SoundOn THEN FContents$(8) = "Y" ELSE FContents$(8) = "N" FContents$(9) = CmdFocus$ FContents$(10) = CmdPauseAftGame$ FContents$(11) = CmdPauseAftDate$ DO TopOfCWLoop: CALL ScreenIO(Keyed, KeyEsc, 0, KeyEsc, Flds, CursorPtr, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) 'Edit Field Contents Error1$ = "N" IF FContents$(1) <> "Y" AND FContents$(1) <> "N" THEN Error1$ = "Y": CursorPtr = 1: CALL MyBeep: GOTO TopOfCWLoop END IF FOR i = 3 TO 11 'Edit the Y/N responses IF i <> 5 AND i <> 6 THEN IF FContents$(i) <> "Y" AND FContents$(i) <> "N" THEN Error1$ = "Y": CursorPtr = i: CALL MyBeep: GOTO TopOfCWLoop END IF END IF NEXT IF FContents$(5) = "0" THEN FContents$(8) = "N" IF FContents$(6) < "1" OR FContents$(6) > "6" THEN Error1$ = "Y": CursorPtr = 6 CALL PopMsg(18+rowO, 22+colO, " Color Scheme out of range [1-6]", errattr, 2, kc) GOTO TopOfCWLoop END IF IF FContents$(3) = "N" OR FContents$(4) = "N" THEN IF FContents$(5) = "0" THEN Error1$ = "Y": CursorPtr = 5 CALL PopMsg(18+rowO, 17+colO, " Delay cannot be 0 if either AutoManager = N ", errattr, 2, kc) GOTO TopOfCWLoop END IF END IF LOOP WHILE Error1$ = "Y" CURSOR OFF 'turn off cursor amgr(1) = (FContents$(3) = "Y") amgr(2) = (FContents$(4) = "Y") DelFac = VAL(FContents$(5)) ColorScheme = VAL(FContents$(6)) CmdChangePhoto$ = FContents$(7) SoundOn = (FContents$(8) = "Y") CmdFocus$ = FContents$(9) CmdPauseAftGame$ = FContents$(10) CmdPauseAftDate$ = FContents$(11) IF FContents$(1) = "Y" THEN amgr(1) = TRUE amgr(2) = TRUE DelFac = 0 SoundOn = FALSE END IF END SUB SUB Outfield (AtPos) STATIC OutfErr = 0 wag = WHOATGUY (AtPos) defperF! = DEFPCT!(wag) 'Increase factor to improve defense zF! = defperF! + (1 - defperF!) * .5 IF RND < zF! THEN EXIT SUB OutfErr = -1 'Outfielder Error: botched it! INCR inne INCR innadverr i = DataRef(wag, id) INCR GpPos(i, id, AtPos) INCR merr(i, id) INCR SumErrors(AtPos) INCR iterrs(id) 'Some (1/2) of these errors will be throwing errors! IF DelFac THEN IF RND < .5 THEN 'bad throw by * CALL Msg ("30", "0", "0", "03", wag, id, man2, team2) ELSE 'ball gets away from * CALL Msg ("30", "0", "0", "04", wag, id, man2, team2) END IF IF NUMBERON > 1 THEN t$ = "05" ELSE t$ = "04" CALL Msg ("31", "0", "0", t$, 0, it, man2, team2) 'runner(s) advance(s) END IF i = Errorx Errorx = TRUE CALL Advanc(1, 1, 1) Errorx = i Result$ = Result$ + "/E-" + LTRIM$(STR$(AtPos)) END SUB SUB OutOrError STATIC ON ERROR GOTO ERRORTRAP 'Forced outcome for debugging through variable fr7 IF fr7=300 THEN CALL StrikeOutRoutine fr7=0 EXIT SUB END IF IF fr7=100 OR fr7=200 OR fr7=201 THEN GOTO OutDIRECTION END IF 'Find the percentage of outs which are strike-outs i = DataAB(ib, it) - DataHits(ib, it) IF i <> 0 THEN hsoF! = DataSO(ib, it) / i '% of Outs that are StrikeOuts ELSE hsoF! = .250 END IF psoF! = DataSO(ip, id) / (DataAB(ip, id) * 3) ' 0 to bpkF! is a K ' bpkF! to bpgF! is a ground out ' bpgF! to 1 is a fly out IF pkbaseF(id) > 0 THEN y! = pkbaseF(id) ELSE y! = .239 x! = hsoF! * (psoF! / y!) bpkF! = x! / (x! + ( (1-hsoF!)*(1-psoF!)/(1-y!) ) ) 'Use Pitcher Fatigue to influence ground/fly ratio adjF! = 1.85 'See below ** 'Pitcher Fatigue IF NewStyle(id) AND DataGames(ip, id) AND DataAB(ip, id) THEN 'New Style has "Games" and "Starts" FatFac! = nPitch(id) / ExpectedPitchCount(ip, id) adjF! = adjF! + (0.25 * FatFac! - 0.15) '** IF adjF! > 2.2 THEN adjF! = 2.2 '2.20-> 45.5% grounders END IF '1.95-> 51.3% '1.70-> 58.8% bpgF! = bpkF! + ((1 - bpkF!) / adjF!) '1.9 produces 52.6% grounders '1.85 produces 54.1% grounders '1.75 produces 57.1% grounders IF HitAndRun = FALSE THEN xrF! = RND IF xrF! < bpkF! THEN CALL StrikeOutRoutine EXIT SUB END IF ELSE 'On Hit-and-run's we don't process strike outs here 'Find a new random number between bpkF! and 1.0 n = (1.0 - bpkF!) * 1000 j = 1000 - FRND(n) xrF! = j / 1000 CALL Msg ("25", "0", "0", "02", 0, it, 0, 0) 'Hit-and-run END IF OutDIRECTION: REM ** PULLED ? ** ' Hit Somewhere ppF! = FindPP! IF fr7=100 THEN GOTO OutGROUND 'ground IF fr7=200 OR fr7 = 201 THEN GOTO OutFLY 'fly IF xrF! > bpgF! THEN GOTO OutFLY ' GOTO Fly '** GROUNDER ** ' Ground Ball OutGROUND: WhoAtPos = GROUNDBALLWHOAT (ppF!) IF WhoAtPos = 1 THEN wag = ip defperF! = NormDEF(1) ELSE wag = WHOATGUY(WhoAtPos) defperF! = DEFPCT!(wag) END IF p$ = LTRIM$(STR$(WhoAtPos)) 'Since most errors occur on grounders, fudge defperF! down to produce more errors zF! = defperF! * .98 IF RND > zF! THEN 'FIELDING or THROWING ERROR! Errorx = TRUE INCR iterrs(id) INCR inne i = DataRef(wag, id) INCR GpPos(i, id, WhoAtPos) INCR merr(i, id) INCR SumErrors(WhoAtPos) IF DelFac THEN CALL Msg ("02", p$, "1", "00", wag, id, man2, team2) IF fr4 = 1 THEN '25% of infield errors are throwing errors IF DelFac THEN IF p$ = "3" THEN AddToAnnouncer id, "He flips to the pitcher covering..." ELSE CALL Msg ("02", p$, "2", "00", wag, id, man2, team2) 'fields & throws END IF 'No indication of where he's throwing it CALL Msg ("30", "0","0", "02", wag, id, man2, team2) 'bad throw END IF ThrowError = TRUE ELSEIF p$ < "3" THEN IF DelFac THEN CALL Msg ("21", p$, "0", "00", wag, id, man2, team2) 'boots it OneBaseError = TRUE ELSE 'The ball is at an infielder (3-4-5-6) and it's a fielding error IF fr4 > 2 THEN 'one base adv IF DelFac THEN CALL Msg ("21", p$, "0", "01", wag, id, man2, team2) 'boots it OneBaseError = TRUE ELSE 'two base adv IF DelFac THEN CALL Msg ("21", p$, "0", "02", wag, id, man2, team2) 'right by him END IF END IF IF DelFac THEN CALL Msg ("30", "0","0", "09", wag, id, man2, team2) 'error Result$ = "E-" + LTRIM$(STR$(WhoAtPos)) CALL SingleRoutine 'Sound handled in SingleRoutine EXIT SUB END IF 'No error (yet) Result$ = LTRIM$(STR$(WhoAtPos)) CALL Ground 'handles sound INCR mpo(ip, id) EXIT SUB '** FLY ** OutFLY: 'where did the fly go? FoulBall = FALSE xF! = RND 'about 70% go to outfield i = OUTFIELDWHOAT(ppF!) 'returns 7, 8 or 9 only IF i = 7 THEN IF xF! > .24 THEN WhoAtPos = 7 ELSE WhoAtPos = 7 - FRND(2) ' 7 .76 ' 6 .12 ' 5 .12 ELSEIF i = 8 THEN IF xF! > .47 AND xF! < .52 THEN '.05 WhoAtPos = 2 ELSEIF xF! > .20 THEN '.75 WhoAtPos = 8 ELSEIF xF! > .10 THEN '.10 WhoAtPos = 6 ELSE '.10 WhoAtPos = 4 END IF ELSE IF xF! > .24 THEN WhoAtPos = 9 ELSE WhoAtPos = 5 - FRND(2) ' 9 .76 ' 4 .12 ' 3 .12 END IF wag = WHOATGUY(WhoAtPos) 'Infield flys: DPsw = FALSE xF! = RND IF WhoAtPos < 7 THEN IF xF! < .10 AND WhoAtPos <> 2 THEN IF DelFac THEN CALL Msg ("04", "0", "0", "00", wag, id, man2, team2) 'Line Shot IF SoundOn THEN CALL WavLineDrive END IF IF xF! < .05 OR HitAndRun THEN '1/2 of linedrives DPsw = TRUE 'Double play! (possibility) END IF ELSE IF DelFac THEN IF SoundOn THEN CALL WavPopUp CALL Msg ("05", "0", "1", "00", 0, it, man2, team2) 'pop up CALL Msg ("05", "0", "2", "00", wag, id, man2, team2) '* under it END IF xFF! = RND IF (WhoAtPos = 5 OR WhoAtPos = 3) AND xFF! < .3 THEN FoulBall = TRUE IF WhoAtPos = 2 AND xFF! < .7 THEN FoulBall = TRUE IF FoulBall THEN 'Drifts into Foul Territory... IF DelFac THEN CALL Msg ("29", "0", "0", "20", wag, id, man2, team2) END IF END IF END IF defperF! = DEFPCT!(wag) Dramatic = (RND < .11) deep = FALSE 'IF ERRSw(id) = FALSE THEN ' IF WhoAtPos = 2 THEN defperF! = defperF! * 0.9550 ' IF WhoAtPos = 3 THEN defperF! = defperF! * 0.9800 'END IF 'Outfield flys IF WhoAtPos > 6 THEN IF RND < .06 THEN 'Teaser for Home Run IF DelFac THEN IF SoundOn THEN CALL WavBigFly CALL Msg ("09", "0", "1", "01", wag, id, man2, team2) 'There's a drive IF RND < .1 THEN t$ = "02" ELSE t$ = "01" CALL Msg ("09", "0", "2", t$, wag, id, man2, team2) '* going back t$ = "01" END IF Dramatic = TRUE deep = TRUE GOTO 10060 END IF 'Outfield fly messages t$ = LTRIM$(STR$(RND(1, 2))) t$ = PADZEROS$(t$, 2) IF DelFac THEN IF Dramatic THEN IF SoundOn THEN IF t$ = "01" THEN CALL WavBigFly ELSE CALL WavShortFly END IF END IF CALL Msg ("07", "0", "1", t$, wag, id, man2, team2) CALL Msg ("07", "0", "2", t$, wag, id, man2, team2) CALL Msg ("07", "0", "3", t$, wag, id, man2, team2) ELSE IF SoundOn THEN CALL WavRegularFly CALL Msg ("06", "0", "1", "00", wag, id, man2, team2) CALL Msg ("06", "0", "2", "00", wag, id, man2, team2) END IF ELSE deep = (RND < .38) END IF END IF 'Not many errors occur on fly balls (both outfield and infield here) IF WhoAtPos < 7 THEN 'Infield Fly zF! = defperF! * 1.03 IF zF! > .99999 THEN zF! = .99999 ELSE 'Outfield Fly zF! = defperF! + (1 - defperF!) * .4 'was .5 END IF IF RND > zF! THEN Errorx = TRUE 'Error on the fly INCR iterrs(id) INCR inne i = DataRef(wag, id) INCR GpPos(i, id, WhoAtPos) INCR merr(i, id) INCR SumErrors(WhoAtPos) IF DelFac THEN CALL Msg ("30", "0", "0", "01", wag, id, man2, team2) 'dropped CALL Msg ("30", "0", "0", "09", wag, id, man2, team2) 'error END IF Result$ = "E-" + LTRIM$(STR$(WhoAtPos)) IF FoulBall THEN CALL AddToScoreCrd(it, DataRef(ib, it), " ", Result$ + " (Foul)") CALL ResetBatter EXIT SUB END IF SaveSound = SoundOn SoundOn = FALSE IF WhoAtPos < 7 THEN 'pop-up - 1 base error OneBaseError = TRUE CALL SingleRoutine 'handles sound (already done) SoundOn = SaveSound EXIT SUB END IF CALL DoubleRoutine '2 base error on outfielder - handles sound SoundOn = SaveSound EXIT SUB END IF 10060: Result$ = LTRIM$(STR$(WhoAtPos)) IF FoulBall THEN Result$ = Result$ + " (Foul)" INCR PutOuts(DataRef(wag, id), id, WhoAtPos) CALL Fly(DPsw, Dramatic, deep, t$) INCR mpo(ip, id) EXIT SUB ErrorTrap: LOCATE 10, 30 PRINT "OUTorERR_Error"; ERRCLEAR x$ = WAITKEY$ END SUB SUB ParseCommand (xS$, nargs) 'Parses xS$ into ArgList(). Counts nargs. REGISTER i AS INTEGER nargs = 0 DIM Args$(20) REDIM ArgList(20) AS GLOBAL ArgType IF LEN(xS$) = 0 THEN EXIT SUB i = 1 inword = FALSE DO WHILE i <= LEN(xS$) cS$ = MID$(xS$, i, 1) IF cS$ = "/" THEN inword = TRUE INCR nargs Args$(nargs) = Args$(nargs) + cS$ ELSEIF cS$ <> " " AND inword THEN Args$(nargs) = Args$(nargs) + cS$ ELSEIF cS$ = " " THEN inword = FALSE END IF INCR i LOOP 'Special Case to pull off a /CMD file: IF nargs = 1 THEN y$ = UCASE$(Args$(1)) z$ = LEFT$(y$, 5) IF z$ = "/CMD:" THEN CmdCmdFile$ = MID$(y$, 6) END IF END IF 'Copy results into the global dynamic array FOR i = 1 TO nargs ArgList(i).Arg = Args$(i) NEXT END SUB SUB PauseIt ' routine to clear keyboard CALL Clrkbd CALL ClearInpBuffer x$ = WAITKEY$ END SUB SUB PickAFile (Fil$, FileLimit, List1() AS List1Type, RetKey, Pick, mous, FrameStyle) 'Return Pick and RetKey DIM F$(9) d = INSTR(Fil$, "|") IF d THEN F$(1) = MID$(Fil$, 1, d-1) F$(2) = MID$(Fil$, d+1) c = 2 ELSE F$(1) = Fil$ c = 1 END IF n = 0 FOR i = 1 TO c CALL LoadFilesToList1 (F$(i), List1(), FileLimit, n) 'returns "n" = total files found NEXT IF n = 1 THEN IF RTRIM$(List1(1).ListItem) = ".." OR _ RTRIM$(List1(1).ListItem) = "C:\" THEN n = 0 END IF END IF IF n > FileLimit THEN CALL MyBeep x$ = "Error: Too Many Files. Limit is " + STR$(FileLimit) CALL ErrorBox (x$) n = FileLimit END IF IF n THEN ARRAY SORT List1(1) FOR n, DESCEND SELECT CASE MenuOpt$ CASE "S" zS$ = "Schedule Files" yS$ = "[E]dit [N]ew ESC:Menu" CALL PrintSCHHelp CASE "E" zS$ = "Series Files" yS$ = "[V]iew [E]dit [N]ew ESC:Menu" CALL PrintSERHelp CASE "A" zS$ = "Statistics Files" yS$ = "DEL:Delete ESC:Menu" CALL PrintSTAHelp CASE ELSE zS$ = "" yS$ = "" END SELECT IF MenuOpt$ <> "1" THEN row1 = 2 + rowO col1 = 2 + colO row2 = 10 + rowO col2 = 46 + colO Shadow = 0 ESCPoint = 2 r = 4 + rowO columns = 3 itemsincol = 7 ELSE row1 = 3 + rowO col1 = 62 + colO row2 = 21 + rowO col2 = 76 + colO Shadow = 0 ESCPoint = 2 r = 10 + rowO columns = 1 itemsincol = 17 END IF CALL Drawfrm (row1, col1, row2, col2, defattr, zS$, yS$, Shadow, FrameStyle, ESCPoint) IF FrameStyle = 0 THEN x1$ = "µ": x2$ = "¶" ELSE x1$ = "Ñ": x2$ = "ã" QPRINTs r, col2, x1$, defattr QPRINTs r + 1, col2, UpPtr$, defattr QPRINTs r + 2, col2, DnPtr$, defattr QPRINTs r + 3, col2, x2$, defattr DO CALL PickFromList(List1(), n, itemsincol, columns, 12, row1,col1,row2,col2, dimattr, revattr, Pick, RetKey, nulls$, mous, ms$) IF ms$ = "—" THEN RetKey = -61 ' LOCATE 1, 1 : print "pick:";Pick;" RetKey:"; RetKey IF RetKey THEN 'was just > 0 but need to catch negative ones too sometimes SELECT CASE MenuOpt$ CASE "S" CALL ExitPickForSCH(List1(), Pick, RetKey) CASE "E" CALL ExitPickForDAT(List1(), Pick, RetKey) CASE "A" CALL ExitPickForSTS(List1(), Pick, RetKey) CASE ELSE END SELECT END IF LOOP WHILE RetKey = -99 END SUB SUB PickFromList (List1() AS List1Type, ItemsInList, ItemsInColumn, Columns, ItemLen, row, col, row2, col2, colattr, revattr, Pick, RetKey, OutDevice$, mous, ms$) STATIC 'Row and Col are coordinates of the upper-left corner of the FRAME 'Requires SUB ChangeAttribute 'Lots of the internal variables need to be STATIC because sometimes 'we jump back into the middle of this routine IF RetKey = -99 THEN GOTO Pick1WaitForKey IF RetKey = -97 OR RetKey = -98 THEN DisplayOnly = -1 MaxPages = 99 REDIM FirstItemOnPage(MaxPages) Pick1BeginPage: pageno = 1 PageItemPtr = 1 FirstItemOnPage(1) = 1 Pick1Reentry: PageMaxItems = ItemsInColumn * Columns ItemNum = FirstItemOnPage(pageno) PageItemCtr = 1 PageFull = FALSE EndOfList = FALSE HiLiteA = colattr IF ConsRows = 25 AND ConsCols = 80 THEN BeginBuffer DO UNTIL PageFull 'Don't read past End of List IF ItemNum > ItemsInList THEN 'Blank Rest of Screen tmpPageItemCtr = PageItemCtr DO WHILE tmpPageItemCtr <= PageMaxItems stak = (tmpPageItemCtr - 1) \ ItemsInColumn + 1 c = col + (stak - 1) * (ItemLen + 2) + 2 r = row + tmpPageItemCtr - (stak - 1) * ItemsInColumn QPRINTs r, c, SPACE$(ItemLen), colattr INCR tmpPageItemCtr LOOP EndOfList = TRUE PageFull = TRUE EXIT DO END IF 'Figure where to locate stak = (PageItemCtr - 1) \ ItemsInColumn + 1 c = col + (stak - 1) * (ItemLen + 2) + 2 r = row + PageItemCtr - (stak - 1) * ItemsInColumn attr = colattr IF DisplayOnly = FALSE THEN 'Hilite item IF PageItemCtr = PageItemPtr THEN attr = revattr HiLiteR = r HiLiteC = c END IF END IF IF DisplayOnly AND LEFT$(List1(ItemNum).ListItem, 1) = "~" THEN attr = defattr xS$ = MID$(List1(ItemNum).ListItem, 2) ELSEIF LEFT$(List1(ItemNum).ListItem, 1) = "%" THEN attr = skipattr xS$ = MID$(List1(ItemNum).ListItem, 2) IF PageItemCtr = PageItemPtr THEN INCR PageItemPtr END IF ELSE xS$ = List1(ItemNum).ListItem END IF QPRINTs r, c, PADRIGHT$(xS$, ItemLen), attr INCR PageItemCtr INCR ItemNum IF PageItemCtr > PageMaxItems THEN PageFull = TRUE LOOP IF ConsRows = 25 AND ConsCols = 80 THEN EndBuffer IF RetKey = -97 THEN Pick = 0: GOTO Pick1Exit Pick1WaitForKey: 'Wait for arrow Items / PageUp / PageDown / Enter DO mous = 0 msx = 0 msy = 0 KyS$ = WAITKEY$ s% = INSHIFT IF LEN(KyS$) = 1 THEN kc = ASC(KyS$) KyS$ = UCASE$(KyS$) ELSEIF LEN(KyS$) = 2 THEN kc = -ASC(RIGHT$(KyS$, 1)) ELSEIF LEN(KyS$) = 4 THEN IF ASC(KyS$, 3) = 2 THEN DoubleClick = TRUE ELSE DoubleClick = FALSE END IF mous = TRUE msx = MOUSEX msy = MOUSEY ms$ = CHR$(SCREEN(msy, msx)) IF ms$ = "—" THEN kc = 27 GOSUB FlashMouse ELSEIF ms$ = CloseButton$ THEN kc = 13 GOSUB FlashMouse ELSEIF msx > col AND msx < col2 AND msy > row AND msy < row2 THEN 'INSIDE frame IF ItemsInList THEN 'Determine PageItemPtr PageItemPtr = msy - row + INT((msx - col - 2) / (ItemLen + 2)) * ItemsInColumn IF PageItemPtr < 1 THEN PageItemPtr = 1 IF PageItemPtr > PageItemCtr - 1 THEN PageItemPtr = PageItemCtr - 1 DO GOSUB PMHiLite1 'Is this a skipped field? CALL ReadFromScreen (r, c, ItemLen, field$, "", Valid$) IF HiLiteA <> skipattr AND _ field$ <> STRING$(ItemLen, "Ž") THEN EXIT DO 'yes, skip this field INCR PageItemPtr IF PageItemPtr > PageItemCtr - 1 THEN PageItemPtr = 1 END IF LOOP IF DoubleClick THEN kc = 13 ELSE GOTO PContinueLoop END IF ELSE GOTO PContinueLoop END IF ELSEIF msx < col OR msx > col2 OR msy < row OR msy > row2 THEN 'OUTSIDE the frame - ESC kc = 27 ELSE 'ON the frame SELECT CASE ms$ CASE "V", "E", "A", "N", "F", "P", "Q" KyS$ = ms$ kc = ASC(KyS$) GOSUB FlashMouse CASE DnPtr$ kc = -81 GOSUB FlashMouse CASE UpPtr$ kc = -73 GOSUB FlashMouse CASE ELSE kc = 27 END SELECT END IF END IF IF kc = -72 THEN 'Up IF PageItemPtr > 1 THEN DECR PageItemPtr DO GOSUB PMHiLite1 'Is this a skipped field? CALL ReadFromScreen (r, c, ItemLen, field$, "", Valid$) IF HiLiteA <> skipattr AND _ field$ <> STRING$(ItemLen, "Ž") THEN EXIT DO 'Yes DECR PageItemPtr IF PageItemPtr < 1 THEN PageItemPtr = PageItemCtr - 1 END IF LOOP GOTO PContinueLoop END IF END IF IF kc = -80 THEN 'Down IF PageItemPtr < PageItemCtr - 1 THEN INCR PageItemPtr DO GOSUB PMHiLite1 'Is this a skipped field? CALL ReadFromScreen (r, c, ItemLen, field$, "", Valid$) IF HiLiteA <> skipattr AND _ field$ <> STRING$(ItemLen, "Ž") THEN EXIT DO 'No 'Yes - experiment INCR PageItemPtr IF PageItemPtr > PageItemCtr - 1 THEN PageItemPtr = 1 END IF LOOP GOTO PContinueLoop END IF END IF IF kc = -75 THEN 'Left IF PageItemPtr > ItemsInColumn THEN PageItemPtr = PageItemPtr - ItemsInColumn GOSUB PMHiLite1 GOTO PContinueLoop END IF END IF IF kc = -77 THEN 'Right IF PageItemPtr + ItemsInColumn < PageItemCtr THEN PageItemPtr = PageItemPtr + ItemsInColumn GOSUB PMHiLite1 GOTO PContinueLoop END IF END IF IF kc = -73 THEN 'PageUp IF pageno > 1 THEN DECR pageno PageItemPtr = 1 GOTO Pick1Reentry END IF IF kc = -81 AND EndOfList = FALSE THEN 'PageDown IF pageno < MaxPages THEN INCR pageno FirstItemOnPage(pageno) = ItemNum PageItemPtr = 1 GOTO Pick1Reentry END IF IF kc = 13 OR kc = -83 OR KyS$ = "V" OR KyS$ = "E" OR KyS$ = "A" THEN 'ENTER or DEL or V or E or A to set Pick and escape Pick = FirstItemOnPage(pageno) + PageItemPtr - 1 IF Pick > ItemsInList THEN Pick = ItemsInList EXIT DO END IF IF KyS$ = "N" THEN 'N for "new" Pick = 0 EXIT DO END IF IF kc = 113 OR kc = 81 OR kc = -61 OR kc = 27 OR kc = -68 THEN 'q/Q,F3,ESC, F10 to Abort Pick = 0 EXIT DO END IF IF kc = KeyF4 THEN Pick = 0 EXIT DO END IF IF kc = 112 OR kc = 80 THEN '[P]rint ' xS$ = "LPT" + LTRIM$(STR$(LPTNum)) xS$ = "LPT1" CALL DumpList(List1(), ItemsInList, xS$, FALSE) END IF IF kc = 102 OR kc = 70 THEN '[F]ile IF OutDevice$ > "!" THEN xS$ = CmdWritePath$ + OutDevice$ CALL DumpList(List1(), ItemsInList, xS$, TRUE) CALL PopMsg(18+rowO, 26+colO, " Screen dumped to: " + xS$, errattr, 2, kc) END IF END IF PContinueLoop: LOOP RetKey = kc GOTO Pick1Exit PMHiLite1: 'Feed this routine "PageItemPtr" and it hi-lites the right item IF DisplayOnly THEN RETURN 'Reset old hilite item CALL ChangeAttribute(HiLiteR, HiLiteC, ItemLen, HiLiteA) 'Set new hilite item stak = (PageItemPtr - 1) \ ItemsInColumn + 1 c = col + (stak - 1) * (ItemLen + 2) + 2 r = row + PageItemPtr - (stak - 1) * ItemsInColumn HiLiteA = SCREENATTR(r, c) 'save original color attr 'IF HiLiteA <> skipattr THEN CALL ChangeAttribute(r, c, ItemLen, revattr) 'change to reverse 'END IF HiLiteR = r HiLiteC = c RETURN FlashMouse: CALL FlashField (msy, msx, 1, 2, 100, 0) RETURN Pick1Exit: DisplayOnly = 0 LOCATE 1, 1 END SUB SUB PickFromPlyList (PlyList() AS PlyListType, ItemsInList, ItemsInColumn, Columns, ItemLen, row, col, row2, col2, colattr, revattr, Pick, RetKey, OutDevice$, FreezePtr) STATIC ON ERROR GOTO ERRORTRAP 'Row and Col are coordinates of the upper-left corner of the FRAME 'Requires SUB ChangeAttribute 'Lots of the internal variables need to be STATIC because sometimes 'we jump back into the middle of this routine IF RetKey = -99 THEN GOTO Pick2WaitForKey DisplayOnly = (RetKey = -98) MaxPages = 99 REDIM FirstItemOnPage(MaxPages) Pick2BeginPage: pageno = 1 IF FreezePtr THEN IF PageItemPtr < 1 THEN PageItemPtr = 1 ELSE PageItemPtr = 1 END IF FirstItemOnPage(1) = 1 Pick2Reentry: PageMaxItems = ItemsInColumn * Columns ItemNum = FirstItemOnPage(pageno) PageItemCtr = 1 PageFull = FALSE EndOfList = FALSE IF ConsRows = 25 AND ConsCols = 80 THEN BeginBuffer DO UNTIL PageFull 'Don't read past End of List IF ItemNum > ItemsInList THEN 'Blank Rest of Screen tmpPageItemCtr = PageItemCtr DO WHILE tmpPageItemCtr <= PageMaxItems stak = (tmpPageItemCtr - 1) \ ItemsInColumn + 1 c = col + (stak - 1) * (ItemLen + 2) + 2 r = row + tmpPageItemCtr - (stak - 1) * ItemsInColumn QPRINTs r, c, SPACE$(ItemLen), colattr INCR tmpPageItemCtr LOOP EndOfList = TRUE PageFull = TRUE EXIT DO END IF 'Figure where to locate stak = (PageItemCtr - 1) \ ItemsInColumn + 1 c = col + (stak - 1) * (ItemLen + 2) + 2 r = row + PageItemCtr - (stak - 1) * ItemsInColumn attr = colattr IF DisplayOnly = FALSE THEN 'Hilite item IF PageItemCtr = PageItemPtr THEN attr = revattr HiLiteR = r HiLiteC = c END IF END IF a$ = PlyList(ItemNum).Item a$ = PADRIGHT$(a$, ItemLen) QPRINTs r, c, a$, attr INCR PageItemCtr INCR ItemNum IF PageItemCtr > PageMaxItems THEN PageFull = TRUE LOOP IF ConsRows = 25 AND ConsCols = 80 THEN EndBuffer Pick2WaitForKey: 'Wait for arrow Items / PageUp / PageDown / Enter DO msx = 0 msy = 0 KyS$ = WAITKEY$ s% = INSHIFT IF LEN(KyS$) = 1 THEN kc = ASC(KyS$) KyS$ = UCASE$(KyS$) ELSEIF LEN(KyS$) = 2 THEN kc = -ASC(RIGHT$(KyS$, 1)) ELSEIF LEN(KyS$) = 4 THEN IF ASC(KyS$, 3) = 2 THEN DoubleClick = TRUE ELSE DoubleClick = FALSE END IF msx = MOUSEX msy = MOUSEY ms$ = CHR$(SCREEN(msy, msx)) IF ms$ = "—" THEN kc = 27 ELSEIF ms$ = CloseButton$ THEN kc = 13 ELSEIF msx > col AND msx < col2 AND msy > row AND msy < row2 THEN 'INSIDE frame 'Determine PageItemPtr PageItemPtr = msy - row + INT((msx - col - 2) / (ItemLen + 2)) * ItemsInColumn IF PageItemPtr < 1 THEN PageItemPtr = 1 IF PageItemPtr > PageItemCtr - 1 THEN PageItemPtr = PageItemCtr - 1 GOSUB PMHiLite2 IF DoubleClick THEN kc = 13 ELSE GOTO PContinueLoop2 END IF ELSEIF msx < col OR msx > col2 OR msy < row OR msy > row2 THEN 'OUTSIDE the frame - ESC kc = 27 ELSE 'ON the frame SELECT CASE ms$ CASE "V", "E", "A", "N", "Q", "F", "P" KyS$ = ms$ kc = ASC(KyS$) GOSUB FlashMouse CASE DnPtr$ kc = -81 GOSUB FlashMouse CASE UpPtr$ kc = -73 GOSUB FlashMouse CASE ELSE kc = 27 END SELECT END IF END IF IF kc = -72 THEN 'Up IF PageItemPtr > 1 THEN DECR PageItemPtr GOSUB PMHiLite2 GOTO PContinueLoop2 END IF END IF IF kc = -80 THEN 'Down IF PageItemPtr < PageItemCtr - 1 THEN INCR PageItemPtr GOSUB PMHiLite2 GOTO PContinueLoop2 END IF END IF IF kc = -75 THEN 'Left IF PageItemPtr > ItemsInColumn THEN PageItemPtr = PageItemPtr - ItemsInColumn GOSUB PMHiLite2 GOTO PContinueLoop2 END IF END IF IF kc = -77 THEN 'Right IF PageItemPtr + ItemsInColumn < PageItemCtr THEN PageItemPtr = PageItemPtr + ItemsInColumn GOSUB PMHiLite2 GOTO PContinueLoop2 END IF END IF IF kc = -73 THEN 'PageUp IF pageno > 1 THEN DECR pageno PageItemPtr = 1 GOTO Pick2Reentry END IF IF kc = -81 AND EndOfList = FALSE THEN 'PageDown IF pageno < MaxPages THEN INCR pageno FirstItemOnPage(pageno) = ItemNum PageItemPtr = 1 GOTO Pick2Reentry END IF IF kc = 13 THEN 'Enter : set Pick and escape Pick = FirstItemOnPage(pageno) + PageItemPtr - 1 EXIT DO END IF IF kc = 113 OR kc = 81 OR kc = -61 OR kc = 27 THEN 'q,Q,F3,ESC to Abort Pick = 0 EXIT DO END IF PContinueLoop2: LOOP RetKey = kc GOTO Pick2Exit PMHiLite2: 'Reset old hilite item CALL ChangeAttribute(HiLiteR, HiLiteC, ItemLen, colattr) 'set new hilite item stak = (PageItemPtr - 1) \ ItemsInColumn + 1 c = col + (stak - 1) * (ItemLen + 2) + 2 r = row + PageItemPtr - (stak - 1) * ItemsInColumn CALL ChangeAttribute(r, c, ItemLen, revattr) HiLiteR = r HiLiteC = c RETURN FlashMouse: CALL FlashField (msy, msx, 1, 2, 100, 0) RETURN Pick2Exit: LOCATE 1, 1 EXIT SUB ErrorTrap: LOCATE 10, 30 PRINT "ERROR: PickFrPL"; ERRCLEAR x$ = WAITKEY$ END SUB SUB PickTheStarter(tm, r, N) ' [in: tm, r(ow)] [out: Pick] r = 8 REDIM PlyList(1 TO 21) AS PlyListType REDIM StartsList(1 TO 21) AS RankType 'Decide if we're going to sort by number of starts or just pick first 5 'Count how many pitchers have "starts" : Av Av = 0 FOR j = 10 TO LastPiAd(tm) IF DataPos(j, tm) = 1 AND DataGbyP(j, tm, 1) > 0 THEN IF Av < 20 THEN INCR Av xS$ = LTRIM$(STR$(DataGbyP(j, tm, 1))) 'Starts StartsList(Av).Criteria = PADZEROS$(xS$, 4) StartsList(Av).Slot = j END IF END IF NEXT 'fS$ = "\ \ \\ ## ## ### ## #### #### ### ### #.##" IF Av < 5 THEN 'Punt -- just list first five i = 0 IF LastPiAd(tm) < 14 THEN k = LastPiAd(tm) ELSE k = 14 IF k = 0 THEN k = 11 FOR j = 10 TO k a$ = SPACE$(60) IF CmdStat$ > "!" AND DaysOffRule = TRUE THEN m = GetDaysOff (j, tm) IF m THEN MID$(a$, 1, 1) = LFORMAT$(m, "#") END IF END IF MID$(a$, 3, 17) = DataName(j, tm) MID$(a$, 22, 1) = DataHand(j, tm) MID$(a$, 26, 2) = LFORMAT$(DataDef(j, tm), "##") MID$(a$, 29, 2) = LFORMAT$(DataSB(j, tm), "##") MID$(a$, 32, 3) = LFORMAT$(DataGames(j, tm), "##") MID$(a$, 36, 2) = LFORMAT$(DataGbyP(j, tm, 1), "##") MID$(a$, 39, 4) = LFORMAT$(DataAB(j, tm), "####") MID$(a$, 44, 4) = LFORMAT$(DataHits(j, tm), "####") MID$(a$, 49, 3) = LFORMAT$(DataBB(j, tm), "###") MID$(a$, 53, 3) = LFORMAT$(DataSO(j, tm), "###") MID$(a$, 57, 4) = FFORMAT$(DataRBI(j, tm) / 100, "#.##") INCR i PlyList(i).Item = a$ PlyList(i).Ref = j NEXT Av = k - 10 + 1 ELSE 'list the starters ARRAY SORT StartsList(1) FOR Av, FROM 1 TO 4, DESCEND i = 0 FOR k = 1 TO Av j = StartsList(k).Slot a$ = SPACE$(60) IF CmdStat$ > "!" AND DaysOffRule = TRUE THEN m = GetDaysOff (j, tm) IF m THEN MID$(a$, 1, 1) = LFORMAT$(m, "#") END IF END IF MID$(a$, 3, 17) = DataName(j, tm) MID$(a$, 22, 1) = DataHand(j, tm) MID$(a$, 26, 2) = LFORMAT$(DataDef(j, tm), "##") MID$(a$, 29, 2) = LFORMAT$(DataSB(j, tm), "##") MID$(a$, 32, 3) = LFORMAT$(DataGames(j, tm), "##") MID$(a$, 36, 2) = LFORMAT$(DataGbyP(j, tm, 1), "##") MID$(a$, 39, 4) = LFORMAT$(DataAB(j, tm), "####") MID$(a$, 44, 4) = LFORMAT$(DataHits(j, tm), "####") MID$(a$, 49, 3) = LFORMAT$(DataBB(j, tm), "###") MID$(a$, 53, 3) = LFORMAT$(DataSO(j, tm), "###") MID$(a$, 57, 4) = FFORMAT$(DataRBI(j, tm) / 100, "#.##") INCR i PlyList(i).Item = a$ PlyList(i).Ref = j NEXT END IF ' r2 = r + 12 'Allows display of 10 starters ' r2 = r + 15 'Allows display of 13 starters r2 = r + Av + 2 IF r2 > 23 THEN r2 = 23 FreezePtr = FALSE IF MenuOpt$ = "M" THEN 'Manual Mode CALL Drawfrm(r+rowO, 7+colO, r2+rowO, 71+colO, defattr, "Select Starting Pitcher for '" + Names(tm), "Dbl-click (or Enter) selection or ESC to Abort", 1, 0, 2) ELSEIF MMx THEN 'Manual Manage within a Schedule CALL Drawfrm(r+rowO, 7+colO, r2+rowO, 71+colO, defattr, "Select Starting Pitcher for '" + Names(tm), "Dbl-click (or Enter) selection", 1, 0, 1) ELSE 'Two-Team Mode CALL Drawfrm(r+rowO, 7+colO, r2+rowO, 71+colO, defattr, "Select Pitching Rotation for '" + Names(tm), "Dbl-click (or Enter) selection -- ESC When Done", 1, 0, 2) IF SelX > 0 THEN FreezePtr = TRUE END IF QPRINTs r+1+rowO, 10+colO, " Name L/R W L G St Inn Hits BB SO ERA", dimattr PTSTryAgain: CALL PickFromPlyList (PlyList(), Av, r2-r-2, 1, 60, r+1+rowO, 8+colO, r2+rowO, 71+colO, dimattr, revattr, Pick, RetKey, nulls$, FreezePtr) IF Pick > 0 THEN N = PlyList(Pick).Ref ELSE N = 0 END IF IF MMx AND CmdStat$ > "!" AND DaysOffRule = TRUE THEN 'What if all pitchers are tired? AllAreTired = TRUE FOR i = 1 TO Av ii = PlyList(i).Ref IF GetDaysOff (ii, tm) = 0 THEN AllAreTired = FALSE NEXT IF AllAreTired = FALSE THEN IF GetDaysOff (N, tm) > 0 THEN x$ = " That pitcher seems to have the day off. | " x$ = x$ + "Start this pitcher anyway? [Y/n] " CALL PopMsg(MidRow+8, MidCol-20, x$, errattr, 0, kc) IF UCASE$(CHR$(kc)) = "N" THEN GOTO PTSTryAgain END IF END IF END IF END IF ERASE PlyList END SUB SUB PinchHit (m) ON ERROR GOTO ERRORTRAP IF amgr(it) THEN IF m > LastPiAd(it) THEN 'AutoManager has already selected PHitter GOTO P50 ELSE GOTO P999 END IF END IF 'Select Bench List REDIM PlyList(1 TO 30) AS PlyListType 'was 15 Av = 0 FOR j = LastPiAd(it) + 1 TO MAXPLAYERS IF Av < 30 THEN IF DataName(j, it) < "." THEN pend = j - 1: EXIT FOR IF DataAB(j, it) = 0 THEN BAF! = 0 ELSE BAF! = DataHits(j, it) / DataAB(j, it) END IF flag$ = " " IF iused(j, it) THEN flag$ = "x" 'Is the bench player's name identical to a current or used pitcher? FOR i = 1 TO np(it) IF DataName(j, it) = DataName(iyp(i,it), it) THEN flag$ = "x" NEXT 'f$ = "\\\ \ \\ ### ### ### ## ### ### ### ### \\## ### ## ### .###" a$ = SPACE$(73) MID$(a$, 1, 1) = flag$ MID$(a$, 3, 16) = DataName(j, it) MID$(a$, 20, 2) = Pos(DataPos(j, it)) MID$(a$, 23, 3) = LFORMAT$(DataAB(j, it), "###") MID$(a$, 27, 3) = LFORMAT$(DataHits(j, it), "###") MID$(a$, 31, 3) = LFORMAT$(Data2B(j, it), "###") MID$(a$, 35, 2) = LFORMAT$(Data3B(j, it), "##") MID$(a$, 38, 3) = LFORMAT$(DataHR(j, it), "###") MID$(a$, 42, 3) = LFORMAT$(DataRBI(j, it), "###") MID$(a$, 46, 3) = LFORMAT$(DataBB(j, it), "###") MID$(a$, 50, 3) = LFORMAT$(DataSO(j, it), "###") MID$(a$, 54, 1) = DataHand(j, it) MID$(a$, 56, 2) = LFORMAT$(DataSpeed(j, it), "##") MID$(a$, 59, 3) = LFORMAT$(DataSB(j, it), "###") MID$(a$, 63, 2) = LFORMAT$(DataCS(j, it), "##") MID$(a$, 66, 3) = LFORMAT$(DataDef(j, it), "###") MID$(a$, 70, 4) = FFORMAT$(BAF!, ".###") INCR Av PlyList(Av).Item = a$ PlyList(Av).Ref = j END IF NEXT 'Display Bench QPush P5: r = Av + 7 + rowO IF r > (ConsRows - 2) THEN r = ConsRows - 2 IF Gfx THEN CALL GraphHole(30, 5+rowO, 2+colO, r+1, 80+colO) CALL Drawfrm(5+rowO, 2+colO, r, 78+colO, defattr, "'" + RTRIM$(Names(it)) + " Bench", "Dbl-click (or Enter) selection or ESC", 1, 0, 2) IF Av > (r-7-rowO) THEN x1$ = "µ": x2$ = "¶" col2 = 78+colO row2 = (5 + rowO + r ) \ 2 - 1 QPRINTs row2, col2, x1$, defattr QPRINTs row2 + 1, col2, UpPtr$, defattr QPRINTs row2 + 2, col2, DnPtr$, defattr QPRINTs row2 + 3, col2, x2$, defattr END IF xS$ = " Name P AB HIT 2B 3B HR RBI BB SO B S SB CS Def Avg" IF ERRSw(it) THEN MID$(xS$, 67, 3) = "ERR" QPRINTs 6+rowO, 3+colO, xS$, defattr 'Row and Col are coordinates of the upper-left corner of the FRAME ' (PlyList() AS PlyListType, ItemsInList, ItemsInColumn, Columns, ItemLen, row, col, row2, col2, colattr, revattr, Pick, RetKey, OutDevice$, FreezePtr) CALL PickFromPlyList (PlyList(), Av, r-7-rowO, 1, 74, 6+rowO, 2+colO, r, 78+colO, dimattr, revattr, Pick, RetKey, nulls$, 0) IF Pick > 0 THEN m = PlyList(Pick).Ref ELSE m = 0 ERASE PlyList GOTO P999 END IF IF iused(m, it) THEN CALL PopMsg(r, 16+colO, " Player has already hit the showers! Try again. ", errattr, 2, kc) GOTO P5 END IF 'Is the selected player's name identical to a current or used pitcher? ie = 0 FOR i = 1 TO np(it) IF DataName(m, it) = DataName(iyp(i,it), it) THEN ie = -1 NEXT IF ie THEN CALL PopMsg(r, 16+colO, " Already used as a pitcher! Try again. ", errattr, 2, kc) GOTO P5 END IF 'Pinch-hitter selected "m" P50: CALL AddToScoreCrd(it, DataRef(ib, it), "9", "(for PH)") 'EX: IF DataPos(ib, it) = 1 THEN 'Pinch hitting for pitcher CALL CountAvPitchers (it, AvP, LastGuy) IF AvP < 1 THEN IF NOT amgr(it) THEN CALL PopMsg(r, 23+colO, " You don't have any pitchers left! ", errattr, 2, kc) END IF m = 0 GOTO P999 END IF CALL Switch(m, ib, it) 'Pinch hitter takes pitchers spot DataPos(ib, it) = 1 'Call pinch hitter a pitcher temporarily iused(m, it) = TRUE 'Mark replaced hitter (the old pitcher) as used 'I question whether the above statement should use a reference number 'instead of "m" iused(ipa(it), it) = TRUE 'Mark old pitcher as used in his pitcher slot ELSE 'Pinch hitting for a non-pitcher OldPos = DataPos(ib, it) 'Save defensive position of player being pulled CALL Switch(m, ib, it) 'Call switch routine to swap players M and IB on team IT DataPos(ib, it) = OldPos 'Pinch hitter goes into play the old defensive position iused(m, it) = TRUE 'Mark replaced hitter as used ' see comment above END IF CALL AddToRefByBO (ib, it, DataRef(ib, it)) 'bat position, team, ref P999: IF NOT amgr(it) THEN QPop IF Gfx THEN CALL EliminateHole(30) CALL UnfreezeAndRefresh END IF END IF EXIT SUB ErrorTrap: LOCATE 10, 30 PRINT "ERROR: PinchH "; ERRCLEAR x$ = WAITKEY$ END SUB SUB PinchRun (m, runner) ON ERROR GOTO ERRORTRAP IF amgr(it) THEN IF m > LastPiAd(it) THEN 'AutoManager has already selected PRunner GOTO PR50 ELSE GOTO PR999 END IF END IF QPush 'Display baserunners IF ir1 = 0 AND ir2 = 0 AND ir3 = 0 THEN CALL PopMsg(18+rowO, 27+colO, " There are no baserunners! ", errattr, 2, kc) GOTO PR999 END IF 'What if there's only 1 baserunner? IF (ir1 > 0 AND ir2 = 0 AND ir3 = 0) THEN runner = ir1: GOTO PR12 IF (ir2 > 0 AND ir1 = 0 AND ir3 = 0) THEN runner = ir2: GOTO PR12 IF (ir3 > 0 AND ir1 = 0 AND ir2 = 0) THEN runner = ir3: GOTO PR12 'Display Baserunners IF Gfx THEN CALL GraphHole(30, 2+rowO, 8+colO, 9+rowO, 74+colO) CALL Drawfrm(2+rowO, 8+colO, 8+rowO, 72+colO, defattr, nulls$, nulls$, 1, 0, 1) QPRINTs 3+rowO, 27+colO, "The Baserunners are:", defattr k = 4 + rowO 'Line counter IF ir1 THEN xS$ = LASTNAME$(DataName(ir1, it)) z$ = "1) First Base - " + xS$ QPRINTs k, 27+colO, z$, defattr END IF IF ir2 THEN INCR k xS$ = LASTNAME$(DataName(ir2, it)) z$ = "2) Second Base - " + xS$ QPRINTs k, 27+colO, z$, defattr END IF IF ir3 THEN INCR k xS$ = LASTNAME$(DataName(ir3, it)) z$ = "3) Third Base - " + xS$ QPRINTs k, 27+colO, z$, defattr END IF 'Find out who we are pinch running for: PR10: QPRINTs 7+rowO, 10+colO, "Indicate by base number who you are running for [1 2 3]: ", defattr n = VAL(MYINPUT$(FALSE, KeyEscape, CustomEscKey, KeyAccept, kc, revfor, revbac, 7+rowO, 67+colO, 1, "NE", 1, 3, nulls$, msx, msy)) 'Handle all mouse stuff here since the edit code is "NE" which doesn't 'return anything through MYINPUT$ 'Any "bad" mouse click should close this and return IF msx > 0 AND msy > 0 THEN a$ = CHR$(SCREEN(msy, msx)) IF a$ > "0" AND a$ < "4" THEN QPRINTs 7+rowO, 67+colO, a$, defattr n = VAL(a$) ELSE n = 0 END IF END IF IF n = 0 THEN m = 0 GOTO PR999 END IF IF (n = 1 AND ir1 = 0) OR (n = 2 AND ir2 = 0) OR (n = 3 AND ir3 = 0) THEN CALL MyBeep GOTO PR10 END IF IF n = 1 THEN runner = ir1 IF n = 2 THEN runner = ir2 IF n = 3 THEN runner = ir3 PR12: 'Build Bench List REDIM PlyList(1 TO 30) AS PlyListType Av = 0 FOR j = LastPiAd(it) + 1 TO MAXPLAYERS IF Av < 30 THEN IF DataName(j, it) < "." THEN pend = j - 1: EXIT FOR IF DataAB(j, it) = 0 THEN BAF! = 0 ELSE BAF! = DataHits(j, it) / DataAB(j, it) END IF ' IF iused(j, it) THEN flag$ = CHR$(251) ELSE flag$ = " " IF iused(j, it) THEN flag$ = "x" ELSE flag$ = " " 'Is the bench player's name identical to a current or used pitcher? FOR i = 1 TO np(it) IF DataName(j, it) = DataName(iyp(i,it), it) THEN flag$ = "x" NEXT 'f$ = "\\\ \ \\ ### ### ### ## ### ### ### ### \\## ### ## ### .###" a$ = SPACE$(73) MID$(a$, 1, 1) = flag$ MID$(a$, 3, 16) = DataName(j, it) MID$(a$, 20, 2) = Pos(DataPos(j, it)) MID$(a$, 23, 3) = LFORMAT$(DataAB(j, it), "###") MID$(a$, 27, 3) = LFORMAT$(DataHits(j, it), "###") MID$(a$, 31, 3) = LFORMAT$(Data2B(j, it), "###") MID$(a$, 35, 2) = LFORMAT$(Data3B(j, it), "##") MID$(a$, 38, 3) = LFORMAT$(DataHR(j, it), "###") MID$(a$, 42, 3) = LFORMAT$(DataRBI(j, it), "###") MID$(a$, 46, 3) = LFORMAT$(DataBB(j, it), "###") MID$(a$, 50, 3) = LFORMAT$(DataSO(j, it), "###") MID$(a$, 54, 1) = DataHand(j, it) MID$(a$, 56, 2) = LFORMAT$(DataSpeed(j, it), "##") MID$(a$, 59, 3) = LFORMAT$(DataSB(j, it), "###") MID$(a$, 63, 2) = LFORMAT$(DataCS(j, it), "##") MID$(a$, 66, 3) = LFORMAT$(DataDef(j, it), "###") MID$(a$, 70, 4) = FFORMAT$(BAF!, ".###") INCR Av PlyList(Av).Item = a$ PlyList(Av).Ref = j END IF NEXT 'Display/Pick Player PR15: r = Av + 12 + rowO IF r > (ConsRows-2) THEN r = ConsRows-2 IF Gfx THEN CALL GraphHole(32, 10+rowO, 2+colO, r+1, 80+colO) CALL Drawfrm(10+rowO, 2+colO, r, 78+colO, defattr, "'" + RTRIM$(Names(it)) + " Bench", "Dbl-click (or Enter) selection or ESC", 1, 0, 2) IF Av > (r-12-rowO) THEN x1$ = "µ": x2$ = "¶" col2 = 78+colO row2 = (10 + rowO + r ) \ 2 - 1 QPRINTs row2, col2, x1$, defattr QPRINTs row2 + 1, col2, UpPtr$, defattr QPRINTs row2 + 2, col2, DnPtr$, defattr QPRINTs row2 + 3, col2, x2$, defattr END IF xS$ = " Name P AB HIT 2B 3B HR RBI BB SO B S SB CS Def Avg" IF ERRSw(it) THEN MID$(xS$, 67, 3) = "ERR" QPRINTs 11+rowO, 3+colO, xS$, defattr 'Row and Col are coordinates of the upper-left corner of the FRAME CALL PickFromPlyList (PlyList(), Av, r-12-rowO, 1, 74, 11+rowO, 2+colO, r, 78+colO, dimattr, revattr, Pick, RetKey, nulls$, 0) IF Pick > 0 THEN m = PlyList(Pick).Ref ELSE m = 0 ERASE PlyList GOTO PR999 END IF IF iused(m, it) THEN CALL PopMsg(r, 17+colO, " You've already used that guy! Try again. ", errattr, 2, kc) GOTO PR15 END IF 'Fix: 2/23/05 'Is the selected player's name identical to a current or used pitcher? ie = 0 FOR i = 1 TO np(it) IF DataName(m, it) = DataName(iyp(i,it), it) THEN ie = -1 NEXT IF ie THEN CALL PopMsg(r, 17+colO, " Already used as a pitcher! Try again. ", errattr, 2, kc) GOTO PR15 END IF PR50: 'Pinch-runner has been seleted (m) 'Pinch running for the pitcher CALL AddToScoreCrd(it, DataRef(runner, it), "9", "(for PR)") 'EX: IF DataPos(runner, it) = 1 THEN CALL CountAvPitchers (it, AvP, LastGuy) IF AvP < 1 THEN IF NOT amgr(it) THEN CALL PopMsg(18+rowO, 20+colO, " You don't have any pitchers left! ", errattr, 2, kc) m = 0 GOTO PR999 END IF 'Mark old pitcher as used iused(ipa(it), it) = TRUE 'info 09/03/05 ' x$ = "Runner=" + STR$(runner) + "|" ' x$ = x$ + "ipa(it)=" + STR$(ipa(it)) + "|" ' x$ = x$ + "DataRef(runner,it)=" + STR$(DataRef(runner,it)) ' CALL ErrorBox (x$) END IF 'Swap players m (from the bench) and runner on team "it" OldPos = DataPos(runner, it) CALL Switch(m, runner, it) DataPos(runner, it) = OldPos iused(m, it) = TRUE 'I wonder if this should be the ref#(m) instead CALL AddToRefByBO (runner, it, DataRef(runner, it)) 'bat pos, team, ref CALL AddToScoreCrd(it, DataRef(runner, it), "7", "") PR999: IF NOT amgr(it) THEN QPop IF Gfx THEN CALL EliminateHole(30) CALL EliminateHole(32) CALL UnfreezeAndRefresh END IF END IF EXIT SUB ErrorTrap: LOCATE 10, 30 PRINT "ERROR: PinchR "; ERRCLEAR x$ = WAITKEY$ END SUB SUB PitchersWLS (team, player, w, l, s, era!) w = 0 l = 0 s = 0 era! = 0. IF CmdStat$ > "!" THEN Find$ = League(team) + PADRIGHT$(Names(team), 12) + PADRIGHT$(NameRef(player, team), 16) TotalRecs = PSum(0).PGameCtr CALL BinarySearchP (PSum(), 1, 29, 1, TotalRecs, Find$, FoundAt, mini) IF FoundAt THEN w = PSum(FoundAt).PWin l = PSum(FoundAt).PLoss s = PSum(FoundAt).PSave IF PSum(FoundAt).PInns > 0 THEN era! = PSum(FoundAt).PERuns * 9.0 / _ (PSum(FoundAt).PInns + PSum(FoundAt).P3rds / 3) IF era! > 99.9 THEN era! = 99.9 ELSE era! = 0. END IF END IF END IF END SUB SUB PopMsg (row, col, xS$, attr, waittime, kc) ' row, col are Upper Left Corner ' Support string argument parsed by "|" n = PARSECOUNT(xS$, "|") ' Find length of the longest segment LMax = 0 FOR i = 1 TO n x$ = PARSE$(xS$, "|", i) L = LEN(x$) IF L > LMax THEN LMax = L NEXT 'Save screen IF Gfx AND RegDsply THEN CALL GraphHole(31, row, col, row+n-1, col+LMax-1) END IF CALL GetScreen(ScrString$, row, col, row+n-1, col+LMax-1) 'Print r = row FOR i = 1 TO n x$ = PARSE$(xS$, "|", i) L = LEN(x$) IF L < LMax THEN x$ = x$ + SPACE$(LMax - L) QPRINTs r, col, x$, attr INCR r NEXT 'Pause for reply IF waittime THEN SLEEP waittime * 1000 kc = 0 ELSE a$ = WAITKEY$ IF LEN(a$) = 4 THEN kc = SCREEN(MOUSEY, MOUSEX) ELSE kc = ASC(a$) END IF END IF 'Restore screen CALL PutScreen(ScrString$, row, col, row+n-1, col+LMax-1) IF Gfx AND RegDsply THEN CALL EliminateHole(31) CALL UnfreezeAndRefresh END IF END SUB SUB PopWindow (row1, col1, row2, col2, win) ' win = 1 is offense window, = 2 is defense window COLOR deffor, defbac col = col1 + 1 IF win = 1 THEN QPRINTs row1 + 1, col, " On Off", defattr QPRINTs row1 + 2, col, " EXIT ", defattr QPRINTs row1 + 3, col, " Pinch Hit ", defattr QPRINTs row1 + 4, col, " Pinch Run ", defattr QPRINTs row1 + 5, col, " View Line-up ", defattr QPRINTs row1 + 6, col, " View Opponent ", defattr IF WarmUpRule THEN attr = defattr ELSE attr = CALCATTR(0, 1) 'black on blue QPRINTs row1 + 7, col, " Call Bullpen ", attr QPRINTs row1 + 8, col, " ŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽ- ", defattr QPRINTs row1 + 9, col, " Steal ", defattr QPRINTs row1 + 10, col, " Bunt/Squeeze ", defattr QPRINTs row1 + 11, col, " Hit & Run ", defattr END IF IF win = 2 THEN QPRINTs row1 + 1, col, " On Off", defattr QPRINTs row1 + 2, col, " EXIT ", defattr QPRINTs row1 + 3, col, " Visit Mound ", defattr QPRINTs row1 + 4, col, " Substitute ", defattr QPRINTs row1 + 5, col, " Swap Positions ", defattr QPRINTs row1 + 6, col, " View Line-up ", defattr QPRINTs row1 + 7, col, " View Opponent ", defattr QPRINTs row1 + 8, col, " ŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽ- ", defattr QPRINTs row1 + 9, col, " Intent. Walk ", defattr QPRINTs row1 + 10, col, " Infield In ", defattr QPRINTs row1 + 11, col, " Pitch-Out ", defattr QPRINTs row1 + 12, col, " Pitch-Around ", defattr END IF END SUB SUB PostAnnouncer (delayy) REGISTER i AS INTEGER, c AS INTEGER L = 38 + colO xS$ = SPACE$(L) IF DelFac = 0 AND amgr(1) AND amgr(2) THEN QPRINTs 2, 42, xS$, scdattr QPRINTs 3, 42, " Quick Play Mode ", scdattr QPRINTs 4, 42, xS$, scdattr ELSE 'Is it an "instant win" situation? IF inn >= RegInns AND it = 2 THEN IF itruns(2) > itruns(1) THEN IF IGone THEN AddToAnnouncer it, "Gone!" AddToAnnouncer it, "Game's over!" END IF END IF c = 0 FOR i = 1 TO ANx 'Clear Box Method IF i = 1 OR i = 4 OR i = 7 OR i = 10 THEN QPRINTs 2, 42, xS$, scdattr QPRINTs 3, 42, xS$, scdattr QPRINTs 4, 42, xS$, scdattr c = 0 END IF INCR c QPRINTs c + 1, 42, LEFT$(Announcer(i).mgs, L), scdattr IF i < ANx THEN IF delayy THEN IF i = 1 THEN IF OrgWhoAtPos THEN WhoAtPos = OrgWhoAtPos IF WhoAtPos THEN CALL Flash(WhoAtPos, FALSE) END IF SLEEP (DelFac * 300) END IF END IF NEXT END IF END SUB SUB PrintSCHHelp CALL Drawfrm(12+rowO, 8+colO, 24+rowO, 71+colO, defattr, nulls$, nulls$, 1, 0, 0) r = 13 + rowO c = 10 + colO QPRINTs r, c, " SCH files are a database of games played by date. You can ", dimattr QPRINTs r+1, c, "interrupt a SCH and the stats and re-start data are saved ", dimattr QPRINTs r+2, c, "so you can continue later (but be sure to specify the same ", dimattr QPRINTs r+3, c, "stat file). ", dimattr QPRINTs r+4, c, " To manage one or more teams yourself, press E to edit the ", dimattr QPRINTs r+5, c, "schedule. Then select the starting date when YOU want to ", dimattr QPRINTs r+6, c, "manage your team(s). In the Options column, type in /vm:+ (to", dimattr QPRINTs r+7, c, "indicate you wish to manage the visiting team) or /hm:+ (to ", dimattr QPRINTs r+8, c, "indicate the home team). To remove your team(s) from manual ", dimattr QPRINTs r+9, c, "control type in /vm:- or /hm:- on the date when you want the ", dimattr QPRINTs r+10,c, "computer to take over. See documentation for details. ", dimattr END SUB SUB PrintSERHelp CALL Drawfrm(12+rowO, 8+colO, 23+rowO, 71+colO, defattr, nulls$, nulls$, 1, 0, 0) r = 13 + rowO c = 10 + colO QPRINTs r, c, " SER files are just a simple text listing of games to be ", dimattr QPRINTs r+1, c, "played. A simulation based on a SER file CANNOT be restarted ", dimattr QPRINTs r+2, c, "at the point it was interrupted, so you usually want to let ", dimattr QPRINTs r+3, c, "them finish once you start one. Generally you want SBS to ", dimattr QPRINTs r+4, c, "manage all the teams and crank through the simulation as ", dimattr QPRINTs r+5, c, "quickly as possible. ", dimattr QPRINTs r+6, c, " Hit [V] or [E] to view or edit. Notice that /H: and /V: ", dimattr QPRINTs r+7, c, "specify home and visitor and /n: specifies the number of ", dimattr QPRINTs r+8, c, "games to run. Those are usually the only options that a SER ", dimattr QPRINTs r+9, c, "file uses. See documentation for details. ", dimattr END SUB SUB PrintSTAHelp CALL Drawfrm(14+rowO, 8+colO, 22+rowO, 71+colO, defattr, nulls$, nulls$, 1, 0, 0) r = 15 + rowO c = 10 + colO QPRINTs r, c, " These are the statistics files that have been specified by", dimattr QPRINTs r+1, c, "the user in the [Statistics Recording Options] window. No ", dimattr QPRINTs r+2, c, "matter which simulation type you choose (manual, two-team, ", dimattr QPRINTs r+3, c, "SCH or SER) you have the option of saving the statistics that", dimattr QPRINTs r+4, c, "are generated. You can then build a report at any time by ", dimattr QPRINTs r+5, c, "selecting the file. Or hit the [Delete] key to permanently ", dimattr QPRINTs r+6, c, "discard the file. ", dimattr END SUB SUB Prompt (special) STATIC QPRINTs ConsRows, 1, SPACE$(ConsCols - 9), scdattr QPRINTs ConsRows, ConsCols - 11, " SBS v4.9", scoattr IF MenuOpt$ = "M" THEN QPRINTs ConsRows, 59, "Manual ", scdattr IF MenuOpt$ = "S" THEN QPRINTs ConsRows, 59, "Schedule", scdattr IF MenuOpt$ = "E" THEN QPRINTs ConsRows, 59, "Series ", scdattr IF MenuOpt$ = "T" THEN QPRINTs ConsRows, 59, "Two-Team", scdattr IF special > 0 THEN 'closing xS$ = " New Box Card Results Stats Doc Quit " QPRINTs ConsRows, 1, xS$, scdattr a = ConsRows: b = 2: c = 1: d = prmfor: e = prmbac GOSUB PromptSub1 b = 7 GOSUB PromptSub1 b = 12 GOSUB PromptSub1 b = 18 GOSUB PromptSub1 b = 27 GOSUB PromptSub1 b = 34 GOSUB PromptSub1 b = 39 GOSUB PromptSub1 ELSEIF amgr(1) AND amgr(2) THEN QPRINTs ConsRows, 1, " ptions ox ard esults ", scdattr QPRINTs ConsRows, 2, "O", prmattr QPRINTs ConsRows, 11, "B", prmattr QPRINTs ConsRows, 16, "C", prmattr QPRINTs ConsRows, 22, "R", prmattr IF DelFac = 0 THEN QPRINTs ConsRows, 31, " oggle Display uit ", scdattr QPRINTs ConsRows, 31, "T", prmattr QPRINTs ConsRows, 47, "Q", prmattr ELSE QPRINTs ConsRows, 31, " uit ", scdattr QPRINTs ConsRows, 31, "Q", prmattr END IF ELSE 'min len = 37 max len = 54 xS$ = EnterPtr$ + " Options Box Card Doc " IF NewUI = TRUE THEN IF NOT amgr(1) THEN xS$ = xS$ + "Visitor " IF NOT amgr(2) THEN xS$ = xS$ + "Home " ELSE IF NOT amgr(1) THEN xS$ = xS$ + "S=Visi " IF NOT amgr(2) THEN xS$ = xS$ + "5=Home " END IF xS$ = xS$ + "Quit " LLeng = LEN(xS$) QPRINTs ConsRows, 1, xS$, scdattr a = ConsRows: b = 2: c = 3: d = prmfor: e = prmbac GOSUB PromptSub1 b = 7: c = 1 GOSUB PromptSub1 'Options b = 16 GOSUB PromptSub1 'Box b = 21 GOSUB PromptSub1 'Card b = 27 GOSUB PromptSub1 'Doc b = 32 GOSUB PromptSub1 'catch the Quit IF LLeng > 36 THEN b = LLeng - 4 GOSUB PromptSub1 END IF 'catch Home if both Visi and Home IF LEN(xS$) = 51 THEN 'Visitor Home Quit ' b = 41 GOSUB PromptSub1 END IF IF LEN(xS$) = 52 THEN 'S=Visi 5=Home Quit ' b = 40 GOSUB PromptSub1 END IF END IF LOCATE 1, 1 CURSOR OFF EXIT SUB PromptSub1: attr = (e * 16) + d CALL ChangeAttribute(a, b, c, attr) RETURN END SUB SUB PutPitHitStatsInBO FOR tm = 1 TO 2 j = 0 DO IF j > 8 THEN j = 9: EXIT DO INCR j LOOP UNTIL DataPos(j, tm) = 1 CALL MovePitHitStats (j, tm) 'puts hitting stats in slot j NEXT END SUB SUB PutScreen (ScrSave$, row1, col1, row2, col2) IF ConsRows = 25 THEN BeginBuffer i = 1 FOR r = row1 TO row2 FOR c = col1 TO col2 b$ = MID$(ScrSave$, i, 1) attr = ASC(MID$(ScrSave$, i+1, 1)) QPRINTs r, c, b$, attr i = i + 2 NEXT NEXT IF ConsRows = 25 THEN EndBuffer END SUB SUB QPRINTs (row AS LONG, col AS LONG, xS$, attr AS LONG) IF ConsRows = 25 AND ConsCols = 80 AND Gfx = FALSE THEN QPRINT row, col, xS$, attr ELSE L = LEN(xS$) LOCATE row, col forg = attr MOD 16 bacg = attr \ 16 COLOR forg, bacg IF (col + L) < (ConsCols + 2) THEN PRINT xS$; END IF END SUB SUB QSortRand (myfile$, fp, Reclen, start, leng, ASCorDES$) OPEN myfile$ FOR BINARY AS fp RecCount = LOF(fp) \ Reclen CALL QSRand(1, RecCount, fp, Reclen, start, leng) CLOSE fp END SUB SUB QSRand (L, R, fp, Reclen, start, leng) ' Does not support "Descending" order! i = L: j = R s = (L + R) \ 2 IF s < 1 THEN BEEP: PRINT " Sort Error "; : GOTO QSRandEscape xsortfield$ = FindRA$(s, fp, Reclen, start, leng) DO DO WHILE FindRA$(i, fp, Reclen, start, leng) < xsortfield$ INCR i LOOP DO WHILE xsortfield$ < FindRA$(j, fp, Reclen, start, leng) DECR j LOOP IF i <= j THEN SEEK fp, (i - 1) * Reclen + 1 GET$ fp, Reclen, y$ SEEK fp, (j - 1) * Reclen + 1 GET$ fp, Reclen, z$ SEEK fp, (j - 1) * Reclen + 1 PUT$ fp, y$ SEEK fp, (i - 1) * Reclen + 1 PUT$ fp, z$ INCR i DECR j END IF LOOP UNTIL i > j IF L < j THEN CALL QSRand(L, j, fp, Reclen, start, leng) IF L < R THEN CALL QSRand(i, R, fp, Reclen, start, leng) QSRandEscape: END SUB SUB ReadFromScreen (row, col, leng, field$, edit$, Valid$) STATIC field$ = "" L = col + leng - 1 FOR c = col TO L field$ = field$ + CHR$(SCREEN(row, c)) NEXT c Valid$ = "Y" x1$ = MID$(edit$, 1, 1) x2$ = MID$(edit$, 2, 1) IF x2$ = "R" THEN 'Required IF field$ = SPACE$(leng) THEN Valid$ = "N" END IF IF x1$ = "N" THEN IF x2$ = "E" OR x2$ = " " THEN IF NOT NUMERIC(field$, TRUE, FALSE) THEN Valid$ = "N" ELSE IF NOT NUMERIC(field$, FALSE, FALSE) THEN Valid$ = "N" END IF END IF END SUB SUB ReadSCHSlot SubRecOff = 10 + (SchSlotPtr - 1) * SubRecLen CmdVFil$ = UCASE$(RTRIM$(MID$(SchBuffer$, SubRecOff + VisiOffset, 8))) CmdHFil$ = UCASE$(RTRIM$(MID$(SchBuffer$, SubRecOff + HomeOffset, 8))) CmdSlotGames = 1 xS$ = MID$(SchBuffer$, SubRecOff + OptiOffset, 12) IF xS$ <> SPACE$(12) THEN 'just parses the option list CALL ParseCommand (xS$, nargs) CALL SetSwitches (nargs) END IF 'Scan Rest Of SCHRec IF SchSlotPtr = SchGamesPerRecord THEN 'formerly 7 LastGameThisDate = TRUE ELSE LastGameThisDate = TRUE FOR i = SchSlotPtr + 1 TO SchGamesPerRecord 'formerly 7 SubRecOff = 10 + (i - 1) * SubRecLen xS$ = MID$(SchBuffer$, SubRecOff + VisiOffset, 8) yS$ = MID$(SchBuffer$, SubRecOff + HomeOffset, 8) IF xS$ > "!" AND yS$ > "!" THEN LastGameThisDate = FALSE EXIT FOR END IF NEXT END IF 'If looking for Specific League/Team/Date, is it here? FilterOK = TRUE 'One League only? 'File name must be YYLTTTTT.DAT or YYYYLTTT.DAT IF LEN(CmdFavLeague$) THEN IF LEN(CmdVFil$) AND LEN(CmdHFil$) THEN IF NUMERIC(MID$(CmdVFil$, 1, 4), FALSE, FALSE) THEN xS$ = MID$(CmdVFil$, 5, 1) ELSE xS$ = MID$(CmdVFil$, 3, 1) END IF IF NUMERIC(MID$(CmdHFil$, 1, 4), FALSE, FALSE) THEN yS$ = MID$(CmdHFil$, 5, 1) ELSE yS$ = MID$(CmdHFil$, 3, 1) END IF xS$ = UCASE$(xS$) yS$ = UCASE$(yS$) IF CmdFavLeague$ <> xS$ AND CmdFavLeague$ <> yS$ THEN FilterOK = FALSE END IF END IF 'One Team only? IF LEN(CmdFavTeam$) THEN IF LEN(CmdVFil$) AND LEN(CmdHFil$) THEN IF CmdFavTeam$ <> CmdVFil$ AND CmdFavTeam$ <> CmdHFil$ THEN FilterOK = FALSE END IF END IF 'If Date Range is active, is this date OK? IF LEN(CmdDateL$) AND LEN(CmdDateH$) THEN IF SCHDate$ < CmdDateL$ OR SCHDate$ > CmdDateH$ THEN FilterOK = FALSE END IF END SUB SUB ResetBatter ResetHitter = TRUE DECR ibp(it) DECR mab(ref, it) IF UCASE$(DataHand(ip, id)) = "L" THEN DECR mabLHP(ref, it) ELSE DECR mabRHP(ref, it) END IF END SUB SUB RestFrSnapShot FOR it = 1 TO 2 REDIM Positions (10) FOR i = 1 TO 9 Positions(DataPos(i,it)) = 1 NEXT FOR i = 2 TO 9 IF Positions(i) = 0 THEN x$ = "RESTFRSNAP1 error: Defense position " + STR$(i) + " is empty " CALL ErrorBox (x$) END IF NEXT NEXT FOR it = 1 TO 2 L = 1 DO UNTIL L > MAXPLAYERS j = RefOrgSave(L, it).RefNo 'Search For Reference #j FoundSw = FALSE k = 1 DO UNTIL k > MAXPLAYERS IF DataRef(k, it) = j THEN FoundSw = TRUE: EXIT DO INCR k IF k = 10 THEN k = LastPiAd(it) + 1 LOOP IF FoundSw THEN IF k <> L THEN CALL Switch(L, k, it) END IF END IF DataPos(L, it) = RefOrgSave(L, it).RefPos INCR L IF L = 10 THEN L = LastPiAd(it) + 1 LOOP NEXT FOR it = 1 TO 2 REDIM Positions (10) FOR i = 1 TO 9 Positions(DataPos(i,it)) = 1 NEXT FOR i = 2 TO 9 IF Positions(i) = 0 THEN x$ = "RESTFRSNAP2 error: Defense position " + STR$(i) + " is empty " CALL ErrorBox (x$) END IF NEXT NEXT END SUB SUB RotationMethIO (Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) CALL Drawfrm(6+rowO, 16+colO, 15+rowO, 64+colO, defattr, "Default Pitching Rotation Method", "ESC:Continue F3:Abort", 1, 0, 2) DATA 8,25,"Number In Rotation [2-5]: ",08,58, 1,"X " DATA 10,25,"[S]equential or [R]andom Order?: ",10,58, 1,"X " DATA 12,25,"Use Spot Starters?: ",12,58, 1,"X " Flds = 3 c = 1 FOR i = 1 TO Flds Flitrow(i) = VAL(READ$(c)) + rowO Flitcol(i) = VAL(READ$(c+1)) + colO Flit$(i) = READ$(c+2) Frow(i) = VAL(READ$(c+3)) + rowO Fcol(i) = VAL(READ$(c+4)) + colO Flen(i) = VAL(READ$(c+5)) Fed$(i) = READ$(c+6) c = c + 7 NEXT REDIM FContents$(13) FContents$(1) = "5" FContents$(2) = "S" FContents$(3) = "Y" CursorPtr = 1 DO RotationMethLoop: CALL ScreenIO(Keyed, KeyF3, 0, KeyEsc, Flds, CursorPtr, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) IF Keyed = KeyF3 THEN CmdSP$ = nulls$ EXIT SUB END IF 'Edit Field Contents Error1$ = "N" IF INSTR("12345", FContents$(1)) = 0 THEN Error1$ = "Y" CursorPtr = 1 GOTO RotationMethLoop END IF IF INSTR("RS12345", FContents$(2)) = 0 THEN Error1$ = "Y" CursorPtr = 2 GOTO RotationMethLoop END IF IF INSTR("YN", FContents$(3)) = 0 THEN Error1$ = "Y" CursorPtr = 3 END IF LOOP WHILE Error1$ = "Y" CmdSpot$ = FContents$(3) CmdSP$ = FContents$(2) + FContents$(1) END SUB SUB SameTeamsSetup (kc, Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) CALL DrawFrm(18+rowO, 22+colO, 22+rowO, 61+colO, defattr, nulls$, "ESC:Continue F3:Cancel", 0, 0, 2) FContents$(1) = "N" Flds = 1 DATA 20,24,"Play again with same teams? [y/N] ",20,58,01,"X " c = 1 FOR i = 1 TO Flds Flitrow(i) = VAL(READ$(c)) + rowO Flitcol(i) = VAL(READ$(c+1)) + colO Flit$(i) = READ$(c+2) Frow(i) = VAL(READ$(c+3)) + rowO Fcol(i) = VAL(READ$(c+4)) + colO Flen(i) = VAL(READ$(c+5)) Fed$(i) = READ$(c+6) c = c + 7 NEXT CursorPtr = 1 DO s = defattr defattr = dimattr CALL ScreenIO(Keyed, KeyF3, 0, KeyEsc, Flds, CursorPtr, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) defattr = s ErrorSw$ = "N" 'Cancel IF Keyed = KeyF3 THEN EXIT DO IF FContents$(1) <> "Y" AND FContents$(1) <> "N" THEN ErrorSw$ = "Y" LOOP WHILE ErrorSw$ = "Y" kc = Keyed END SUB SUB SCHDateTeamIO (Keyed, Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) DATA 08,20,"Single League [A/N] :",08,43, 1,"X " DATA 10,20,"Single Team [filename]:",10,43, 8,"X " DATA 12,20,"Date Range [MM/DD/YY]:",12,43, 8,"X " DATA 12,51,"-", 12,52, 8,"X " Flds = 4 c = 1 FOR i = 1 TO Flds Flitrow(i) = VAL(READ$(c)) + rowO Flitcol(i) = VAL(READ$(c+1)) + colO Flit$(i) = READ$(c+2) Frow(i) = VAL(READ$(c+3)) + rowO Fcol(i) = VAL(READ$(c+4)) + colO Flen(i) = VAL(READ$(c+5)) Fed$(i) = READ$(c+6) c = c + 7 NEXT REDIM FContents$(13) CursorPtr = 1 CALL Drawfrm(6+rowO, 18+colO, 15+rowO, 61+colO, defattr, "Schedule Filter", "ESC:Continue F3:Abort", 1, 0, 2) QPRINTs 14+rowO, 27+colO,"[Leave Blank for All Games]", dimattr DO CALL ScreenIO(Keyed, KeyF3, 0, KeyEsc, Flds, CursorPtr, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) 'Trap F3 IF Keyed = KeyF3 THEN EXIT SUB 'Edit Field Contents Error1$ = "N" CmdFavLeague$ = UCASE$(RTRIM$(FContents$(1))) CmdFavTeam$ = UCASE$(RTRIM$(FContents$(2))) CmdDateL$ = RTRIM$(FContents$(3)) CmdDateH$ = RTRIM$(FContents$(4)) IF LEN(CmdDateH$) THEN IF NOT ValidMMDDYY(CmdDateH$) THEN MyBeep LOCATE 13+rowO, 23+colO: PRINT "** Date must be in MM/DD/YY form **"; SLEEP 1000 CursorPtr = 4 Error1$ = "Y" END IF END IF IF LEN(CmdDateL$) THEN IF NOT ValidMMDDYY(CmdDateL$) THEN MyBeep LOCATE 13+rowO, 20+colO: PRINT "** Date must be in MM/DD/YY form **"; SLEEP 1000 CursorPtr = 3 Error1$ = "Y" END IF END IF IF LEN(CmdFavTeam$) THEN k = CountGamesInSCH (nulls$, CmdFavTeam$, nulls$, nulls$, SubRecLen, VisiOffset, HomeOffset, OptiOffset) IF k = 0 THEN MyBeep LOCATE 13+rowO, 20+colO: PRINT "** Team does not appear in .SCH! **"; SLEEP 1000 CursorPtr = 2 Error1$ = "Y" END IF END IF LOOP WHILE Error1$ = "Y" IF LEN(CmdDateL$) > 0 AND LEN(CmdDateH$) = 0 THEN CmdDateH$ = CmdDateL$ END SUB SUB ScreenIO (Keyed, EscKey, CustomEscKey, AcceptKey, Flds, CursorPtr, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) ' Print screen literals and field contents ' Flen's which are NEGATIVE are to be dimmed and skipped FOR i = 1 TO Flds IF Flitrow(i) > 0 AND Flitrow(i) <= ConsRows AND Flitcol(i) > 0 AND Flitcol(i) <= ConsCols THEN IF Flen(i) < 0 THEN attr = dimattr ELSE attr = defattr QPRINTs Flitrow(i), Flitcol(i), Flit$(i), attr END IF IF Frow(i) > 0 AND Frow(i) <= ConsRows AND Fcol(i) > 0 AND Fcol(i) <= ConsCols THEN IF Flen(i) < 0 THEN attr = dimattr ELSE attr = revattr 'Print field contents or blanks IF LEN(FContents$(i)) = 0 THEN QPRINTs Frow(i), Fcol(i), SPACE$(ABS(Flen(i))), attr ELSE QPRINTs Frow(i), Fcol(i), PADRIGHT$(FContents$(i), ABS(Flen(i))), attr END IF END IF NEXT i InsToggle = 0 'overwrite mode CsrSize = 100 ' Find 1st Input Field (not necessarily Fld = 1) ' Flen's which are NEGATIVE are to be dimmed and skipped i = 1 DO WHILE Frow(i) = 0 OR Fcol(i) = 0 OR Flen(i) < 0 INCR i IF i > Flds THEN i = 1: EXIT DO LOOP FirstInputField = i Fldptr = CursorPtr LOCATE Frow(Fldptr), Fcol(Fldptr) COLOR revfor, revbac ' Loop until Escape-Key. Data is manipulated on-screen and returned in the ' FContents$() array DO ResetPtr: GOSUB ScrIOSpecialCases 'ResetPtr: row = Frow(Fldptr) col = Fcol(Fldptr) leng = ABS(Flen(Fldptr)) 'Just in case I screwed up edit$ = Fed$(Fldptr) default$ = FContents$(Fldptr) 'Get Input from keyboard or mouse FContents$(FldPtr) = MYINPUT$(TRUE, EscKey, CustomEscKey, AcceptKey, kc, revfor, revbac, row, col, leng, edit$, 0, 999999, default$, msx, msy) 'If returning from mouse input (kc=-99), we might have clicked anywhere IF msy > 0 AND msx > 0 THEN 'mouse click somewhere CALL FlashField (msy, msx, 1, 2, 100, 0) IF CHR$(SCREEN(msy, msx)) = CloseButton$ THEN 'ESC button (but accept input) kc = AcceptKey EXIT DO END IF IF CHR$(SCREEN(msy, msx)) = AbortButton$ THEN 'Abort button kc = EscKey EXIT DO END IF 'Did we click in an input field? FOR i = 1 TO Flds IF Frow(i) > 0 AND Fcol(i) > 0 AND Flen(i) > 0 THEN IF msx >= Fcol(i) AND msx < Fcol(i) + Flen(i) AND msy = Frow(i) THEN Fldptr = i GOTO ResetPtr END IF END IF NEXT 'Did we click inside one of the "literal" areas? FOR i = 1 TO Flds IF Flitrow(i) > 0 AND Flitcol(i) > 0 AND Flen(i) > 0 AND _ Frow(i) > 0 AND Fcol(i) > 0 THEN 'Within Literal-Area? IF (msx >= Flitcol(i) AND msx < Flitcol(i) + LEN(FLit$(i)) AND _ msy = Flitrow(i)) THEN Fldptr = i a$ = UCASE$(CHR$(SCREEN(msy, msx))) IF a$ >= "0" AND a$ <= "Z" THEN FContents$(FldPtr) = a$ GOTO ResetPtr END IF END IF NEXT '"TakeFromAnywhere"? IF TakeFromAnywhere = 1 THEN 'DefSwitch Special case a$ = UCASE$(CHR$(SCREEN(msy, msx))) IF a$ >= "0" AND a$ <= "Z" THEN FContents$(FldPtr) = a$ LOCATE row, col PRINT a$; END IF IF TakeFromAnywhere = 2 THEN 'StatRecordIO Special case for F4 IF msy = 8+rowO AND msx > 39+colO AND msx < 44+colO THEN kc = CustomEscKey END IF END IF IF CHR$(SCREEN(msy, msx)) = "+" THEN 'Custom ESC kc = CustomEscKey END IF END IF ' Shift-tab or Up-arrow or Left-arrow IF kc = -15 OR kc = -72 OR kc = -75 THEN DO DECR Fldptr LOOP UNTIL (Frow(Fldptr) <> 0 AND Fcol(Fldptr) <> 0 AND Flen(Fldptr) > 0) OR Fldptr < 1 IF Fldptr < 1 THEN Fldptr = FirstInputField LOCATE Frow(Fldptr), Fcol(Fldptr) ' C/R, R-Tab, Down-arrow, Right-arrow ELSE DO INCR Fldptr IF Fldptr > Flds THEN Fldptr = FirstInputField: EXIT DO LOOP UNTIL Frow(Fldptr) <> 0 AND Fcol(Fldptr) <> 0 AND Flen(Fldptr) > 0 LOCATE Frow(Fldptr), Fcol(Fldptr) END IF LOOP UNTIL kc = EscKey OR kc = AcceptKey OR kc = CustomEscKey Keyed = kc COLOR deffor, defbac LOCATE 1, 1 CURSOR OFF EXIT SUB ScrIOSpecialCases: 'For Ground Rule Screen IF LEFT$(Flit$(1), 9) = "Automatic" THEN FOR i = 2 TO 3 IF FContents$(i) = "Y" THEN xS$ = "Computer will manage '" + Names(i - 1) ELSE xS$ = "Player will manage '" + Names(i - 1) END IF QPRINTs i+2+rowO, 34+colO, xS$, dimattr NEXT END IF RETURN END SUB SUB ScoreBrd (DoFrame, DoAllInns) STATIC ' DoFrame - ' DoAllInns - ' Nothing done with announcer in this routine 'DIM ss AS STRING * 2 ss$ = " " CURSOR OFF IF DoFrame = FALSE THEN GOTO ScoreBoardNumbers END IF 'Scoreboard box xS$ = STRING$(39, 205) QPRINTs 1, 1, "å" + xS$, scoattr QPRINTs 2, 1, "ü 1 2 3 4 5 6 7 8 9 10 R H E", scoattr QPRINTs 3, 1, "ü", scoattr QPRINTs 4, 1, "ü", scoattr QPRINTs 5, 1, "âÖæ ", scoattr QPRINTs 5, 5, "Out:", prmattr x$ = " ’" + LEFT$(xS$, 28) QPRINTs 5, 11, x$, scoattr 'Draw blank announcer's box xS$ = STRING$(ConsCols - 42, 205) QPRINTs 1, 41, CHR$(209), scoattr x$ = xS$ + " " QPRINTs 1, 42, x$, scoattr QPRINTs 2, 41, CHR$(179), scoattr QPRINTs 2, ConsCols, CHR$(179), scoattr QPRINTs 3, 41, CHR$(179), scoattr QPRINTs 3, ConsCols, CHR$(179), scoattr QPRINTs 4, 41, CHR$(179), scoattr QPRINTs 4, ConsCols, CHR$(179), scoattr QPRINTs 5, 41, CHR$(207), scoattr x$ = xS$ + "ó" QPRINTs 5, 42, x$, scoattr xS$ = SPACE$(ConsCols - 42) QPRINTs 2, 42, xS$, scdattr QPRINTs 3, 42, xS$, scdattr QPRINTs 4, 42, xS$, scdattr ScoreBoardNumbers: 'Handle Home Runs IF IGone THEN 'Is it an "instant win" situation? 'If it is we need to show the numbers, because program will not 'get another chance to update the scoreboard. Any other home run 'will not update the scoreboard here. IF inn >= RegInns AND it = 2 THEN IF itruns(2) > itruns(1) THEN GOTO ScoreBoardPost END IF 'If not, do not show the numbers GOTO ScoreBoardX END IF ScoreBoardPost: 'Put up the numbers 'Erase scoreboard numbers if necessary IF DoAllInns OR (innct = 1 AND it = 1) THEN xS$ = STRING$(20, 32) QPRINTs 3, 12, xS$, scdattr QPRINTs 4, 12, xS$, scdattr END IF IF it = 1 THEN attr1 = scoattr attr2 = scdattr ELSE attr1 = scdattr attr2 = scoattr END IF QPRINTs 3, 2, LEFT$(Names(1), 10), attr1 QPRINTs 4, 2, LEFT$(Names(2), 10), attr2 'Visitor FOR i = 1 TO 10 IF it = 1 AND i = innct THEN attr = revattr ELSE attr = scdattr IF i <= innct THEN IF i = innct AND it = 1 THEN IF iScoreBd(1, i) = 0 THEN ss$ = "ê " ELSE IF iScoreBd(1, i) < 10 THEN ss$ = "ê" + LTRIM$(STR$(iScoreBd(1, i))) ELSE ss$ = LTRIM$(STR$(iScoreBd(1, i))) END IF END IF ELSE ss$ = PADLEFT$(LTRIM$(STR$(iScoreBd(1, i))), 2) END IF IF DoAllInns OR i = innct THEN QPRINTs 3, (10 + i*2), ss$, attr END IF END IF NEXT 'Home FOR i = 1 TO 10 IF it = 2 AND i = innct THEN attr = revattr ELSE attr = scdattr IF i <= innct THEN IF i = innct THEN IF it = 2 THEN IF iScoreBd(2, i) = 0 THEN ss$ = "ê " ELSEIF iScoreBd(2, i) < 10 THEN ss$ = "ê" + LTRIM$(STR$(iScoreBd(2, i))) ELSE ss$ = LTRIM$(STR$(iScoreBd(2, i))) END IF QPRINTs 4, (10 + i*2), ss$, attr END IF ELSE IF (i = innct - 1) OR DoAllInns THEN ss$ = PADLEFT$(LTRIM$(STR$(iScoreBd(2, i))), 2) QPRINTs 4, (10 + i*2), ss$, attr END IF END IF END IF NEXT ScoreBoardTots: a$ = SPACE$(9) MID$(a$, 1, 3) = LFORMAT$(itruns(1),"###") MID$(a$, 4, 3) = LFORMAT$(ithits(1),"###") MID$(a$, 7, 3) = LFORMAT$(iterrs(1),"###") QPRINTs 3, 32, a$, scdattr a$ = SPACE$(9) MID$(a$, 1, 3) = LFORMAT$(itruns(2),"###") MID$(a$, 4, 3) = LFORMAT$(ithits(2),"###") MID$(a$, 7, 3) = LFORMAT$(iterrs(2),"###") QPRINTs 4, 32, a$, scdattr ScoreBoardX: QPRINTs 5, 9, STR$(iout), prmattr END SUB SUB SearchPbyP (ARRAYx() AS PbyP_OVL, beg, leng, rangelo, rangehi, Find$, FoundAt, mini) STATIC FoundAt = 0 'no matching element yet mini = rangelo maxi = rangehi DO Try = (mini + maxi) \ 2 'start testing in middle xS$ = ARRAYx(Try).PbyP_Rec xS$ = MID$(xS$, beg, leng) IF xS$ = Find$ THEN 'found it! FoundAt = Try 'return matching element EXIT DO 'all done END IF IF xS$ > Find$ THEN 'too high, cut in half maxi = Try - 1 ELSE mini = Try + 1 'too low, cut other way END IF LOOP WHILE maxi >= mini END SUB SUB SearchStandingsTable (Lg$, Dv$, Team$, ndx) ON ERROR GOTO ERRORTRAP i = 1 DO IF i > WLx THEN INCR WLx WLRec(WLx).WLTeam = Team$ WLRec(WLx).WLWins = 0 WLRec(WLx).WLLoss = 0 WLRec(WLx).WLLeague = Lg$ WLRec(WLx).WLDiv = Dv$ WLRec(WLx).WLPct = "0000" ndx = WLx EXIT DO END IF IF WLRec(i).WLLeague = Lg$ AND RTRIM$(WLRec(i).WLTeam) = RTRIM$(Team$) THEN ndx = i EXIT DO END IF INCR i LOOP EXIT SUB ErrorTrap: LOCATE 10, 30 PRINT "ERROR: SearchSta"; ERRCLEAR x$ = WAITKEY$ END SUB SUB SelectPhotoIO(List1() AS List1Type, choices, Selection$) CALL GetScreen(Scr3$, 2+rowO, 3+colO, 21+rowO, 78+colO) row1 = 2 + rowO col1 = 3 + colO row2 = 21 + rowO col2 = 78 + colO Shadow = 0 ESCPoint = 2 zS$ = "" yS$ = "Where do you want to go today? [PgUp/PgDown]" CALL Drawfrm (row1, col1, row2, col2, defattr, zS$, yS$, Shadow, 0, ESCPoint) r = 9 + rowO columns = 1 itemsincol = 18 x1$ = "µ": x2$ = "¶" QPRINTs r, col2, x1$, defattr QPRINTs r + 1, col2, UpPtr$, defattr QPRINTs r + 2, col2, DnPtr$, defattr QPRINTs r + 3, col2, x2$, defattr CALL PickFromList(List1(), choices, itemsincol, columns, 73, row1,col1,row2,col2, dimattr, revattr, Pick, RetKey, nulls$, mous, ms$) IF Pick > 0 THEN rec$ = List1(Pick).ListItem Selection$ = RTRIM$(MID$(rec$, 1, 20)) ELSE Selection$ = "" END IF CALL PutScreen(Scr3$, 2+rowO, 3+colO, 21+rowO, 78+colO) END SUB SUB SetColors (ColorScheme) IF ColorScheme = 1 THEN fldfor = 14: fldbac = 2 'yellow on green runfor = 0: runbac = 2 'black on green END IF IF ColorScheme = 2 THEN fldfor = 15: fldbac = 2 'bright on green runfor = 0: runbac = 2 'black on green END IF IF ColorScheme = 3 THEN fldfor = 0: fldbac = 2 'black on green runfor = 0: runbac = 2 'black on green END IF IF ColorScheme = 4 THEN fldfor = 14: fldbac = 3 'yellow on sky-blue runfor = 0: runbac = 3 'black on sky-blue END IF IF ColorScheme = 5 THEN fldfor = 15: fldbac = 3 'bright on sky-blue runfor = 0: runbac = 3 'black on sky-blue END IF IF ColorScheme = 6 THEN fldfor = 0: fldbac = 3 'black on sky-blue runfor = 0: runbac = 3 'black on sky-blue END IF fldattr = CALCATTR(fldfor, fldbac) 'labattr only used for smaller screens where stats are displayed 'in the middle of the screen labfor = 0 labbac = fldbac labattr = CALCATTR(labfor, labbac) END SUB SUB SetDH IF CmdDH$ = "Y" OR CmdDH$ = "A" THEN dh = -1 IF CmdDH$ = "N" THEN dh = 0 IF CmdDH$ = "H" THEN IF League(2) = "A" THEN IF Century(2) = "19" AND MID$(Names(2), 1, 2) > "73" THEN dh = -1 ELSEIF Century(2) = "20" THEN dh = -1 ELSE dh = 0 END IF ELSE dh = 0 END IF 'DAT Override switch: *DH=Y IF DHDATOvr(2) = -1 THEN dh = -1 'DAT Override switch: *DH=N IF DHDATOvr(2) = 1 THEN dh = 0 END IF IF CmdDH$ = "E" THEN IF DHinDAT(1) OR DHinDAT(2) THEN dh = -1 ELSE dh = 0 END IF IF dh THEN CALL SwitchToDH (1) CALL SwitchToDH (2) ELSE 'Also puts pitcher's hitting stats in correct slot CALL SwitchToNoDH (1) CALL SwitchToNoDH (2) END IF END SUB SUB SetHomeTorF (t$, DspSw) ' This always works with the window on the right side - the Home side IF t$ = "T" THEN TorF = TRUE IF t$ = "F" THEN TorF = FALSE IF DspSw THEN IF TorF = FALSE THEN QPRINTs 11 + RowO + HomePtr, 47+ColO, " ", defattr QPRINTs 11 + RowO + HomePtr, 65+ColO, "–", defattr ELSE QPRINTs 11 + RowO + HomePtr, 47+ColO, "–", defattr QPRINTs 11 + RowO + HomePtr, 65+ColO, " ", defattr END IF ELSE FOR i = 1 TO 3 QPRINTs 11 + RowO + HomePtr, 47+ColO, "*", defattr QPRINTs 11 + RowO + HomePtr, 65+ColO, "*", defattr SLEEP 40 QPRINTs 11 + RowO + HomePtr, 47+ColO, " ", defattr QPRINTs 11 + RowO + HomePtr, 65+ColO, " ", defattr SLEEP 40 NEXT END IF IF it = 2 THEN SELECT CASE HomePtr CASE 1 HomeReady = TorF CASE 2 PH = TorF CASE 3 PRun = TorF CASE 4 ViewHome = TorF CASE 5 ViewVisi = TorF CASE 6 IF WarmUpRule THEN BULLO = TorF CASE 8 Steal = TorF CASE 9 Bunt = TorF CASE 10 HitAndRun = TorF CASE ELSE END SELECT END IF IF it = 1 THEN SELECT CASE HomePtr CASE 1 HomeReady = TorF CASE 2 BullD = TorF CASE 3 Subx = TorF CASE 4 SwPos = TorF CASE 5 ViewHome = TorF CASE 6 ViewVisi = TorF CASE 8 IWalk = TorF CASE 9 Tight = TorF CASE 10 POut = TorF CASE 11 PAround = TorF CASE ELSE END SELECT END IF END SUB SUB SetVisiTorF (t$, DspSw) 'This always works with the window on the left side - the Visitor side IF t$ = "T" THEN TorF = TRUE IF t$ = "F" THEN TorF = FALSE IF DspSw THEN IF TorF = FALSE THEN LOCATE 11+RowO + VisiPtr, 16+ColO PRINT " "; LOCATE 11+RowO + VisiPtr, 34+ColO PRINT "–"; ELSE LOCATE 11+RowO + VisiPtr, 16+ColO PRINT "–"; LOCATE 11+RowO + VisiPtr, 34+ColO PRINT " "; END IF ELSE FOR i = 1 TO 3 LOCATE 11+RowO + VisiPtr, 16+ColO PRINT "*"; LOCATE 11+RowO + VisiPtr, 34+ColO PRINT "*"; SLEEP 40 LOCATE 11+RowO + VisiPtr, 16+ColO PRINT " "; LOCATE 11+RowO + VisiPtr, 34+ColO PRINT " "; SLEEP 40 NEXT END IF IF it = 1 THEN SELECT CASE VisiPtr CASE 1 VisiReady = TorF CASE 2 PH = TorF CASE 3 PRun = TorF CASE 4 ViewVisi = TorF CASE 5 ViewHome = TorF CASE 6 IF WarmUpRule THEN BULLO = TorF CASE 8 Steal = TorF CASE 9 Bunt = TorF CASE 10 HitAndRun = TorF CASE ELSE END SELECT END IF IF it = 2 THEN SELECT CASE VisiPtr CASE 1 VisiReady = TorF CASE 2 BullD = TorF CASE 3 Subx = TorF CASE 4 SwPos = TorF CASE 5 ViewVisi = TorF CASE 6 ViewHome = TorF CASE 8 IWalk = TorF CASE 9 Tight = TorF CASE 10 POut = TorF CASE 11 PAround = TorF CASE ELSE END SELECT END IF END SUB SUB SetPlatoon FOR it = 1 TO 2 id = 3 - it zS$ = UCASE$(DataHand(iyp(1, id), id)) 'handedness of opposing pitcher FOR i = 1 TO 9 IF DataPos(i, it) <> 1 THEN IF DataPlat(i, it) <> " " AND DataHand(i, it) = zS$ THEN yS$ = DataPlat(i, it) FOR j = LastPiAd(it) + 1 TO MAXPLAYERS IF yS$ = DataPlat(j, it) AND DataHand(j, it) <> zS$ THEN k = DataPos(i, it) 'Can the sub guy (j) play position (k)? OK = FALSE 'Are we playing "strict" or "loose"? IF DataPosi(j, it, 1) > 0 THEN 'Strict IF FoundPosition (k, j, it) THEN OK = TRUE END IF ELSE subdefPos = DataPos(j, it) SELECT CASE k CASE 2 IF subdefPos = 2 THEN OK = TRUE CASE 3 IF subdefPos = 3 OR subdefPos = 5 THEN OK = TRUE CASE 4 IF subdefPos = 4 OR subdefPos = 6 THEN OK = TRUE CASE 5 IF subdefPos = 5 OR subdefPos = 6 THEN OK = TRUE CASE 6 IF subdefPos = 6 THEN OK = TRUE CASE 7, 8, 9 IF subdefPos = 7 OR subdefPos = 8 OR subdefPos = 9 THEN OK = TRUE END SELECT END IF 'Is the sub guy's name the same as the starting pitcher? IF DataName(j, it) = DataName(ipa(it), it) THEN OK = FALSE IF OK THEN CALL Switch(i, j, it) 'Swap players i and j on team it DataPos(i, it) = k END IF END IF NEXT END IF END IF NEXT NEXT END SUB SUB SetRefByBO FOR tm = 1 TO 2 FOR i = 1 TO 9 zS$ = LTRIM$(STR$(DataRef(i, tm))) RefByBO(i, tm) = PADZEROS$(zS$, 2) NEXT NEXT END SUB SUB SetRestartData 'The active CmdStat$ must have been picked earlier SETSCHDate$ = nulls$ IF CmdStat$ > "!" THEN 'Schedule Restart info IF LEN(DIR$(CmdWritePath$ + CmdStat$ + ".RES")) THEN OPEN CmdWritePath$ + CmdStat$ + ".RES" FOR RANDOM AS #5 LEN = LEN(RestartRec) GET #5, 1, RestartRec SETSCHDate$ = RestartRec.ResSCHDate SETSlotPtr = RestartRec.ResSCHSlotPtr SETSlotGameCtr = RestartRec.ResSlotGameCtr SETSlotGames = RestartRec.ResSlotGames SimGameCtr = RestartRec.ResSimGameCtr CLOSE #5 END IF ' Pitching Rotations IF LEN(DIR$(CmdWritePath$ + CmdStat$ + ".ROT")) THEN OPEN CmdWritePath$ + CmdStat$ + ".ROT" FOR RANDOM AS #6 LEN = LEN(RotRec(1)) RTx = LOF(6) / LEN(RotRec(1)) FOR i = 1 TO RTx GET #6, i, RotRec(i) NEXT CLOSE #6 END IF ' Standings IF LEN(DIR$(CmdWritePath$ + CmdStat$ + ".STD")) THEN OPEN CmdWritePath$ + CmdStat$ + ".STD" FOR RANDOM AS #7 LEN = LEN(WLRec(1)) WLx = LOF(7) / LEN(WLRec(1)) FOR i = 1 TO WLx GET #7, i, WLRec(i) NEXT CLOSE #7 END IF END IF 'SetPositioninSCH SoundOn = FALSE 'Reopen to get first line of .SCH file or read until we get valid teams OPEN CmdPath$ + CmdSCH$ FOR BINARY AS #2 RecLen = 0 L& = LOF(2) IF L& MOD 210 = 0 THEN RecLen = 210: SchGamesPerRecord = 7 IF L& MOD 430 = 0 THEN RecLen = 430: SchGamesPerRecord = 15 IF RecLen > 0 THEN SchRecords = L& / RecLen ELSE SchRecords = 0 SchBuffer$ = SPACE$(RecLen) GET #2 ,, SchBuffer$ 'Skip 1st rec rec = 1 OUTTAHERE = FALSE DO SchSlotPtr = 0 INCR rec IF rec > SchRecords THEN EXIT DO GET #2 ,, SchBuffer$ IF MID$(SchBuffer$, 1, 1) = "D" THEN ITERATE DO 'Set SCHDate$ SCHDate$ = MID$(SchBuffer$, 3, 8) DO WHILE SchSlotPtr < SchGamesPerRecord 'formerly 7 INCR SchSlotPtr CALL ReadSCHSlot IF CmdVFil$ > "!" AND CmdHFil$ > "!" AND FilterOK THEN IF SETSCHDate$ > "!" THEN IF SCHDate$ = SETSCHDate$ AND SchSlotPtr = SETSlotPtr THEN IF SETSlotGameCtr < SETSlotGames THEN SlotGameCtr = SETSlotGameCtr OUTTAHERE = TRUE EXIT DO ELSE SlotGameCtr = 0 SETSCHDate$ = nulls$ END IF END IF ELSE OUTTAHERE = TRUE EXIT DO END IF END IF LOOP LOOP UNTIL OUTTAHERE END SUB SUB SetSCHBookMark REGISTER i AS INTEGER IF CmdStat$ < "!" THEN EXIT SUB a$ = nulls$ xS$ = CmdWritePath$ + CmdStat$ + ".RES" yS$ = CmdWritePath$ + CmdStat$ + ".ROT" zS$ = CmdWritePath$ + CmdStat$ + ".STD" IF EOF(2) THEN 'SCH is over! [perhaps with "filters"] a$ = "DEL" IF LEN(DIR$(xS$)) THEN KILL xS$ END IF IF LEN(DIR$(yS$)) THEN KILL yS$ END IF IF LEN(DIR$(zS$)) THEN KILL zS$ END IF ELSE 'SCH not over - create/update Restart File OPEN xS$ FOR RANDOM AS #5 LEN = LEN(RestartRec) RestartRec.ResSCHName = CmdSCH$ RestartRec.ResSCHDate = SCHDate$ RestartRec.ResSCHSlotPtr = SCHSlotPtr RestartRec.ResSlotGameCtr = SlotGameCtr RestartRec.ResSlotGames = CmdSlotGames RestartRec.ResSimGameCtr = SimGameCtr PUT #5, 1, RestartRec CLOSE #5 IF RTx > 0 THEN OPEN yS$ FOR RANDOM AS #6 LEN = LEN(RotRec(1)) FOR i = 1 TO RTx PUT #6,, RotRec(i) NEXT CLOSE #6 END IF IF WLx > 0 THEN OPEN zS$ FOR RANDOM AS #7 LEN = LEN(WLRec(1)) FOR i = 1 TO WLx PUT #7,, WLRec(i) NEXT CLOSE #7 END IF END IF END SUB SUB SetSwitches (nargs) 'In: ' ArgList() ' nargs 'Out: ' CmdVM$ ' CmdHM$ ' CmdSound$ ' CmdDH$ ' CmdNoOpt$ ' CmdSlotGames REGISTER i AS INTEGER CmdVM$ = nulls$ CmdHM$ = nulls$ CmdHomeFieldAdv$ = "Y" CmdSlotGames = 1 CmdDelIsOnCommandLine = FALSE FOR i = 1 TO nargs ArgList(i).Arg = UCASE$(ArgList(i).Arg) Temp$ = RTRIM$(ArgList(i).Arg) IF INSTR(Temp$, "/P:") THEN CmdPath$ = MID$(Temp$, 4) IF INSTR(Temp$, "/PW:") THEN CmdWritePath$ = MID$(Temp$, 5) IF INSTR(Temp$, "/V:") THEN CmdVFil$ = MID$(Temp$, 4) IF INSTR(Temp$, "/H:") THEN CmdHFil$ = MID$(Temp$, 4) IF INSTR(Temp$, "/N:") THEN CmdSlotGames = VAL(MID$(Temp$, 4)) IF INSTR(Temp$, "/SCH:") THEN CmdSch$ = MID$(Temp$, 6) IF INSTR(Temp$, "/SER:") THEN CmdSER$ = MID$(Temp$, 6) IF INSTR(Temp$, "/ST:") THEN CmdStat$ = MID$(Temp$, 5) IF INSTR(Temp$, "/STB:") THEN CmdStar$ = MID$(Temp$, 6) IF INSTR(Temp$, "/BX:") THEN CmdBoxF$ = MID$(Temp$, 5) IF INSTR(Temp$, "/SC:") THEN CmdScrF$ = MID$(Temp$, 5) IF INSTR(Temp$, "/LS:") THEN CmdLinF$ = MID$(Temp$, 5) IF INSTR(Temp$, "/SP:") THEN CmdSP$ = MID$(Temp$, 5) IF INSTR(Temp$, "/VP:") THEN CmdVP$ = MID$(Temp$, 5) IF INSTR(Temp$, "/HP:") THEN CmdHP$ = MID$(Temp$, 5) IF INSTR(Temp$, "/AUL:") THEN CmdAutoLU$ = MID$(Temp$, 6) IF Temp$ ="/AUL" THEN CmdAutoLU$ = "Y" IF INSTR(Temp$, "/AL:") THEN CmdAutoLU$ = MID$(Temp$, 5) IF Temp$ ="/AL" THEN CmdAutoLU$ = "Y" IF INSTR(Temp$, "/VAL:") THEN CmdVAutoLU$ = MID$(Temp$, 6) IF Temp$ ="/VAL" THEN CmdVAutoLU$ = "Y" IF INSTR(Temp$, "/HAL:") THEN CmdHAutoLU$ = MID$(Temp$, 6) IF Temp$ ="/HAL" THEN CmdHAutoLU$ = "Y" IF INSTR(Temp$, "/ABO:") THEN CmdAdjustBO$ = MID$(Temp$, 6) IF Temp$ ="/ABO" THEN CmdAdjustBO$ = "Y" IF INSTR(Temp$, "/VBO:") THEN CmdVAdjustBO$ = MID$(Temp$, 6) IF Temp$ ="/VBO" THEN CmdVAdjustBO$ = "Y" IF INSTR(Temp$, "/HBO:") THEN CmdHAdjustBO$ = MID$(Temp$, 6) IF Temp$ ="/HBO" THEN CmdHAdjustBO$ = "Y" IF INSTR(Temp$, "/FOC:") THEN CmdFocus$ = MID$(Temp$, 6) IF Temp$ ="/FOC" THEN CmdFocus$ = "Y" IF INSTR(Temp$, "/SPT:") THEN CmdSpot$ = MID$(Temp$, 6) IF Temp$ ="/SPT" THEN CmdSpot$ = "Y" IF INSTR(Temp$, "/VSPT:") THEN CmdVSpot$ = MID$(Temp$, 7) IF Temp$ ="/VSPT" THEN CmdVSpot$ = "Y" IF INSTR(Temp$, "/HSPT:") THEN CmdHSpot$ = MID$(Temp$, 7) IF Temp$ ="/HSPT" THEN CmdHSpot$ = "Y" IF INSTR(Temp$, "/VAM:") THEN CmdVAutoMgr$ = MID$(Temp$, 6) IF Temp$ ="/VAM" THEN CmdVAutoMgr$ = "Y" IF INSTR(Temp$, "/HAM:") THEN CmdHAutoMgr$ = MID$(Temp$, 6) IF Temp$ ="/HAM" THEN CmdHAutoMgr$ = "Y" IF INSTR(Temp$, "/VM:") THEN CmdVM$ = MID$(Temp$, 5) IF INSTR(Temp$, "/HM:") THEN CmdHM$ = MID$(Temp$, 5) IF INSTR(Temp$, "/DH:") THEN CmdDH$ = MID$(Temp$, 5) IF Temp$ ="/DH" THEN CmdDH$ = "Y" IF INSTR(Temp$, "/DEL:") THEN CmdDel = VAL(MID$(Temp$, 6)) : CmdDelIsOnCommandLine = TRUE IF INSTR(Temp$, "/C:") THEN CmdColor$ = MID$(Temp$, 4) IF Temp$ ="/C" THEN CmdColor$ = "Y" IF INSTR(Temp$, "/S:") THEN CmdSound$ = MID$(Temp$, 4) IF Temp$ ="/S" THEN CmdSound$ = "Y" IF INSTR(Temp$, "/PG:") THEN CmdPauseAftGame$ = MID$(Temp$, 5) IF Temp$ ="/PG" THEN CmdPauseAftGame$ = "Y" IF INSTR(Temp$, "/PD:") THEN CmdPauseAftDate$ = MID$(Temp$, 5) IF Temp$ ="/PD" THEN CmdPauseAftDate$ = "Y" IF INSTR(Temp$, "/ERA:") THEN CmdERA$ = MID$(Temp$, 6) IF INSTR(Temp$, "/DEBUG") THEN CmdDeBug$ = "Y" IF INSTR(Temp$, "/NOOPT") THEN CmdNoOpt$ = "Y" IF INSTR(Temp$, "/CC:") THEN CmdCols$ = MID$(Temp$, 5) IF INSTR(Temp$, "/CR:") THEN CmdRows$ = MID$(Temp$, 5) IF INSTR(Temp$, "/X:") THEN CmdAutoExit$ = MID$(Temp$, 4) 'new 4.8 IF Temp$ ="/X" THEN CmdAutoExit$ = "Y" IF INSTR(Temp$, "/T:") THEN CmdHomeFieldAdv$ = MID$(Temp$, 4) 'new 4.8 IF Temp$ ="/T" THEN CmdHomeFieldAdv$= "N" NEXT 'Edit CmdVFil$ and CmdHFil$ a bit ii = INSTR(CmdVFil$, ".") IF ii > 0 THEN CmdVFil$ = MID$(CmdVFil$, 1, ii-1) IF LEN(CmdVFil$) > 8 THEN CmdVFil$ = MID$(CmdVFil$, 1, 8) ii = INSTR(CmdHFil$, ".") IF ii > 0 THEN CmdHFil$ = MID$(CmdHFil$, 1, ii-1) IF LEN(CmdHFil$) > 8 THEN CmdHFil$ = MID$(CmdHFil$, 1, 8) IF CmdCols$ <> nulls$ THEN n = VAL(CmdCols$) IF n > 0 AND n < 200 THEN ConsCols = n END IF IF CmdRows$ <> nulls$ THEN n = VAL(CmdRows$) IF n > 0 AND n < 100 THEN ConsRows = n END IF CmdVM$ = RTRIM$(CmdVM$) CmdHM$ = RTRIM$(CmdHM$) CmdERA$ = RTRIM$(CmdERA$) IF CmdVM$ = "+" THEN IF NOT FoundInMMList (CmdVFil$) THEN CALL AddToMMList (CmdVFil$) ELSEIF CmdVM$ = "-" THEN CALL DelFrMMList (CmdVFil$) END IF IF CmdHM$ = "+" THEN IF NOT FoundInMMList (CmdHFil$) THEN CALL AddToMMList (CmdHFil$) ELSEIF CmdHM$ = "-" THEN CALL DelFrMMList (CmdHFil$) END IF IF CmdPath$ <> nulls$ THEN IF RIGHT$(CmdPath$, 1) <> "\" THEN CmdPath$ = CmdPath$ + "\" END IF IF CmdWritePath$ <> nulls$ THEN IF RIGHT$(CmdWritePath$, 1) <> "\" THEN CmdWritePath$ = CmdWritePath$ + "\" END IF IF CmdSch$ <> nulls$ THEN SchedSw = TRUE i = INSTR(CmdSch$, ".") IF i THEN CmdSch$ = LEFT$(CmdSch$, i - 1) CmdSch$ = RTRIM$(CmdSch$) + ".SCH" END IF IF CmdSER$ <> nulls$ THEN SeriesSw = TRUE i = INSTR(CmdSER$, ".") IF i THEN CmdSER$ = LEFT$(CmdSER$, i - 1) CmdSER$ = RTRIM$(CmdSER$) + ".SER" END IF IF CmdStat$ <> nulls$ THEN i = INSTR(CmdStat$, ".") IF INSTR(CmdStat$, ".") THEN CmdStat$ = LEFT$(CmdStat$, i - 1) ELSE CmdStat$ = RTRIM$(CmdStat$) END IF END IF IF CmdSP$ = nulls$ THEN CmdSP$ = "S5" 'Sound Defaults: if using a .sch/.ser file default is "no" else "yes" SoundOn = (CmdSound$ = "Y") IF CmdAutoLU$ = "Y" THEN AutoLineUpSw(1) = TRUE AutoLineUpSw(2) = TRUE END IF IF CmdVAutoLU$ = "Y" THEN AutoLineUpSw(1) = TRUE IF CmdHAutoLU$ = "Y" THEN AutoLineUpSw(2) = TRUE IF CmdAdjustBO$ = "Y" OR CmdAdjustBO$ = "C" THEN AdjustBO(1) = CmdAdjustBO$ AdjustBO(2) = CmdAdjustBO$ END IF IF CmdVAdjustBO$ = "Y" OR CmdVAdjustBO$ = "C" THEN AdjustBO(1) = CmdVAdjustBO$ IF CmdHAdjustBO$ = "Y" OR CmdHAdjustBO$ = "C" THEN AdjustBO(2) = CmdHAdjustBO$ IF CmdPauseAftGame$ <> "Y" THEN CmdPauseAftGame$ = "N" IF CmdPauseAftDate$ <> "Y" THEN CmdPauseAftDate$ = "N" 'Color Defaults 'Override color if desired IF CmdColor$ <> nulls$ THEN mon$ = CmdColor$ '1=dark blue 2=green 3=sky-blue 4=red 5=purple 6=brown 7=grey CALL SetColors (ColorScheme) 'sets field and label colors deffor = 15: defbac = 1 'bright on dark blue revfor = 0: revbac = 7 'black on grey drtfor = 15: drtbac = 6 'bright on brown DIRT prmfor = 14: prmbac = 0 'yellow on black linfor = 0: linbac = 7 'black on grey errfor = 15: errbac = 4 'bright on red scofor = 15: scobac = 0 'bright on black scdfor = 7: scdbac = 0 'grey on black drkfor = 3: drkbac = 0 'sky blue on black dimfor = 7: dimbac = 1 'grey on dark blue defattr = CALCATTR(deffor, defbac) revattr = CALCATTR(revfor, revbac) drtattr = CALCATTR(drtfor, drtbac) prmattr = CALCATTR(prmfor, prmbac) linattr = CALCATTR(linfor, linbac) errattr = CALCATTR(errfor, errbac) scoattr = CALCATTR(scofor, scobac) scdattr = CALCATTR(scdfor, scdbac) drkattr = CALCATTR(drkfor, drkbac) dimattr = CALCATTR(dimfor, dimbac) skipattr = CALCATTR(0, 1) 'black on blue END SUB SUB ShowDoc IF LEN(DIR$("BASEBALL.DOC")) = 0 THEN CALL PopMsg(18+rowO, 19+colO, " BASEBALL.DOC not found in current directory", errattr, 2, kc) ELSE 'This will launch Wordpad in separate window ShowWindState& = 1 zS$ = WordPadSpec$ + " BASEBALL.DOC" ConsoleShell zS$, ShowWindState& END IF END SUB SUB ShowStandings (delayy) STATIC ON ERROR GOTO ErrorTrap IF SaveL = 0 THEN DIM SaveDivByLeagues(3) AS LONG IF WLx < 1 THEN GOTO ExitShowStandings 'Compute WLPct(i) FOR i = 1 TO WLx Games = WLRec(i).WLWins + WLRec(i).WLLoss IF Games > 0 THEN xF! = WLRec(i).WLWins / Games n = xF! * 1000 xS$ = LTRIM$(STR$(n)) WLRec(i).WLPct = PADZEROS$(xS$, 4) ELSE WLRec(i).WLPct = "0000" END IF NEXT 'Sort the WLRec by WLLeague/WLDiv/WLPct ARRAY SORT WLRec(1) FOR WLx, FROM 21 TO 26, DESCEND 'Count Leagues and Divisions REDIM DivByLeagues(3) AS LONG L=0 i=1 DO WHILE i <= WLx D=0 IF L = 3 THEN EXIT DO INCR L SaveLeague$ = WLRec(i).WLLeague DO WHILE SaveLeague$ = WLRec(i).WLLeague AND i <= WLx IF D = 3 THEN EXIT DO INCR D SaveDiv$ = WLRec(i).WLDiv DO WHILE SaveDiv$ = WLRec(i).WLDiv AND _ SaveLeague$ = WLRec(i).WLLeague AND i <= WLx INCR i IF i > WLx THEN EXIT DO LOOP IF L < 4 THEN DivByLeagues(L) = D IF i > WLx THEN EXIT DO LOOP IF i > WLx THEN EXIT DO LOOP 'Decide whether to print veritically or horizontally Horz = FALSE FOR i = 1 TO L IF DivByLeagues(i) > 2 THEN Horz = TRUE NEXT 'Decide whether we need to erase the screen or not erasescreen = 0 IF L > SaveL THEN SaveL = L: erasescreen = -1 FOR i = 1 TO L IF DivByLeagues(i) <> SaveDivByLeagues(i) THEN SaveDivByLeagues(i) = DivByLeagues(i) erasescreen = -1 END IF NEXT IF erasescreen THEN COLOR deffor, defbac CLS CALL Prompt(0) '0 = [O]ptions [T]oggle display '1 = [N]ew END IF QPRINTs 1, MidCol-5, "Standings", defattr i = 1 LegCtr = 0 BiggestRow = 0 DO SaveLeague$ = WLRec(i).WLLeague SELECT CASE SaveLeague$ CASE "A" LeagueName$ = "A.L." CASE "N" LeagueName$ = "N.L." CASE "F" LeagueName$ = "Federal" CASE ELSE LeagueName$ = SaveLeague$ END SELECT IF Horz THEN IF LegCtr = 0 THEN r = 2 IF LegCtr = 1 THEN r = 12 c = 1 ELSE c = LegCtr * 27 + 1 r = 2 END IF IF c < 56 THEN QPRINTs r, c, LeagueName$, defattr END IF DivCtr = 0 DO WHILE WLRec(i).WLLeague = SaveLeague$ AND i <= WLx IF Horz THEN IF LegCtr = 0 THEN r = 3 IF LegCtr = 1 THEN r = 12 c = DivCtr * 27 + 1 ELSE r = DivCtr * 9 + 3 c = LegCtr * 27 + 1 END IF SaveDiv$ = WLRec(i).WLDiv IF (Horz AND LegCtr = 0) OR (NOT Horz) THEN DivName$ = SPACE$(16) IF SaveDiv$ = "N" THEN DivName$ = "North" IF SaveDiv$ = "S" THEN DivName$ = "South" IF SaveDiv$ = "E" THEN DivName$ = "East" IF SaveDiv$ = "C" THEN DivName$ = "Central" IF SaveDiv$ = "W" THEN DivName$ = "West" IF c < 56 AND r < 13 THEN QPRINTs r, c, DivName$, defattr IF r = 3 THEN INCR r IF MenuOpt$ = "T" THEN QPRINTs r, c, " Won Lost Pct", defattr ELSE QPRINTs r, c, " Won Lost Pct", defattr END IF END IF END IF END IF DO WHILE WLRec(i).WLDiv = SaveDiv$ AND WLRec(i).WLLeague = SaveLeague$ AND i <= WLx INCR r IF Horz THEN IF LegCtr = 0 AND r > 11 THEN GOTO SSNextRec END IF IF r > 19 THEN GOTO SSNextRec IF c < 56 THEN IF MenuOpt$ = "T" THEN a$ = SPACE$(29) MID$(a$, 1, 11) = WLRec(i).WLTeam MID$(a$, 12, 6) = LFORMAT$(WLRec(i).WLWins, "######") MID$(a$, 19, 6) = LFORMAT$(WLRec(i).WLLoss, "######") IF WLRec(i).WLPct > "0998" THEN MID$(a$, 26, 4) = "1.00" ELSE MID$(a$, 26, 1) = "." MID$(a$, 27, 3) = RIGHT$(WLRec(i).WLPct, 3) END IF ELSE a$ = SPACE$(24) MID$(a$, 1, 11) = WLRec(i).WLTeam MID$(a$, 12, 4) = LFORMAT$(WLRec(i).WLWins, "####") MID$(a$, 16, 4) = LFORMAT$(WLRec(i).WLLoss, "####") IF WLRec(i).WLPct > "0998" THEN MID$(a$, 21, 4) = "1.00" ELSE MID$(a$, 21, 1) = "." MID$(a$, 22, 3) = RIGHT$(WLRec(i).WLPct, 3) END IF END IF QPRINTs r, c, a$, dimattr IF r > BiggestRow THEN BiggestRow = r END IF SSNextRec: INCR i IF i > WLx THEN EXIT DO LOOP 'Division Changed INCR DivCtr IF i > WLx THEN EXIT DO LOOP 'League Changed INCR LegCtr LOOP UNTIL i > WLx 'Display Hi-lites IF HLx > 0 AND HLx <> HLxOld THEN HLxOld = HLx REDIM List1(1 TO 400) AS List1Type i = 0 DO WHILE i < HLx INCR i xS$ = PADRIGHT$(LTRIM$(STR$(HLRec(i).HLGameNo)), 6) + HLRec(i).HLMessage List1(i).ListItem = xS$ LOOP r1 = BiggestRow + 2 r2 = ConsRows - 1 c1 = 2 c2 = ConsCols - 1 QPRINTs r1-1, c1, SPACE$(c2-c1+1), defattr 'blank line IF Delayy = FALSE THEN CALL Drawfrm(r1, c1, r2, c2, defattr, "Hi-Lites", "", 0, 0, 0) RetKey = -97 'Display and return instantly ELSE CALL Drawfrm(r1, c1, r2, c2, defattr, "Hi-Lites", "ESC PgUp/PgDown", 0, 0, 0) RetKey = -98 'Display and wait for paging keys END IF CALL PickFromList(List1(), HLx, r2-r1-1, 2, INT((c2-c1)/2)-2, r1, c1, r2, c2, dimattr, revattr, Pick, RetKey, nulls$, mous, ms$) ERASE List1 EXIT SUB END IF ExitShowStandings: IF Delayy THEN PauseIt EXIT SUB ErrorTrap: LOCATE 10, 30 PRINT "ERROR: Standings"; ERRCLEAR x$ = WAITKEY$ END SUB SUB ShowVirtWin (p1, maxLines, RowOff, ColOff, startline, startcol, rowlock, collock, collimit) 'Clear out viewing window 'maxLines = 10 'startline = 3 'startcol = 3 'rowlock = 10 'collock = 20 'collimit = 76 'locate 6, 30: PRINT "Entering ShowVirtWin "; : xS$ = Waitkey$ 'locate 6, 30: PRINT " "; 'Scroll Down 10, 3, 3, 12, 78 'SCROLL DOWN maxLines, startline, startcol, startline + maxLines - 1, startcol + collimit - 1 'locate 6, 30: PRINT "Just did a scroll down"; : xS$ = Waitkey$ 'locate 6, 30: PRINT " "; IF ConsRows = 25 AND ConsCols = 80 THEN BeginBuffer sr = startline - 1 FOR r = 1 TO rowlock xS$ = MID$(VirtualWin(r).item, 1, collock) GOSUB FixAttr INCR sr QPRINTs sr, startcol, xS$, attr xS$ = MID$(VirtualWin(r).item, collock + ColOff + 1) xS$ = PADRIGHT$(xS$, collimit - collock) QPRINTs sr, startcol + collock, xS$, attr NEXT 'locate 6, 30: PRINT "Just did first part "; : xS$ = Waitkey$ 'locate 6, 30: PRINT " "; r = rowlock + RowOff + p1 DO WHILE (sr - startline + 1) < maxLines IF r > MAXPLAYERS + 4 THEN EXIT DO xS$ = MID$(VirtualWin(r).item, 1, collock) L = LEN(xS$) ' IF xS$ = SPACE$(L) THEN EXIT DO IF xS$ < " !" THEN xS$ = SPACE$(L) INCR sr GOSUB FixAttr QPRINTs sr, startcol, xS$, attr xS$ = MID$(VirtualWin(r).item, collock + ColOff + 1) L = LEN(xS$) IF xS$ < " !" THEN xS$ = SPACE$(L) xS$ = PADRIGHT$(xS$, collimit - collock) QPRINTs sr, startcol + collock, xS$, attr IF xS$ = SPACE$(L) THEN EXIT DO INCR r LOOP 'locate 6, 30: PRINT "Just did 2nd part "; : xS$ = Waitkey$ 'locate 6, 30: PRINT "Out of ShowVirtWin "; IF ConsRows = 25 AND ConsCols = 80 THEN EndBuffer EXIT SUB FixAttr: IF LEFT$(xS$, 1) = "~" THEN xS$ = MID$(xS$, 2) + " " attr = defattr ELSE attr = dimattr END IF RETURN END SUB SUB SingleRoutine InfieldHit = FALSE ConsiderExtraBase = FALSE IF Errorx = FALSE THEN 'Decide where the hit went ppF! = FindPP! ELSE 'An infielder made an error on the play IF SoundOn THEN CALL WavRegularGrounder IF OneBaseError THEN ii = 1 jj = 1 GOTO SingleAdvance ELSEIF ThrowError THEN ii = 2 jj = 2 GOTO SingleAdvance ELSE 'The ground ball error has gone to the outfield OrgWhoAtPos = WhoAtPos WhoAtPos = OUTfrIN(WhoAtPos, 0) END IF END IF IF Errorx = FALSE THEN IF RND < .6 THEN 'FLY (60% of hits) WhoAtPos = OUTFIELDWHOAT(ppF!) wag = WHOATGUY(WhoAtPos) IF DelFac THEN IF RND < .10 THEN 'Short dramatic flys IF SoundOn THEN CALL WavShortFly CALL Msg ("07", "0", "1", "02", 0, id, man2, team2) CALL Msg ("07", "0", "2", "02", wag, id, man2, team2) CALL Msg ("07", "0", "3", "02", 0, id, man2, team2) CALL Msg ("29", "0", "0", "15", 0, id, man2, team2) CALL Msg ("29", "0", "0", "09", ib, it, man2, team2) ELSE 'Regular flys IF SoundOn THEN CALL WavRegularHit p$ = LTRIM$(STR$(WhoAtPos)) t$ = PADZEROS$(LTRIM$(STR$(RND(1,4))) , 2) IF t$ = "02" THEN i = ib: j = it ELSE i = wag: j = id CALL Msg ("12", p$, "1", t$, 0, id, man2, team2) CALL Msg ("12", p$, "2", t$, i, j, man2, team2) CALL Msg ("12", p$, "3", t$, ib, it, man2, team2) END IF END IF ELSE 'GROUND (40% of hits) WhoAtPos = GROUNDBALLWHOAT (ppF!) wag = WHOATGUY(WhoAtPos) p$ = LTRIM$(STR$(WhoAtPos)) x! = RND 'Infield Hit? IF RND < .25 OR p$ < "3" THEN 'Set % of infield hits (25% of 40% = 10%) 'Possibility of Infield Hit and wild throw (Hit and error) WildThrow = FALSE IF WhoAtPos <> 3 THEN defperF! = DEFPCT!(wag) zF! = (1.0 - defperF!) * .65 'Increase constant for fewer errors IF RND > (defperF! + zF!) THEN WildThrow = TRUE END IF IF DelFac THEN IF x! < .15 THEN 'set "type" of infield hit t$ = "01" ' (most are "slow") ELSEIF x! < .30 THEN t$ = "02" ELSE t$ = "04" END IF IF p$ = "1" THEN t$ = "04" IF SoundOn THEN IF t$ = "04" THEN CALL WavSoftGrounder ELSE CALL WavRegularGrounder END IF END IF CALL Msg ("03", p$, "1", t$, 0, id, man2, team2) CALL Msg ("03", p$, "2", t$, wag, id, man2, team2) CALL Msg ("03", p$, "3", t$, wag, id, man2, team2) 'Not in time CALL Msg ("23", "0","0","01", 0, it, man2, team2) IF WildThrow THEN AddToAnnouncer id, "Wild throw! Into the dugout!" IF NUMBERON > 0 THEN AddToAnnouncer it, "Everybody gets an extra base!" END IF AddToAnnouncer it, "The hitter will wind up on second." AddToAnnouncer it, "Score that one: a hit and an error." ELSE CALL Msg ("23", "0","0","02", 0, it, man2, team2) END IF END IF InfieldHit = TRUE ELSE 'Shot through the infield somewhere IF DelFac THEN IF x! < .5 THEN 'No "slow" or "right at" t$ = "01" ELSE t$ = "02" END IF IF SoundOn THEN CALL WavRegularGrounder CALL Msg ("03", p$, "1", t$, 0, id, man2, team2) IF RND < .6 THEN 'tough chance/can't get there CALL Msg ("22", "0", "0", "00", wag, id, man2, team2) END IF 'Do PostAnnouncer here to flash the infielder CALL PostAnnouncer (TRUE) SLEEP 1000 ANx = 0 'Next time it should flash the outfielder CALL Msg ("29", "0", "0", "09", ib, it, man2, team2) 'BASE HIT END IF Middle = FALSE IF p$ = "4" AND t$ = "01" THEN Middle = TRUE IF p$ = "6" AND t$ = "02" THEN Middle = TRUE WhoAtPos = OUTfrIN (WhoAtPos, Middle) 'Point action to outfield? wag = WHOATGUY(WhoAtPos) END IF END IF END IF 'How far to advance runners? (default) ii = 1 jj = 1 ThrowOutChance1 = 0 ThrowOutChance2 = 0 ThrowToThird = FALSE ConcedeRun = FALSE Gamble = 0 IF HitAndRun OR InfieldHit THEN IF HitAndRun AND InfieldHit THEN IF RND < .51 THEN ii = 2 jj = 2 ELSE ii = 1 jj = 1 END IF ELSEIF HitAndRun THEN ii = 2 jj = 2 ELSEIF InfieldHit THEN ii = 1 jj = 1 END IF GOTO SingleTOCheck END IF IF ir2 THEN IF ir3 THEN i = 2 ELSE i = 1 IF (itruns(it) + i < itruns(id)) THEN 'Tying run will not score... IF ir1 THEN IF amgr(id) = 0 AND AutoDefense = 0 THEN CALL PostAnnouncer (TRUE) ANx = 0 SLEEP 1500 r = 10+rowO c = 25+colO x$ = " Defense: Throw to 3rd? [y/N] " CALL PopMsg(r, c, x$, errattr, 0, kc) IF UCASE$(CHR$(kc)) = "Y" THEN ThrowToThird = TRUE jj = 2 'Concede run - throw to third END IF ELSE 'When should defense throw to 3rd instead of to home? 'Faster runner on 2nd or slow runner on 1st IF ( (DataSpeed(ir2, it) - DataSpeed(ir1, it) > 1) OR _ DataSpeed(ir1, it) < 4 ) THEN ThrowToThird = TRUE jj = 2 END IF END IF ELSE 'ir1 = 0 IF amgr(id) = 0 AND AutoDefense = 0 THEN CALL PostAnnouncer (TRUE) ANx = 0 SLEEP 1500 r = 10+rowO c = 16+colO IF ir3 = 0 THEN x$ = " Defense: Concede run / Hold batter on 1st? [y/N] " ELSE x$ = " Defense: Concede runs / Hold batter on 1st? [y/N] " END IF CALL PopMsg(r, c, x$, errattr, 0, kc) IF UCASE$(CHR$(kc)) = "Y" THEN ConcedeRun = TRUE jj = 2 'Concede run - throw to 2nd END IF ELSE 'When should defense concede run[s] and just keep batter on 1st? 'Runner on 2nd is fast OR Batter is fast IF ( (DataSpeed(ir2, it) > 6) OR _ DataSpeed(ib, it) > 7 ) THEN ConcedeRun = TRUE jj = 2 'Concede run - throw to 2nd END IF END IF END IF END IF END IF IF ir2 > 0 AND ThrowToThird = FALSE AND ConcedeRun = FALSE THEN 'Advance runner on 2nd jj 'Safe% 2nd-Home 'Sp 0/1out 2out new ' 1 64 76 ' 2 68 80 ' 3 72 84 ' 4 76 88 ' 5 80 92 ' 6 84 96 ' 7 88 98 ' 8 92 98 ' 9 96 98 IF iout = 2 THEN i = 12 ELSE i = 0 n = 4 * DataSpeed(ir2, it) + 60 + i '4.6 n = n + (7 - FRND(13)) '+/- 6 IF n > 98 THEN n = 98 IF amgr(it) = 0 AND AutoCoach = 0 THEN CALL PostAnnouncer (TRUE) ANx = 0 SLEEP 1500 r = 10+rowO c = 22+colO x$ = " Score runner from 2nd? [y/N] (" + LFORMAT$(n, "##") + "%)" CALL PopMsg(r, c, x$, errattr, 0, kc) IF UCASE$(CHR$(kc)) = "Y" THEN jj = 2 ThrowOutChance1 = 100 - n END IF ELSE IF iout = 0 THEN SucLim = 80 '84 IF iout = 1 THEN SucLim = 72 '76 IF iout = 2 THEN SucLim = 68 '72 'Special Case: IF iout = 2 THEN RunsBehind = itruns(id) - itruns(it) IF ir3 THEN a = 2 ELSE a = 1 IF RunsBehind = a OR RunsBehind = (a - 1) THEN SucLim = 50 END IF END IF IF n >= SucLim THEN jj = 2 ThrowOutChance1 = 100 - n 'chance of getting thrown out at home IF SucLim = 50 AND n < 79 THEN Gamble = TRUE ii = 2 ThrowOutChance2 = 3 'chance of getting thrown out at third GOTO SingleTOCheck END IF END IF END IF END IF IF ir1 THEN 'Advance runner on 1st ii IF (ir2 <> 0 AND jj = 1) THEN ii = 1 'Don't overrun somebody ELSE 'Safe% 1st-3rd ' ' left center right 'Sp 0/1out 2out 0/1out 2out 0/1out 2out ' ' 1 48 60 56 68 64 76 ' 2 52 64 60 72 68 80 ' 3 56 68 64 76 72 84 ' 4 60 72 68 80 76 88 ' 5 64 76 72 84 80 92 ' 6 68 80 76 88 84 96 ' 7 72 84 80 92 88 98 ' 8 76 88 84 96 92 98 ' 9 80 92 88 98 96 98 IF iout = 2 THEN i = 12 ELSE i = 0 ' n = 6 * DataSpeed(ir1, it) + 40 + i ' n = 6 * DataSpeed(ir1, it) + 45 + i n = 4 * DataSpeed(ir1, it) + 52 + i IF ThrowToThird THEN n = n - 20 IF WhoAtPos = 7 THEN i = -8 IF WhoAtPos = 8 THEN i = 0 IF WhoAtPos = 9 THEN i = 8 n = n + i n = n + (9 - FRND(15)) '+/- 8 IF n > 98 THEN n = 98 IF amgr(it) = 0 AND AutoCoach = 0 THEN CALL PostAnnouncer (TRUE) ANx = 0 SLEEP 1500 r = 10+rowO c = 26+colO x$ = " Go 1st-to-3rd? [y/N] (" + LFORMAT$(n, "##") + "%)" CALL PopMsg(r, c, x$, errattr, 0, kc) IF UCASE$(CHR$(kc)) = "Y" THEN ii = 2 ThrowOutChance2 = 100 - n END IF ELSE IF iout = 0 THEN SucLim = 88 '90 88 IF iout = 1 THEN SucLim = 70 '76 74 IF iout = 2 THEN SucLim = 92 '92 90 IF n >= SucLim THEN 'Try to go 1st-3rd ii = 2 ThrowOutChance2 = 100 - n END IF END IF END IF END IF SingleTOCheck: IF DelFac THEN IF ir3 > 0 THEN CALL AnnScoring(ir3) IF Gamble THEN xS$ = "They'll gamble to score " + LASTNAME$(DataName(ir2, it)) + "..." CALL AddToAnnouncer (it, xS$) END IF END IF IF ir1 OR ir2 THEN CALL ThrowOutCheck (ii, jj, ThrowOutChance1, ThrowOutChance2, ThrowToThird, ConcedeRun) IF jj = 2 AND ref2 = 0 AND ConcedeRun = FALSE THEN 'Had a chance to throw out somebody but did not 'Sometimes take extra base ConsiderExtraBase = TRUE END IF END IF SingleAdvance: CALL Advanc(ii, jj, 1) IF ref2 THEN INCR iout 'Anybody get thrown out? ir1 = ib mpp(ib) = ip IF Errorx THEN mpp(ib) = -mpp(ib) 'Flip to negative to show batter got on via an error IF OneBaseError OR ThrowError THEN GOTO SubEXIT ELSE CALL CreditHit Result$ = "1B" 'Possibility of throwing error on infield hits IF InfieldHit THEN IF WildThrow THEN INCR iterrs(id) INCR inne INCR innadverr i = DataRef(wag, id) INCR GpPos(i, id, WhoAtPos) INCR merr(i, id) INCR SumErrors(WhoAtPos) Errorx = TRUE CALL Advanc(1, 1, 1) 'Everybody advances one extra base Errorx = FALSE Result$ = Result$ + "/E-" + LTRIM$(STR$(WhoAtPos)) WildThrow = FALSE END IF END IF IF InfieldHit THEN GOTO SubEXIT 'Done, if infield hit END IF 'Did the outfielder muff the ball? 'Not if runner was thrown out! 'Not if throw went through even if runner was not thrown out IF (ref2 > 0 OR ConsiderExtraBase = TRUE) AND ir2 = 0 THEN 'Runner on 1st can sometimes take extra base on the throw IF DataSpeed(ir1, it) + FRND(10) > 12 THEN '13? ir2 = ir1 ir1 = 0 IF DelFac THEN AddToAnnouncer it, "Runner moves up on the throw." GOTO SubEXIT 'Never outfield muff if move up on throw END IF END IF IF ref2 > 0 THEN GOTO SubEXIT 'Never outfield muff if somebody thrown out 'Check for Outfielder muff CALL Outfield (WhoAtPos) 'Gamble to stretch single (and some infield errors) into a double? It's not an infield hit or 1-base error. IF OutFErr = FALSE THEN IF amgr(it) = 0 AND AutoCoach = 0 THEN IF ir1 = ib AND ir2 = 0 THEN 'criteria to gamble RunsBehind = itruns(id) - itruns(it) IF ir3 THEN a = 2 ELSE a = 1 IF inn > (RegInns - 4) AND (RunsBehind = a OR RunsBehind = a-1) THEN CALL PostAnnouncer (TRUE) ANx = 0 SLEEP 1500 r = 10+rowO c = 23+colO n = 5 * DataSpeed(ir1, it) + 30 x$ = " Stretch hit to a double? [y/N] (" + LFORMAT$(n, "##") + "%)" CALL PopMsg(r, c, x$, errattr, 0, kc) IF UCASE$(CHR$(kc)) = "Y" THEN IF DelFac THEN CALL Msg ("31", "0", "0", "09", ir1, it, man2, team2) 'He's going to try for second! IF DelFac THEN CALL Msg ("31", "0", "0", "06", ir1, it, man2, team2) 'He slides... IF RND < (n / 100) THEN 'Made it IF Errorx = FALSE THEN INCR m2b(ref, it) IF UCASE$(DataHand(ip, id)) = "L" THEN INCR m2bLHP(ref, it) ELSE INCR m2bRHP(ref, it) END IF INCR mp2b(ip, id) Result$ = "2B" END IF ir2 = ib ir1 = 0 IF DelFac THEN CALL Msg ("15", "0", "0", "09", ir2, it, man2, team2) 'Safe IF DelFac THEN CALL Msg ("31", "0", "0", "11", ir2, it, man2, team2) 'Gamble pays off! ELSE 'Didn't make it INCR mpo(ip, id) IF DelFac THEN CALL Msg ("14", "0", "0", "02", ir1, it, man2, team2) 'OUT! The gamble failed. ref2 = DataRef(ir1, it) ' Result2$ = "X-@2nd" INCR Assists(DataRef(WHOATGUY(WhoAtPos), id), id, WhoAtPos) IF WhoAtPos = 7 THEN m = 4 ELSE m = 6 'who took throw? INCR PutOuts(DataRef(WHOATGUY(m), id), id, m) Result2$ = LTRIM$(STR$(WhoAtPos)) + "-" + LTRIM$(STR$(m)) Code2$ = "2" ir1 = 0 INCR iout END IF END IF END IF END IF END IF END IF SubEXIT: END SUB SUB SnapShot ' make sure RefOrg has been REDIMed (cleared) ' make sure RefByBO has been erased REDIM RefOrg(MAXPLAYERS, 2) AS GLOBAL RefOrgType REDIM RefOrgSave(MAXPLAYERS, 2) AS GLOBAL RefOrgType REDIM RefByBO(9, 2) AS GLOBAL STRING FOR tm = 1 TO 2 FOR i = 1 TO MAXPLAYERS ref = DataRef(i, tm) p = DataPos(i, tm) RefOrg(i, tm).RefNo = ref RefOrg(i, tm).RefPos = p RefOrgSave(i, tm).RefNo = ref RefOrgSave(i, tm).RefPos = p ' Copy starting lineups positions to RefByBO IF i < 10 THEN CALL AddToRefByBO (i, tm, ref) NEXT NEXT END SUB SUB SoundQAdd(SoundCode) IF SQx < 10 THEN INCR SQx SoundQ(SQx) = SoundCode END IF END SUB SUB StatsIO (Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) CALL Drawfrm(8+rowO, 10+colO, 21+rowO, 69+colO, defattr, "Statistics Report Options", "ESC (or close window):Generate Report F3:Cancel", 1, 0, 2) DATA 10,12,"Statistics File: ", 10,30,38,"X " DATA 12,12,"Standings [Y,n]", 12,44, 1,"X " DATA 13,12,"Highlights [Y,n]", 13,44, 1,"X " DATA 14,12,"Batting/Pitching/Fielding [Y,n]", 14,44, 1,"X " DATA 15,12," Min. AB ", 15,42, 3,"N " DATA 16,12," Batting R/L Breakdown [y,N]", 16,44, 1,"X " DATA 17,12," Fielding [Y,n]", 17,44, 1,"X " DATA 18,12," Fielding Detail [y,N]", 18,44, 1,"X " DATA 19,12,"League Leaders [Y,n]", 19,44, 1,"X " Flds = 9 c = 1 FOR i = 1 TO Flds Flitrow(i) = VAL(READ$(c)) + rowO Flitcol(i) = VAL(READ$(c+1)) + colO Flit$(i) = READ$(c+2) Frow(i) = VAL(READ$(c+3)) + rowO Fcol(i) = VAL(READ$(c+4)) + colO Flen(i) = VAL(READ$(c+5)) Fed$(i) = READ$(c+6) c = c + 7 NEXT REDIM FContents$(13) FContents$(1) = CmdWritePath$ + CmdStat$ FContents$(2) = "Y" 'standings FContents$(3) = "Y" 'hilights FContents$(4) = "Y" 'main FContents$(5) = " 0" 'include AB >= this FContents$(6) = "N" 'batting r/l FContents$(7) = "Y" 'fielding FContents$(8) = "N" 'fielding bd FContents$(9) = "Y" 'leaders CursorPtr = 1 DO StatsLoop: s = deffor deffor = dimfor CALL ScreenIO(Keyed, KeyF3, 0, KeyEsc, Flds, CursorPtr, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) deffor = s 'Trap F3 IF Keyed = KeyF3 THEN EXIT SUB ' Edit Field Contents Error1$ = "N" IF FContents$(1) < "!" THEN EXIT SUB FOR i = 9 TO 2 STEP -1 IF i <> 5 THEN IF FContents$(i) <> "Y" AND FContents$(i) <> "N" THEN CursorPtr = i Error1$ = "Y" END IF END IF NEXT LOOP WHILE Error1$ = "Y" PrtStandings = (FContents$(2) = "Y") PrtHighlights = (FContents$(3) = "Y") PrtMain = (FContents$(4) = "Y") RL = (FContents$(6) = "Y") PrtFielding = (FContents$(7) = "Y") FieldBD = (FContents$(8) = "Y") PrtLeaders = (FContents$(9) = "Y") CALL Stats (RTRIM$(FContents$(1)), OutFile$, PrtStandings, PrtHighlights, PrtMain, PrtFielding, PrtLeaders, VAL(FContents$(5)), RL, FieldBD) CALL ListFile (OutFile$) END SUB SUB Stats (StatFile$, OutFile$, PrtStandings, PrtHighlights, PrtMain, PrtFielding, PrtLeaders, OtherAB, RL, FieldBD) DIM SR AS StatSummary DIM BR AS BatSummary DIM SaveBR AS BatSummary DIM PR AS PitSummary DIM FR AS FldSummary DIM QualPA AS STRING * 4 DIM QualIP AS STRING * 4 DIM SaveTeam AS STRING * 12 DIM LeagueArg AS STRING * 1 DIM NameArg AS STRING * 12 TeamsInLeagueLim = 20 DIM TeamBatSum(1 TO TeamsInLeagueLim) AS STRING DIM TeamPitSum(1 TO TeamsInLeagueLim) AS STRING DIM TeamFldSum(1 TO TeamsInLeagueLim) AS STRING i = 51 REDIM SaveOther(i) AS BatSummary COLOR deffor, defbac CLS IF StatFile$ < "!" THEN BEEP: EXIT SUB i = INSTR(StatFile$, ".") IF i > 0 THEN StatFile$ = MID$(StatFile$, 1, i - 1) ELSE StatFile$ = RTRIM$(StatFile$) IF LEN(DIR$(StatFile$ + ".STS")) = 0 THEN BEEP CALL PopMsg(11, 20, "Statistics File: " + StatFile$ + ".STS not found. ", errattr, 0, kc) CALL PopMsg(11, 12, "Please check to make sure the stat file you want exists. ", errattr, 5, kc) EXIT SUB END IF IF LEN(DIR$(StatFile$ + ".STP")) THEN CALL CheckForValidFile (StatFile$ + ".STP", 126, Valid1) ELSE BEEP CALL PopMsg(MidRow, MidCol-12, "No Pitcher File Found.", errattr, 0, kc) EXIT SUB END IF IF LEN(DIR$(StatFile$ + ".STB")) THEN CALL CheckForValidFile (StatFile$ + ".STB", 162, Valid2) ELSE BEEP CALL PopMsg(MidRow, MidCol-12, "No Batter File Found.", errattr, 0, kc) EXIT SUB END IF IF NOT Valid1 OR NOT Valid2 THEN BEEP CALL PopMsg(MidRow, MidCol-24, "Sorry. Statistics File: " + StatFile$ + " is an old format. ", errattr, 0, kc) EXIT SUB END IF Outdevice$ = StatFile$ + ".PRN" CALL Drawfrm(8+rowO, 14+colO, 13+rowO, 66+colO, defattr, nulls$, nulls$, 1, 0, 0) QPRINTs 10+rowO, 16+colO, "One moment, please.", dimattr x$ = Outdevice$ + " being generated..." QPRINTs 11+rowO, 16+colO, x$, dimattr '=========== .STS Section ============== IF STATTEAMLIMIT = 0 THEN STATTEAMLIMIT = 300 '700 REDIM SA(STATTEAMLIMIT) AS STSAnal STSHdl = FREEFILE OPEN StatFile$ + ".STS" FOR RANDOM AS #STSHdl LEN = LEN(SR) TblMax = 15 'League Leaders tables (number of players to put in each table) TblEnd = 0 'Running count of number of teams encountered (not related to TblMax) SumRecs = LOF(STSHdl) / LEN(SR) EndOfFile = 0 rec = 1 GET #STSHdl,,SR DO IF SR.VLeague = "A" THEN SR.VLeague = "a" LeagueArg = SR.VLeague NameArg = SR.VNam GOSUB SearchTable v = ndx SA(v).ALeague = SR.VLeague SA(v).ADiv = SR.VDiv SA(v).ARuns = SA(v).ARuns + SR.VRuns SA(v).AOppRuns = SA(v).AOppRuns + SR.HRuns SA(v).AHits = SA(v).AHits + SR.VHits SA(v).AErrs = SA(v).AErrs + SR.VErrs SA(v).ALOB = SA(v).ALOB + SR.VLOB SA(v).ADP = SA(v).ADP + SR.VDPs SA(v).AVRunsS = SA(v).AVRunsS + SR.VRuns SA(v).AVRunsA = SA(v).AVRunsA + SR.HRuns IF SR.HLeague = "A" THEN SR.HLeague = "a" LeagueArg = SR.HLeague NameArg = SR.HNam GOSUB SearchTable h = ndx IF SR.HLeague = "A" THEN SR.HLeague = "a" SA(h).ALeague = SR.HLeague SA(h).ADiv = SR.HDiv SA(h).ARuns = SA(h).ARuns + SR.HRuns SA(h).AOppRuns = SA(h).AOppRuns + SR.VRuns SA(h).AHits = SA(h).AHits + SR.HHits SA(h).AErrs = SA(h).AErrs + SR.HErrs SA(h).ALOB = SA(h).ALOB + SR.HLOB SA(h).ADP = SA(h).ADP + SR.HDPs SA(h).AHRunsS = SA(h).AHRunsS + SR.HRuns SA(h).AHRunsA = SA(h).AHRunsA + SR.VRuns IF SR.HRuns > SR.VRuns THEN INCR SA(h).AWins INCR SA(h).AHomWins INCR SA(v).ALosses INCR SA(v).AVisLosses ELSE INCR SA(v).AWins INCR SA(v).AVisWins INCR SA(h).ALosses INCR SA(h).AHomLosses END IF INCR rec IF rec > SumRecs THEN EndOfFile = -1 ELSE GET #STSHdl,,SR END IF LOOP UNTIL EndOfFile CLOSE #STSHdl ' Go thru arrays to create winning array ' Figure max number of games played by a single team MaxGamesTm = 0 FOR i = 1 TO TblEnd xF! = SA(i).AWins / (SA(i).AWins + SA(i).ALosses) n = xF! * 1000 xS$ = LTRIM$(STR$(n)) SA(i).APct = PADZEROS$(xS$, 4) IF SA(i).AWins + SA(i).ALosses > MaxGamesTm THEN MaxGamesTm = SA(i).AWins + SA(i).ALosses END IF NEXT ' Use these figure for qualifying B.A. and ERA stats QualPlate = MaxGamesTm * 3.1 QualInn = MaxGamesTm IF QualInn < 1 THEN QualInn = 1 QualPA = STR$(QualPlate) QualIP = STR$(QualInn) ' Sort by League/Div/Pct ARRAY SORT SA(1) FOR TblEnd, FROM 1 TO 6, DESCEND OUTHdl = FREEFILE OPEN Outdevice$ FOR OUTPUT AS #OUTHdl PageNo = 1 PRINT #OUTHdl, PRINT #OUTHdl, "SBS 4.9"; TAB(35); "Strategic Baseball Statistics" PRINT #OUTHdl, "Date: "; DATE$ PRINT #OUTHdl, "Time: "; TIME$ PRINT #OUTHdl, "File: "; StatFile$ PRINT #OUTHdl, IF PrtStandings = 0 THEN GOTO TryPrtHighlights LeagueCtr = 0 i = 1 DO SaveLeague$ = SA(i).ALeague GOSUB GetLeagueName PRINT #OutHdl, PRINT #OUTHdl, LeagueName$ ' 0 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 0 0 1 1 2 2 3 3 4 ' 1 5 0 5 0 5 0 5 0 5 0 5 0 5 0 5 0 5 0 5 0 5 0 5 0 5 0 PRINT #OUTHdl, " --------- Home -------- --------- Road -------- Avg. " PRINT #OUTHdl, "Team W L Pct GB W L RS RA W L RS RA RS RA Hits Errs LOB DP Score" LeagueCtr = LeagueCtr + 1 LegHomWins = 0 LegHomLosses = 0 LegHomRunsS = 0 LegHomRunsA = 0 LegVisWins = 0 LegVisLosses = 0 LegVisRunsS = 0 LegVisRunsA = 0 LegRuns = 0 LegOppRuns = 0 LegHits = 0 LegErrs = 0 LegLOB = 0 LegDP = 0 LegGames = 0 DO WHILE SA(i).ALeague = SaveLeague$ AND i <= TblEnd SaveDiv$ = SA(i).ADiv DivName$ = SPACE$(16) IF SaveDiv$ = "E" THEN DivName$ = "E Division" IF SaveDiv$ = "C" THEN DivName$ = "C Division" IF SaveDiv$ = "W" THEN DivName$ = "W Division" PRINT #OutHdl, PRINT #OUTHdl, DivName$ d = 1 DO WHILE SA(i).ADiv = SaveDiv$ AND SA(i).ALeague = SaveLeague$ AND i <= TblEnd IF d = 1 THEN a = SA(i).AWins - SA(i).ALosses Games = SA(i).AWins + SA(i).ALosses b = SA(i).AWins - SA(i).ALosses c = (a - b) \ 2 xF! = (a - b) / 2 IF d = 1 OR (c = 0 AND xF! < .002) THEN GB$ = " -" ELSEIF c < 0 THEN GB$ = " " ELSE GB$ = LTRIM$(STR$(c)) END IF IF xF! - .002 > c THEN GB$ = GB$ + ".5" GB$ = PADLEFT$(GB$, 5) a$ = SPACE$(139) MID$(a$, 1, 12) = SA(i).ANam MID$(a$, 13, 6) = LFORMAT$(SA(i).AWins, "######") MID$(a$, 19, 6) = LFORMAT$(SA(i).ALosses, "######") IF SA(i).APct > "0998" THEN MID$(a$, 26, 5) = "1.000" ELSE MID$(a$, 27, 1) = "." MID$(a$, 28, 3) = RIGHT$(SA(i).APct, 3) END IF MID$(a$, 31, 5) = GB$ MID$(a$, 36, 6) = LFORMAT$(SA(i).AHomWins, "######") MID$(a$, 42, 6) = LFORMAT$(SA(i).AHomLosses, "######") MID$(a$, 48, 7) = LFORMAT$(SA(i).AHRunsS, "#######") MID$(a$, 55, 7) = LFORMAT$(SA(i).AHRunsA, "#######") MID$(a$, 62, 6) = LFORMAT$(SA(i).AVisWins, "######") MID$(a$, 68, 6) = LFORMAT$(SA(i).AVisLosses, "######") MID$(a$, 74, 7) = LFORMAT$(SA(i).AVRunsS, "#######") MID$(a$, 81, 7) = LFORMAT$(SA(i).AVRunsA, "#######") MID$(a$, 90, 7) = LFORMAT$(SA(i).ARuns, "#######") MID$(a$, 97, 7) = LFORMAT$(SA(i).AOppRuns, "#######") MID$(a$,104, 7) = LFORMAT$(SA(i).AHits, "#######") MID$(a$,111, 6) = LFORMAT$(SA(i).AErrs, "######") MID$(a$,117, 7) = LFORMAT$(SA(i).ALOB, "#######") MID$(a$,124, 6) = LFORMAT$(SA(i).ADP, "######") MID$(a$,131, 4) = FFORMAT$(SA(i).ARuns / Games, "##.#") MID$(a$,135, 1) = "-" MID$(a$,136, 4) = LTRIM$(FFORMAT$(SA(i).AOppRuns / Games, "##.#")) PRINT #OUTHdl, a$ LegHomWins = LegHomWins + SA(i).AHomWins LegHomLosses = LegHomLosses + SA(i).AHomLosses LegHomRunsS = LegHomRunsS + SA(i).AHRunsS LegHomRunsA = LegHomRunsA + SA(i).AHRunsA LegVisWins = LegVisWins + SA(i).AVisWins LegVisLosses = LegVisLosses + SA(i).AVisLosses LegVisRunsS = LegVisRunsS + SA(i).AVRunsS LegVisRunsA = LegVisRunsA + SA(i).AVRunsA LegRuns = LegRuns + SA(i).ARuns LegOppRuns = LegOppRuns + SA(i).AOppRuns LegHits = LegHits + SA(i).AHits LegErrs = LegErrs + SA(i).AErrs LegLOB = LegLOB + SA(i).ALOB LegDP = LegDP + SA(i).ADP LegGames = LegGames + Games i = i + 1 d = d + 1 LOOP ' Division Changed LOOP 'League Changed 'Print League Totals a$ = SPACE$(139) MID$(a$, 1, 28) = "League Totals" MID$(a$, 36, 6) = LFORMAT$(LegHomWins, "######") MID$(a$, 42, 6) = LFORMAT$(LegHomLosses, "######") MID$(a$, 48, 7) = LFORMAT$(LegHomRunsS, "#######") MID$(a$, 55, 7) = LFORMAT$(LegHomRunsA, "#######") MID$(a$, 62, 6) = LFORMAT$(LegVisWins, "######") MID$(a$, 68, 6) = LFORMAT$(LegVisLosses, "######") MID$(a$, 74, 7) = LFORMAT$(LegVisRunsS, "#######") MID$(a$, 81, 7) = LFORMAT$(LegVisRunsA, "#######") MID$(a$, 90, 7) = LFORMAT$(LegRuns, "#######") MID$(a$, 97, 7) = LFORMAT$(LegOppRuns, "#######") MID$(a$,104, 7) = LFORMAT$(LegHits, "#######") MID$(a$,111, 6) = LFORMAT$(LegErrs, "######") MID$(a$,117, 7) = LFORMAT$(LegLOB, "#######") MID$(a$,124, 6) = LFORMAT$(LegDP, "######") MID$(a$,131, 4) = FFORMAT$(LegRuns / LegGames, "##.#") MID$(a$,135, 1) = "-" MID$(a$,136, 4) = LTRIM$(FFORMAT$(LegOppRuns / LegGames, "##.#")) PRINT #OUTHdl, a$ 'Add to Grand Totals TotHomWins = TotHomWins + LegHomWins TotHomLosses = TotHomLosses + LegHomLosses TotHomRunsS = TotHomRunsS + LegHomRunsS TotHomRunsA = TotHomRunsA + LegHomRunsA TotVisWins = TotVisWins + LegVisWins TotVisLosses = TotVisLosses + LegVisLosses TotVisRunsS = TotVisRunsS + LegVisRunsS TotVisRunsA = TotVisRunsA + LegVisRunsA TotRuns = TotRuns + LegRuns TotOppRuns = TotOppRuns + LegOppRuns TotHits = TotHits + LegHits TotErrs = TotErrs + LegErrs TotLOB = TotLOB + LegLOB TotDP = TotDP + LegDP TotGames = TotGames + LegGames LOOP UNTIL i > TblEnd 'Print Grand Totals IF LeagueCtr > 1 THEN a$ = SPACE$(139) MID$(a$, 1, 28) = "**** Grand Totals ****" MID$(a$, 36, 6) = LFORMAT$(TotHomWins, "######") MID$(a$, 42, 6) = LFORMAT$(TotHomLosses, "######") MID$(a$, 48, 7) = LFORMAT$(TotHomRunsS, "#######") MID$(a$, 55, 7) = LFORMAT$(TotHomRunsA, "#######") MID$(a$, 62, 6) = LFORMAT$(TotVisWins, "######") MID$(a$, 68, 6) = LFORMAT$(TotVisLosses, "######") MID$(a$, 74, 7) = LFORMAT$(TotVisRunsS, "#######") MID$(a$, 81, 7) = LFORMAT$(TotVisRunsA, "#######") MID$(a$, 90, 7) = LFORMAT$(TotRuns, "#######") MID$(a$, 97, 7) = LFORMAT$(TotOppRuns, "#######") MID$(a$,104, 7) = LFORMAT$(TotHits, "#######") MID$(a$,111, 6) = LFORMAT$(TotErrs, "######") MID$(a$,117, 7) = LFORMAT$(TotLOB, "#######") MID$(a$,124, 6) = LFORMAT$(TotDP, "######") MID$(a$,131, 4) = FFORMAT$(TotRuns / TotGames, "##.#") MID$(a$,135, 1) = "-" MID$(a$,136, 4) = LTRIM$(FFORMAT$(TotOppRuns / TotGames, "##.#")) PRINT #OUTHdl, a$ END IF '=========== Highlight Section ============== TryPrtHighlights: ERASE SA IF PrtHighlights = 0 THEN GOTO TryPrtMain IF LEN(DIR$(StatFile$ + ".STH")) THEN STHHdl = FREEFILE OPEN StatFile$ + ".STH" FOR BINARY AS #STHHdl IF LOF(STHHdl) = 0 THEN CLOSE #STHHdl ELSE CLOSE #STHHdl PRINT #OUTHdl, PRINT #OUTHdl, "Highlights of this Simulation" PRINT #OUTHdl, PRINT #OUTHdl, "Game/Event" OPEN StatFile$ + ".STH" FOR INPUT AS #STHHdl DO LINE INPUT #STHHdl, rec$ PRINT #OUTHdl, rec$ LOOP WHILE NOT EOF(STHHdl) CLOSE #STHHdl END IF END IF '======= Print long batting streaks still in progress ======= PRINT #OUTHdl, PRINT #OUTHdl, "Batting Streaks in Progress (at least 10 games)" PRINT #OUTHdl, STBHdl = FREEFILE OPEN StatFile$ + ".STB" FOR RANDOM AS #STBHdl LEN = LEN(BR) BatRecs = LOF(STBHdl) / LEN(BR) BatRecs = BatRecs - 2 'Ignore 1st and last records GET #STBHdl ,, BR 'Read sequentially GET #STBHdl ,, BR 'Skip 1st record rec = 1 i = 0 EndOfFile = 0 DO WHILE NOT EndOfFile 'Process "rec" IF BR.BStreak > 9 THEN PRINT #OUTHdl, BR.BTmNam; " "; BR.BNam; " "; BR.BStreak i = -1 END IF rec = rec + 1 IF rec > BatRecs THEN EndOfFile = -1 ELSE GET #STBHdl, , BR END IF LOOP IF i = 0 THEN PRINT #OUTHdl, "None" CLOSE #STBHdl '=========== Main Batting / Pitching /Fielding Section ============== ' Both files should already be sorted by League/Team/Player ' Summarize and Print TryPrtMain: IF PrtMain = 0 AND PrtLeaders = 0 THEN CLOSE #OUTHdl: GOTO QuickExit STBHdl = FREEFILE OPEN StatFile$ + ".STB" FOR RANDOM AS #STBHdl LEN = LEN(BR) STPHdl = FREEFILE OPEN StatFile$ + ".STP" FOR RANDOM AS #STPHdl LEN = LEN(PR) STFHdl = FREEFILE OPEN StatFile$ + ".STF" FOR RANDOM AS #STFHdl LEN = LEN(FR) BatRecs = LOF(STBHdl) / LEN(BR) BatRecs = BatRecs - 2 'Ignore 1st and last records GET #STBHdl ,, BR 'Read sequentially GET #STBHdl ,, BR 'Skip 1st record 'IF CollapseYY THEN BR.BTmNam = "XX" + MID$(BR.BTmNam, 3, 10) PitRecs = LOF(STPHdl) / LEN(PR) - 1 'Last record is ZZZZZZZ's PRPointer = 2 'Start at 2nd record FldRecs = LOF(STFHdl) / LEN(FR) - 1 'Last record is ZZZZZZZ's FRPointer = 2 'Start at 2nd record rec = 1 EndOfFile = 0 PREndOfFile = 0 FREndOfFile = 0 DO WHILE NOT EndOfFile SaveLeague$ = BR.BLeague GOSUB GetLeagueName IF PrtMain THEN GOSUB NewPage PRINT #OUTHdl, PRINT #OUTHdl, "League: "; LeagueName$ END IF 'League-leader value arrays REDIM TblP1!(TblMax) REDIM TblP2!(TblMax) REDIM TblP3!(TblMax) REDIM TblP4 (TblMax) REDIM TblP5 (TblMax) REDIM TblP6!(TblMax) REDIM TblPAvg!(TblMax) REDIM TblPRuns(TblMax) REDIM TblPHits(TblMax) REDIM TblP2B(TblMax) REDIM TblP3B(TblMax) REDIM TblPHR(TblMax) REDIM TblPRBI(TblMax) REDIM TblPBB(TblMax) REDIM TblPSB(TblMax) REDIM TblPInn!(TblMax) REDIM TblPERA!(TblMax) REDIM TblPSO(TblMax) REDIM TblPWins(TblMax) REDIM TblPSaves(TblMax) 'League-leader name arrays REDIM TblP1N(TblMax) AS SortStrType REDIM TblP2N(TblMax) AS SortStrType REDIM TblP3N(TblMax) AS SortStrType REDIM TblP4N(TblMax) AS SortStrType REDIM TblP5N(TblMax) AS SortStrType REDIM TblP6N(TblMax) AS SortStrType REDIM TblPAvgN(TblMax) AS SortStrType REDIM TblPRunsN(TblMax) AS SortStrType REDIM TblPHitsN(TblMax) AS SortStrType REDIM TblP2BN(TblMax) AS SortStrType REDIM TblP3BN(TblMax) AS SortStrType REDIM TblPHRN(TblMax) AS SortStrType REDIM TblPRBIN(TblMax) AS SortStrType REDIM TblPBBN(TblMax) AS SortStrType REDIM TblPSBN(TblMax) AS SortStrType REDIM TblPInnN(TblMax) AS SortStrType REDIM TblPERAN(TblMax) AS SortStrType REDIM TblPSON(TblMax) AS SortStrType REDIM TblPWinsN(TblMax) AS SortStrType REDIM TblPSavesN(TblMax) AS SortStrType FOR i = 1 TO TblMax: TblPERA!(i) = 99999.99: NEXT FOR i = 1 TO TblMax: TblP6!(i) = 99999.99: NEXT LegBGames = 0 LegBAB = 0 LegBRuns = 0 LegBHits = 0 LegB2B = 0 LegB3B = 0 LegBHR = 0 LegBRBI = 0 LegBBB = 0 LegBSO = 0 LegBSB = 0 LegBCS = 0 LegBERRs = 0 LegBHB = 0 LegBGDP = 0 LegBSacF = 0 LegBSacB = 0 LegPCG = 0 LegPShO = 0 LegPInn = 0 LegP3rds = 0 LegPRuns = 0 LegPERuns = 0 LegPHits = 0 LegPHR = 0 LegPBB = 0 LegPSO = 0 LegPHB = 0 LegPBF = 0 LegFErr = 0 LegFAss = 0 LegFPOs = 0 tdx = 0 DO WHILE BR.BLeague = SaveLeague$ AND NOT EndOfFile TmGames = 0 TmAB = 0 TmRuns = 0 TmHits = 0 Tm2B = 0 Tm3B = 0 TmHR = 0 TmRBI = 0 TmBB = 0 TmSO = 0 TmSB = 0 TmCS = 0 TmERRs = 0 TmHB = 0 TmGDP = 0 TmSacF = 0 TmSacB = 0 octr = 0 SaveTeam = BR.BTmNam IF PrtMain THEN PRINT #OUTHdl, PRINT #OUTHdl, xS$ = RTRIM$(UCASE$(BR.BTmNam)) + " " PRINT #OUTHdl, xS$ + STRING$(181 - LEN(xS$), "-") PRINT #OUTHdl, PRINT #OUTHdl, "Batting" PRINT #OUTHdl, PRINT #OUTHdl, "Name Avg G AB Runs Hits TB 2B 3B HR RBI SH SF HB BB SO SB CS SB% GIDP ERR OB Slg HR OPS TAvg RC/27" END IF DO WHILE SaveTeam = BR.BTmNam AND SaveLeague$ = BR.BLeague AND NOT EndOfFile IF rec = 32767 THEN EndOfFile = -1 EXIT DO END IF IF BR.BABs >= OtherAB THEN GOSUB PrintDetail ELSE INCR octr SaveOther(octr) = BR 'save record in array END IF 'Throw stuff into the "Leader Lists" IF PAvg! > TblPAvg!(TblMax) AND BR.BABs + BR.BBBs + BR.BHB >= QualPlate THEN TblPAvg!(TblMax) = PAvg! TblPAvgN(TblMax).SSItem = SaveTeam + " " + BR.BNam CALL BubbleSortFlt(TblPAvg!(), TblPAvgN(), "D") END IF IF BR.BRuns > TblPRuns(TblMax) THEN TblPRuns(TblMax) = BR.BRuns TblPRunsN(TblMax).SSItem = SaveTeam + " " + BR.BNam CALL BubbleSortInt(TblPRuns(), TblPRunsN()) END IF IF BR.BHits > TblPHits(TblMax) THEN TblPHits(TblMax) = BR.BHits TblPHitsN(TblMax).SSItem = SaveTeam + " " + BR.BNam CALL BubbleSortInt(TblPHits(), TblPHitsN()) END IF IF BR.B2Bs > TblP2B(TblMax) THEN TblP2B(TblMax) = BR.B2Bs TblP2BN(TblMax).SSItem = SaveTeam + " " + BR.BNam CALL BubbleSortInt(TblP2B(), TblP2BN()) END IF IF BR.B3Bs > TblP3B(TblMax) THEN TblP3B(TblMax) = BR.B3Bs TblP3BN(TblMax).SSItem = SaveTeam + " " + BR.BNam CALL BubbleSortInt(TblP3B(), TblP3BN()) END IF IF BR.BHRs > TblPHR(TblMax) THEN TblPHR(TblMax) = BR.BHRs TblPHRN(TblMax).SSItem = SaveTeam + " " + BR.BNam CALL BubbleSortInt(TblPHR(), TblPHRN()) END IF IF BR.BRBIs > TblPRBI(TblMax) THEN TblPRBI(TblMax) = BR.BRBIs TblPRBIN(TblMax).SSItem = SaveTeam + " " + BR.BNam CALL BubbleSortInt(TblPRBI(), TblPRBIN()) END IF IF BR.BBBs > TblPBB(TblMax) THEN TblPBB(TblMax) = BR.BBBs TblPBBN(TblMax).SSItem = SaveTeam + " " + BR.BNam CALL BubbleSortInt(TblPBB(), TblPBBN()) END IF IF BR.BSBs > TblPSB(TblMax) THEN TblPSB(TblMax) = BR.BSBs TblPSBN(TblMax).SSItem = SaveTeam + " " + BR.BNam CALL BubbleSortInt(TblPSB(), TblPSBN()) END IF IF rc27! > TblP1!(TblMax) AND BR.BABs + BR.BBBs + BR.BHB >= QualPlate THEN TblP1!(TblMax) = rc27! TblP1N(TblMax).SSItem = SaveTeam + " " + BR.BNam CALL BubbleSortFlt(TblP1!(), TblP1N(), "D") END IF IF OnBase! > TblP2!(TblMax) AND BR.BABs + BR.BBBs + BR.BHB >= QualPlate THEN TblP2!(TblMax) = OnBase! TblP2N(TblMax).SSItem = SaveTeam + " " + BR.BNam CALL BubbleSortFlt(TblP2!(), TblP2N(), "D") END IF IF slug! > TblP3!(TblMax) AND BR.BABs + BR.BBBs + BR.BHB >= QualPlate THEN TblP3!(TblMax) = slug! TblP3N(TblMax).SSItem = SaveTeam + " " + BR.BNam CALL BubbleSortFlt(TblP3!(), TblP3N(), "D") END IF TmAB = TmAB + BR.BABs TmRuns = TmRuns + BR.BRuns TmHits = TmHits + BR.BHits Tm2B = Tm2B + BR.B2Bs Tm3B = Tm3B + BR.B3Bs TmHR = TmHR + BR.BHRs TmRBI = TmRBI + BR.BRBIs TmBB = TmBB + BR.BBBs TmSO = TmSO + BR.BKs TmSB = TmSB + BR.BSBs TmCS = TmCS + BR.BCSs TmERRs = TmERRs + BR.BERRs TmHB = TmHB + BR.BHB TmGDP = TmGDP + BR.BGDP TmSacF = TmSacF + BR.BSacF TmSacB = TmSacB + BR.BSacB INCR rec IF rec > BatRecs THEN EndOfFile = -1 ELSE GET #STBHdl, , BR 'IF CollapseYY THEN BR.BTmNam = "XX" + MID$(BR.BTmNam, 3, 10) END IF IF INKEY$ = CHR$(27) THEN PRINT PRINT "Report Aborted!" EndOfFile = -1 END IF LOOP 'Team changed 'Sum the "Other" array OABs = 0 OGames = 0 ORuns = 0 OHits = 0 ORBIs = 0 O2Bs = 0 O3Bs = 0 OHRs = 0 OSBs = 0 OCSs = 0 OBBs = 0 OKs = 0 OErrs = 0 OHB = 0 OGDP = 0 OSacF = 0 OSacB = 0 FOR i = 1 TO octr OABs = OABs + SaveOther(i).BABs OGames = OGames + SaveOther(i).BGames ORuns = ORuns + SaveOther(i).BRuns OHits = OHits + SaveOther(i).BHits ORBIs = ORBIs + SaveOther(i).BRBIs O2Bs = O2Bs + SaveOther(i).B2Bs O3Bs = O3Bs + SaveOther(i).B3Bs OHRs = OHRs + SaveOther(i).BHRs OSBs = OSBs + SaveOther(i).BSBs OCSs = OCSs + SaveOther(i).BCSs OBBs = OBBs + SaveOther(i).BBBs OKs = OKs + SaveOther(i).BKs OErrs = OErrs + SaveOther(i).BErrs OHB = OHB + SaveOther(i).BHB OGDP = OGDP + SaveOther(i).BGDP OSacF = OSacF + SaveOther(i).BSacF OSacB = OSacB + SaveOther(i).BSacB NEXT IF octr > 0 THEN SaveBR = BR BR.BNam = "[Other]" BR.BTmNam = "" BR.BLeague = "" BR.BABs = OABs BR.BGames = 0 BR.BRuns = ORuns BR.BHits = OHits BR.BRBIs = ORBIs BR.B2Bs = O2Bs BR.B3Bs = O3Bs BR.BHRs = OHRs BR.BSBs = OSBs BR.BCSs = OCSs BR.BBBs = OBBs BR.BKs = OKs BR.BErrs = OErrs BR.BHB = OHB BR.BGDP = OGDP BR.BSacF = OSacF BR.BSacB = OSacB GOSUB PrintDetail BR = SaveBR END IF 'Print TEAM BATTING TOTALS IF TmAB <> 0 THEN TmAvg! = TmHits / TmAB ELSE TmAvg! = 0 'Expanded team batting statistics TB = TmHits + Tm2B + 2 * Tm3B + 3 * TmHR IF TmAB > 0 THEN Slug! = TB / TmAB ELSE Slug! = 0. END IF IF TmAB > 0 THEN HRPct! = TmHR / TmAB * 100 ELSE HRPct! = 0. END IF IF TmAB > 0 THEN OnBase! = (TmBB + TmHB + TmHits) / (TmBB + TmHB + TmAB) ELSE OnBase! = 0. END IF Prod! = OnBase! + Slug! IF TmSB <> 0 THEN Rate! = TmSB / (TmSB + TmCS) * 100 ELSE Rate! = 0. END IF IF (TmCS + TmAB - TmHits) > 0 THEN TotAvg! = (TB + TmSB + TmBB + TmHB) / (TmCS + TmAB - TmHits) ELSE TotAvg! = 0. END IF rc27! = RunsCreated27!(TmAB, TmHits, Tm2B, Tm3B, TmHR, TmBB, TmHB, TmSacB, TmSacF, TmSB, TmCS, TmGDP) IF PrtMain THEN 'Name Avg AB Runs Hits TB 2B 3B HR RBI SH SF HB BB SO SB CS SB% GIDP ERR OB Slg HR OPS TAvg RC/27 ' .#### ###### ###### ###### ###### ##### ##### ###### ###### ##### ##### ##### ###### ###### ##### ##### ###.# ##### ##### #.### #.### ##.# #.### #.### ##.## a$ = SPACE$(185) MID$(a$, 1, 15) = "TEAM TOTALS:" MID$(a$, 20, 5) = FFORMAT$(TmAvg!, ".####") MID$(a$, 31, 7) = LFORMAT$(TmAB, "#######") MID$(a$, 38, 7) = LFORMAT$(TmRuns, "#######") MID$(a$, 45, 7) = LFORMAT$(TmHits, "#######") MID$(a$, 52, 7) = LFORMAT$(TB, "#######") MID$(a$, 59, 6) = LFORMAT$(Tm2B, "######") MID$(a$, 65, 6) = LFORMAT$(Tm3B, "######") MID$(a$, 71, 7) = LFORMAT$(TmHR, "#######") MID$(a$, 78, 7) = LFORMAT$(TmRBI, "#######") MID$(a$, 85, 6) = LFORMAT$(TmSacB, "######") MID$(a$, 91, 6) = LFORMAT$(TmSacF, "######") MID$(a$, 97, 6) = LFORMAT$(TmHB, "######") MID$(a$,103, 7) = LFORMAT$(TmBB, "#######") MID$(a$,110, 7) = LFORMAT$(TmSO, "#######") MID$(a$,117, 6) = LFORMAT$(TmSB, "######") MID$(a$,123, 6) = LFORMAT$(TmCS, "######") MID$(a$,130, 5) = FFORMAT$(Rate!, "##0.#") MID$(a$,135, 6) = LFORMAT$(TmGDP, "######") MID$(a$,141, 6) = LFORMAT$(TmERRs, "######") MID$(a$,148, 5) = FFORMAT$(Onbase!, "#.###") MID$(a$,154, 5) = FFORMAT$(Slug!, "#.###") MID$(a$,160, 4) = FFORMAT$(HRPct!, "#0.#") MID$(a$,165, 5) = FFORMAT$(Prod!, "#.###") MID$(a$,171, 5) = FFORMAT$(TotAvg!, "#.###") MID$(a$,177, 5) = FFORMAT$(rc27!, "#0.##") GOSUB StripNulls PRINT #OUTHdl, a$ IF tdx < TeamsInLeagueLim THEN INCR tdx MID$(a$, 1, 15) = SaveTeam TeamBatSum(tdx) = a$ END IF END IF LegBAB = LegBAB + TmAB LegBRuns = LegBRuns + TmRuns LegBHits = LegBHits + TmHits LegB2B = LegB2B + Tm2B LegB3B = LegB3B + Tm3B LegBHR = LegBHR + TmHR LegBRBI = LegBRBI + TmRBI LegBBB = LegBBB + TmBB LegBSO = LegBSO + TmSO LegBSB = LegBSB + TmSB LegBCS = LegBCS + TmCS LegBERRs = LegBERRs + TmERRs LegBHB = LegBHB + TmHB LegBGDP = LegBGDP + TmGDP LegBSacF = LegBSacF + TmSacF LegBSacB = LegBSacB + TmSacB 'Print TEAM PITCHING ----------------------------------- 'Goto first record for this team in the pitching file GET #STPHdl, PRpointer, PR IF PR.PTmNam <> SaveTeam OR PR.PLeague <> SaveLeague$ THEN PRINT #OUTHdl, "File Synchronization Problem" END IF TmCG = 0 TmShO = 0 TmInn = 0 Tm3rds = 0 TmRuns = 0 TmERuns = 0 TmHits = 0 Tm2b = 0 Tm3b = 0 TmHR = 0 TmBB = 0 TmSO = 0 TmWin = 0 TmLoss = 0 TmSave = 0 TmBSave = 0 TmPHB = 0 TmPBF = 0 IF PrtMain THEN PRINT #OUTHdl, PRINT #OUTHdl, "Pitching" PRINT #OUTHdl, " Opp Opp Opp Opp" PRINT #OUTHdl, "Name W L S BS ERA G GS CG ShO Inns Hits Runs ERun HR HB BB SO SO/9 Avg Slg OB OPS" END IF SaveTeam = PR.PTmNam DO WHILE PR.PTmNam = SaveTeam AND SaveLeague$ = PR.PLeague AND NOT PREndOfFile Inns! = PR.PInns + PR.P3rds / 3 IF Inns! < .1 THEN Inns! = .1 PERA! = PR.PERuns / Inns! * 9! IF PERA! > 99.99 THEN PERA! = 99.99 'Expanded individual pitching statistics TB = PR.PHits + PR.P2Bs + 2 * PR.P3Bs + 3 * PR.PHRs IF (PR.PBF - PR.PBBs - PR.PHB) > 0 THEN Avg! = PR.PHits / (PR.PBF - PR.PBBs - PR.PHB) Slug! = TB / (PR.PBF - PR.PBBs - PR.PHB) ELSE Avg! = 0. Slug! = 0. END IF IF PR.PBF > 0 THEN OnBase! = (PR.PBBs + PR.PHB + PR.PHits) / PR.PBF ELSE OnBase! = 0. END IF Prod! = OnBase! + Slug! SO9! = PR.PSOs / (Inns! / 9.) xS$ = LEFT$(PR.PNam, 15) i = INSTR(PR.PNam, ",") IF i > 0 THEN yS$ = MID$(PR.PNam, 1, i - 1) ELSE yS$ = xS$ IF PrtMain THEN 'ame W L S BS ERA G GS CG ShO Inns Hits Runs ERun HR HB BB SO SO/9 Avg Slg OB OPS ' \ ##### ##### ##### #### ##.### ##### ##### ##### #### ######.# ###### ###### ###### ###### ##### ###### ###### ##.## #.### #.### #.### #.### \ \ a$ = SPACE$(175) MID$(a$, 1, 15) = xS$ MID$(a$, 17, 1) = PR.PThrows MID$(a$, 18, 5) = LFORMAT$(PR.PWin, "#####") MID$(a$, 24, 5) = LFORMAT$(PR.PLoss, "#####") MID$(a$, 30, 5) = LFORMAT$(PR.PSave, "#####") MID$(a$, 36, 4) = LFORMAT$(PR.PBS, "####") MID$(a$, 41, 6) = FFORMAT$(PERA!, "#0.###") MID$(a$, 48, 5) = LFORMAT$(PR.PGames, "#####") MID$(a$, 54, 5) = LFORMAT$(PR.PStarts,"#####") MID$(a$, 60, 5) = LFORMAT$(PR.PCGs, "#####") MID$(a$, 66, 4) = LFORMAT$(PR.PShOs, "####") IF Inns! < .3 THEN InnsX! = 0.0 ELSE InnsX! = Inns! MID$(a$, 71, 8) = FFORMAT$(InnsX!, "######.#") MID$(a$, 80, 6) = LFORMAT$(PR.PHits, "######") MID$(a$, 87, 6) = LFORMAT$(PR.PRuns, "######") MID$(a$, 94, 6) = LFORMAT$(PR.PERuns, "######") MID$(a$,101, 6) = LFORMAT$(PR.PHRs, "######") MID$(a$,108, 5) = LFORMAT$(PR.PHB, "#####") MID$(a$,114, 6) = LFORMAT$(PR.PBBs, "######") MID$(a$,121, 6) = LFORMAT$(PR.PSOs, "######") MID$(a$,128, 5) = FFORMAT$(SO9!, "#0.##") MID$(a$,134, 5) = FFORMAT$(Avg!, "#.###") MID$(a$,140, 5) = FFORMAT$(Slug!, "#.###") MID$(a$,146, 5) = FFORMAT$(Onbase!, "#.###") MID$(a$,152, 5) = FFORMAT$(Prod!, "#.###") MID$(a$,158, 15) = yS$ GOSUB StripNulls PRINT #OUTHdl, a$ END IF 'Throw stuff into the Pitcher "Leader Lists" IF PERA! < TblPERA!(TblMax) AND Inns! >= CSNG(QualInn) THEN TblPERA!(TblMax) = PERA! TblPERAN(TblMax).SSItem = SaveTeam + " " + PR.PNam CALL BubbleSortFlt(TblPERA!(), TblPERAN(), "A") END IF IF Inns! > TblPInn!(TblMax) THEN TblPInn!(TblMax) = Inns! TblPInnN(TblMax).SSItem = SaveTeam + " " + PR.PNam CALL BubbleSortFlt(TblPInn!(), TblPInnN(), "D") END IF IF PR.PWin > TblPWins(TblMax) THEN TblPWins(TblMax) = PR.PWin TblPWinsN(TblMax).SSItem = SaveTeam + " " + PR.PNam CALL BubbleSortInt(TblPWins(), TblPWinsN()) END IF IF PR.PSave > TblPSaves(TblMax) THEN TblPSaves(TblMax) = PR.PSave TblPSavesN(TblMax).SSItem = SaveTeam + " " + PR.PNam CALL BubbleSortInt(TblPSaves(), TblPSavesN()) END IF IF PR.PSOs > TblPSO(TblMax) THEN TblPSO(TblMax) = PR.PSOs TblPSON(TblMax).SSItem = SaveTeam + " " + PR.PNam CALL BubbleSortInt(TblPSO(), TblPSON()) END IF IF PR.PCGs > TblP4(TblMax) THEN TblP4(TblMax) = PR.PCGs TblP4N(TblMax).SSItem = SaveTeam + " " + PR.PNam CALL BubbleSortInt(TblP4(), TblP4N()) END IF IF PR.PShOs > TblP5(TblMax) THEN TblP5(TblMax) = PR.PShOs TblP5N(TblMax).SSItem = SaveTeam + " " + PR.PNam CALL BubbleSortInt(TblP5(), TblP5N()) END IF IF Prod! < TblP6!(TblMax) AND Inns! >= CSNG(QualInn) THEN TblP6!(TblMax) = Prod! TblP6N(TblMax).SSItem = SaveTeam + " " + PR.PNam CALL BubbleSortFlt(TblP6!(), TblP6N(), "A") END IF TmCG = TmCG + PR.PCGs TmShO = TmShO + PR.PShOs TmInn = TmInn + PR.PInns Tm3rds = Tm3rds + PR.P3rds TmRuns = TmRuns + PR.PRuns TmERuns = TmERuns + PR.PERuns TmHits = TmHits + PR.PHits Tm2B = Tm2B + PR.P2Bs Tm3B = Tm3B + PR.P3Bs TmHR = TmHR + PR.PHRs TmBB = TmBB + PR.PBBs TmSO = TmSO + PR.PSOs TmWin = TmWin + PR.PWin TmLoss = TmLoss + PR.PLoss TmSave = TmSave + PR.PSave TmBSave = TmBSave + PR.PBS TmPHB = TmPHB + PR.PHB TmPBF = TmPBF + PR.PBF PRPointer = PRPointer + 1 IF PRPointer > PitRecs THEN PREndOfFile = -1 ELSE GET #STPHdl, PRPointer, PR END IF LOOP 'Print TEAM PITCHING TOTALS Inns! = TmInn + Tm3rds / 3 IF Inns! = 0 THEN Inns! = .33 PERA! = TmERuns / Inns! * 9! IF PERA! > 99.99 THEN PERA! = 99.99 'Expanded team pitching statistics 'Old Way 'Avg! = TmHits / (.955 * (Inns! * 3 + TmHits)) 'Slug! = TB / (.955 * (Inns! * 3 + TmHits)) 'OnBase! = (TmBB + TmPHB + TmHits) / (.955 * (TmBB + TmPHB + Inns! * 3 + TmHits)) TB = TmHits + Tm2b + 2 * Tm3b + 3 * TmHR IF (TmPBF - TmBB - TmPHB) > 0 THEN Avg! = TmHits / (TmPBF - TmBB - TmPHB) Slug! = TB / (TmPBF - TmBB - TmPHB) ELSE Avg! = 0. Slug! = 0. END IF IF TmPBF > 0 THEN OnBase! = (TmBB + TmPHB + TmHits) / TmPBF ELSE OnBase! = 0. END IF Prod! = OnBase! + Slug! SO9! = TmSO / (Inns! / 9.) IF PrtMain THEN 'ame W L S BS ERA G GS CG ShO Inns Hits Runs ERun HR HB BB SO SO/9 Avg Slg OB OPS ' \ ##### ##### ##### #### ##.### ##### ##### ##### #### ######.# ###### ###### ###### ###### ##### ###### ###### ##.## #.### #.### #.### #.### a$ = SPACE$(175) MID$(a$, 1, 15) = "TEAM TOTALS:" MID$(a$, 17, 6) = LFORMAT$(TmWin, "######") MID$(a$, 23, 6) = LFORMAT$(TmLoss, "######") MID$(a$, 29, 6) = LFORMAT$(TmSave, "######") MID$(a$, 35, 5) = LFORMAT$(TmBSave, "#####") MID$(a$, 41, 6) = FFORMAT$(PERA!, "#0.###") MID$(a$, 59, 6) = LFORMAT$(TmCG, "######") MID$(a$, 65, 5) = LFORMAT$(TmShO, "#####") MID$(a$, 70, 9) = FFORMAT$(Inns!, "#######.#") MID$(a$, 79, 7) = LFORMAT$(TmHits, "#######") MID$(a$, 86, 7) = LFORMAT$(TmRuns, "#######") MID$(a$, 93, 7) = LFORMAT$(TmERuns, "#######") MID$(a$,100, 7) = LFORMAT$(TmHR, "#######") MID$(a$,107, 6) = LFORMAT$(TmPHB, "######") MID$(a$,113, 7) = LFORMAT$(TmBB, "#######") MID$(a$,120, 7) = LFORMAT$(TmSO, "#######") MID$(a$,128, 5) = FFORMAT$(SO9!, "#0.##") MID$(a$,134, 5) = FFORMAT$(Avg!, "#.###") MID$(a$,140, 5) = FFORMAT$(Slug!, "#.###") MID$(a$,146, 5) = FFORMAT$(Onbase!, "#.###") MID$(a$,152, 5) = FFORMAT$(Prod!, "#.###") GOSUB StripNulls PRINT #OUTHdl, a$ IF tdx < TeamsInLeagueLim THEN MID$(a$, 1, 15) = SaveTeam TeamPitSum(tdx) = a$ END IF END IF LegPCG = LegPCG + TmCG LegPShO = LegPShO + TmShO LegPInn = LegPInn + TmInn LegP3rds = LegP3rds + Tm3rds LegPRuns = LegPRuns + TmRuns LegPERuns = LegPERuns + TmERuns LegPHits = LegPHits + TmHits LegP2B = LegP2B + Tm2b LegP3B = LegP3B + Tm3b LegPHR = LegPHR + TmHR LegPBB = LegPBB + TmBB LegPSO = LegPSO + TmSO LegPHB = LegPHB + TmPHB LegPBF = LegPBF + TmPBF 'Print TEAM FIELDING ------------------------------------- 'Goto first record for this team in the fielding file GET #STFHdl, FRpointer, FR IF FR.FTmNam <> SaveTeam OR FR.FLeague <> SaveLeague$ THEN PRINT #OUTHdl, "File Synchronization Problem" END IF TmFErr = 0 TmFAss = 0 TmFPOs = 0 IF PrtMain AND PrtFielding THEN PRINT #OUTHdl, PRINT #OUTHdl, "Fielding" PRINT #OUTHdl, PRINT #OUTHdl, " Games-By-Position" 'old PRINT #OUTHdl, "Name Tot P C 1B 2B 3B SS LF CF RF DH Errs Assts POs Pct%" PRINT #OUTHdl, "Name Tot P C 1B 2B 3B SS LF CF RF DH Errors Assts POs Pct%" END IF SaveTeam = FR.FTmNam DO WHILE FR.FTmNam = SaveTeam AND SaveLeague$ = FR.FLeague AND NOT FREndOfFile xS$ = LEFT$(FR.FNam, 15) i = INSTR(FR.FNam, ",") IF i > 0 THEN yS$ = MID$(FR.FNam, 1, i - 1) ELSE yS$ = xS$ IF PrtMain AND PrtFielding THEN 'ame Tot P C 1B 2B 3B SS LF CF RF DH Errors Assts POs Pct%" ' \ ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ####### ####### ####### #.### a$ = SPACE$(143) MID$(a$, 1, 15) = xS$ MID$(a$, 17, 6) = LFORMAT$(FR.FCount, "######") ee = 0 ai = 0 po = 0 FOR i = 1 TO 10 IF FR.FGamesByPos(i) > 0 THEN MID$(a$, (7*i + 17), 6) = LFORMAT$(FR.FGamesByPos(i), "######") ELSE MID$(a$, (7*i + 22), 1) = "-" END IF ee = ee + FR.FErrsByPos(i) ai = ai + FR.FAssistsByPos(i) po = po + FR.FPutOutsByPos(i) NEXT MID$(a$, 96, 7) = LFORMAT$(ee, "#######") MID$(a$,104, 7) = LFORMAT$(ai, "#######") MID$(a$,112, 7) = LFORMAT$(po, "#######") IF ee + ai + po > 0 THEN dpct! = (ai + po) / (ee + ai + po) ELSE dpct! = 1.000 END IF MID$(a$,120, 6) = FFORMAT$(dpct!, "#.####") MID$(a$,128, 15) = yS$ PRINT #OUTHdl, a$ 'Add to team totals TmFErr = TmFErr + ee TmFAss = TmFAss + ai TmFPOs = TmFPOs + po IF FieldBD THEN 'Count how many positions were played (pp) and 'store what the were - ignore DH REDIM plist(9) AS INTEGER pp = 0 FOR p = 1 TO 9 IF FR.FGamesByPos(p) > 0 THEN INCR pp plist(pp) = p END IF NEXT 'Break out individual positions IF pp > 1 THEN FOR i = 1 TO pp p = plist(i) ' a$ = SPACE$(115) ' MID$(a$, 4, 3) = Pos(p) ' MID$(a$, (5*p + 17), 4) = LFORMAT$(FR.FGamesByPos(p), "####") ' MID$(a$, 74, 5) = LFORMAT$(FR.FErrsByPos(p), "#####") ' MID$(a$, 80, 5) = LFORMAT$(FR.FAssistsByPos(p),"#####") ' MID$(a$, 86, 5) = LFORMAT$(FR.FPutOutsByPos(p),"#####") a$ = SPACE$(126) MID$(a$, 4, 3) = Pos(p) MID$(a$, (7*p + 17), 6) = LFORMAT$(FR.FGamesByPos(p), "######") MID$(a$, 96, 7) = LFORMAT$(FR.FErrsByPos(p), "#######") MID$(a$,104, 7) = LFORMAT$(FR.FAssistsByPos(p),"#######") MID$(a$,112, 7) = LFORMAT$(FR.FPutOutsByPos(p),"#######") ee = FR.FErrsByPos(p) ai = FR.FAssistsByPos(p) po = FR.FPutOutsByPos(p) IF ee + ai + po > 0 THEN dpct! = (ai + po) / (ee + ai + po) ELSE dpct! = 1.000 END IF ' MID$(a$, 92, 5) = FFORMAT$(dpct!, "#.###") MID$(a$,120, 6) = FFORMAT$(dpct!, "#.####") PRINT #OUTHdl, a$ NEXT END IF END IF END IF 'Throw stuff into the Fielding "Leader Lists" FRPointer = FRPointer + 1 IF FRPointer > FldRecs THEN FREndOfFile = -1 ELSE GET #STFHdl, FRPointer, FR END IF LOOP 'Print TEAM FIELDING TOTALS IF PrtMain AND PrtFielding THEN a$ = SPACE$(143) MID$(a$, 1, 15) = "TEAM TOTALS:" ' MID$(a$, 74, 5) = LFORMAT$(TmFErr, "#####") ' MID$(a$, 80, 5) = LFORMAT$(TmFAss, "#####") ' MID$(a$, 86, 5) = LFORMAT$(TmFPOs, "#####") MID$(a$, 96, 7) = LFORMAT$(TmFErr, "#######") MID$(a$,104, 7) = LFORMAT$(TmFAss, "#######") MID$(a$,112, 7) = LFORMAT$(TmFPOs, "#######") ee = TmFErr ai = TmFAss po = TmFPOs IF ee + ai + po > 0 THEN dpct! = (ai + po) / (ee + ai + po) ELSE dpct! = 1.000 END IF ' MID$(a$, 92, 6) = FFORMAT$(dpct!, "#.####") MID$(a$,120, 6) = FFORMAT$(dpct!, "#.####") PRINT #OUTHdl, a$ IF tdx < TeamsInLeagueLim THEN z$ = SPACE$(46) MID$(z$, 1, 15) = SaveTeam ' MID$(z$, 17, 24) = MID$(a$, 74, 24) MID$(z$, 17, 30) = MID$(a$, 96, 30) TeamFldSum(tdx) = z$ END IF END IF LegFErr = LegFErr + TmFErr LegFAss = LegFAss + TmFAss LegFPOs = LegFPOs + TmFPOs LOOP 'League Changed 'Print League BATTING Totals PRINT #OUTHdl, PRINT #OUTHdl, PRINT #OUTHdl, PRINT #OUTHdl, "LEAGUE BATTING SUMMARY BY TEAM" PRINT #OUTHdl, 'oldPRINT #OUTHdl, "Team Avg AB Runs Hits TB 2B 3B HR RBI SH SF HB BB SO SB CS SB% GIDP ERR OB Slg HR% OPS TAvg RC/27" PRINT #OUTHdl, "Team Avg AB Runs Hits TB 2B 3B HR RBI SH SF HB BB SO SB CS SB% GIDP ERR OB Slg HR OPS TAvg RC/27" ARRAY SORT TeamBatSum() FOR tdx, FROM 39 TO 44, DESCEND FOR i = 1 TO tdx x$ = TeamBatSum(i) PRINT #OUTHdl, x$ NEXT IF LegBAB <> 0 THEN LegAvg! = LegBHits / LegBAB ELSE LegAvg! = 0 'Expanded league BATTING statistics TB = LegBHits + LegB2B + 2 * LegB3B + 3 * LegBHR IF LegBAB > 0 THEN Slug! = TB / LegBAB ELSE Slug! = 0. END IF IF LegBAB > 0 THEN HRPct! = LegBHR / LegBAB * 100 ELSE HRPct! = 0. END IF IF LegBAB > 0 THEN OnBase! = (LegBBB + LegBHB + LegBHits) / (LegBBB + LegBHB + LegBAB) ELSE OnBase! = 0. END IF Prod! = OnBase! + Slug! IF LegBSB <> 0 THEN Rate! = LegBSB / (LegBSB + LegBCS) * 100 ELSE Rate! = 0. END IF IF (LegBCS + LegBAB - LegBHits) > 0 THEN TotAvg! = (TB + LegBSB + LegBBB + LegBHB) / (LegBCS + LegBAB - LegBHits) ELSE TotAvg! = 0. END IF rc27! = RunsCreated27!(LegBAB, LegBHits, LegB2B, LegB3B, LegBHR, LegBBB, LegBHB, LegBSacB, LegBSacF, LegBSB, LegBCS, LegBGDP) IF PrtMain THEN PRINT #OUTHdl, a$ = SPACE$(185) MID$(a$, 1, 12) = "LEAGUE BAT.:" MID$(a$, 14, 1) = SaveLeague$ MID$(a$, 20, 5) = FFORMAT$(LegAvg!, ".####") MID$(a$, 30, 8) = LFORMAT$(LegBAB, "########") MID$(a$, 38, 7) = LFORMAT$(LegBRuns,"#######") MID$(a$, 45, 7) = LFORMAT$(LegBHits,"#######") MID$(a$, 52, 7) = LFORMAT$(TB, "#######") MID$(a$, 59, 6) = LFORMAT$(LegB2B, "######") MID$(a$, 65, 6) = LFORMAT$(LegB3B, "######") MID$(a$, 71, 7) = LFORMAT$(LegBHR, "#######") MID$(a$, 78, 7) = LFORMAT$(LegBRBI, "#######") MID$(a$, 85, 6) = LFORMAT$(LegBSacB, "######") MID$(a$, 91, 6) = LFORMAT$(LegBSacF, "######") MID$(a$, 97, 6) = LFORMAT$(LegBHB, "######") MID$(a$, 103, 7) = LFORMAT$(LegBBB, "#######") MID$(a$, 110, 7) = LFORMAT$(LegBSO, "#######") MID$(a$, 117, 6) = LFORMAT$(LegBSB, "######") MID$(a$, 123, 6) = LFORMAT$(LegBCS, "######") MID$(a$, 130, 5) = FFORMAT$(Rate!, "##0.#") MID$(a$, 135, 6) = LFORMAT$(LegBGDP, "######") MID$(a$, 141, 6) = LFORMAT$(LegBERRs, "######") MID$(a$, 148, 5) = FFORMAT$(Onbase!, "#.###") MID$(a$, 154, 5) = FFORMAT$(Slug!, "#.###") MID$(a$, 160, 4) = FFORMAT$(HRPct!, "#0.#") MID$(a$, 165, 5) = FFORMAT$(Prod!, "#.###") MID$(a$, 171, 5) = FFORMAT$(TotAvg!, "#.###") MID$(a$, 177, 5) = FFORMAT$(rc27!, "#0.##") GOSUB StripNulls PRINT #OUTHdl, a$ END IF 'Print League PITCHING Totals PRINT #OUTHdl, PRINT #OUTHdl, PRINT #OUTHdl, PRINT #OUTHdl, "LEAGUE PITCHING SUMMARY BY TEAM" PRINT #OUTHdl, 'oldPRINT #OUTHdl, "Team W L S BS ERA CG ShO Inns Hits Runs ERun HR HB BB SO SO/9 Avg Slg OB OPS" PRINT #OUTHdl, " Opp Opp Opp Opp" PRINT #OUTHdl, "Name W L S BS ERA CG ShO Inns Hits Runs ERun HR HB BB SO SO/9 Avg Slg OB OPS" ARRAY SORT TeamPitSum() FOR tdx, FROM 87 TO 92, ASCEND FOR i = 1 TO tdx x$ = TeamPitSum(i) PRINT #OUTHdl, x$ NEXT Inns! = LegPInn + LegP3rds / 3 IF Inns! = 0 THEN Inns! = .33 PERA! = LegPERuns / Inns! * 9! IF PERA! > 99.99 THEN PERA! = 99.99 'Expanded League PITCHING Statistics TB = LegPHits + LegP2B + 2 * LegP3B + 3 * LegPHR IF (LegPBF - LegPBB - LegPHB) > 0 THEN Avg! = LegPHits / (LegPBF - LegPBB - LegPHB) Slug! = TB / (LegPBF - LegPBB - LegPHB) ELSE Avg! = 0. Slug! = 0. END IF IF LegPBF > 0 THEN OnBase! = (LegPBB + LegPHB + LegPHits) / LegPBF ELSE OnBase! = 0. END IF Prod! = OnBase! + Slug! SO9! = LegPSO / (Inns! / 9.) IF PrtMain THEN PRINT #OUTHdl, a$ = SPACE$(175) MID$(a$, 1, 12) = "LEAGUE PIT.:" MID$(a$, 14, 1) = SaveLeague$ MID$(a$, 41, 6) = FFORMAT$(PERA!, "#0.###") MID$(a$, 60, 5) = LFORMAT$(LegPCG, "#####") MID$(a$, 65, 5) = LFORMAT$(LegPShO, "#####") MID$(a$, 70, 9) = FFORMAT$(Inns!, "#######.#") MID$(a$, 79, 7) = LFORMAT$(LegPHits, "#######") MID$(a$, 86, 7) = LFORMAT$(LegPRuns, "#######") MID$(a$, 93, 7) = LFORMAT$(LegPERuns, "#######") MID$(a$, 100, 7) = LFORMAT$(LegPHR, "#######") MID$(a$, 107, 6) = LFORMAT$(LegPHB, "######") MID$(a$, 113, 7) = LFORMAT$(LegPBB, "#######") MID$(a$, 120, 7) = LFORMAT$(LegPSO, "#######") MID$(a$, 128, 5) = FFORMAT$(SO9!, "#0.##") MID$(a$, 134, 5) = FFORMAT$(Avg!, "#.###") MID$(a$, 140, 5) = FFORMAT$(Slug!, "#.###") MID$(a$, 146, 5) = FFORMAT$(Onbase!, "#.###") MID$(a$, 152, 5) = FFORMAT$(Prod!, "#.###") GOSUB StripNulls PRINT #OUTHdl, a$ END IF 'Print League FIELDING Totals PRINT #OUTHdl, PRINT #OUTHdl, PRINT #OUTHdl, PRINT #OUTHdl, "LEAGUE FIELDING SUMMARY BY TEAM" PRINT #OUTHdl, ARRAY SORT TeamFldSum() FOR tdx, FROM 41 TO 46, DESCEND PRINT #OUTHdl, "Team Errs Assts POs Pct%" ee = 0: ai = 0: po = 0 FOR i = 1 TO tdx x$ = TeamFldSum(i) ee = ee + VAL(MID$(x$, 17, 7)) ai = ai + VAL(MID$(x$, 25, 7)) po = po + VAL(MID$(x$, 33, 7)) PRINT #OUTHdl, x$ NEXT a$ = SPACE$(46) MID$(a$, 17, 7) = LFORMAT$(ee, "#######") MID$(a$, 25, 7) = LFORMAT$(ai, "#######") MID$(a$, 33, 7) = LFORMAT$(po, "#######") IF ee + ai + po > 0 THEN dpct! = (ai + po) / (ee + ai + po) ELSE dpct! = 1.000 END IF MID$(a$, 41, 6) = FFORMAT$(dpct!, "#.####") PRINT #OUTHdl, a$ 'Print Individual League Batting Leaders IF PrtLeaders = 0 THEN GOTO EscLeaders PRINT #OUTHdl, PRINT #OUTHdl, PRINT #OUTHdl, PRINT #OUTHdl, "=============================" PRINT #OUTHdl, "League Batting Leaders - "; LeagueName$ PRINT #OUTHdl, "=============================" PRINT #OUTHdl, PRINT #OUTHdl, "Batting Avg (Based on"; QualPA; " PA) ====== Runs ================================" ' 1 \ .### \ \ ####" ' 2 \ .### " ' 3 \ \ ####" FOR i = 1 TO TblMax IF TblPAvg!(i) < .001 AND TblPRuns(i) > 0 THEN a$ = SPACE$(80) MID$(a$, 41, 29) = TblPRunsN(i).SSItem MID$(a$, 72, 6) = LFORMAT$(TblPRuns(i), "######") PRINT #OUTHdl, a$ ELSEIF TblPAvg!(i) > .001 AND TblPRuns(i) = 0 THEN a$ = SPACE$(80) MID$(a$, 1, 29) = TblPAvgN(i).SSItem MID$(a$, 33, 4) = FFORMAT$(TblPAvg!(i), ".###") PRINT #OUTHdl, a$ ELSEIF TblPAvg!(i) > .001 AND TblPRuns(i) > 0 THEN a$ = SPACE$(80) MID$(a$, 1, 29) = TblPAvgN(i).SSItem MID$(a$, 33, 4) = FFORMAT$(TblPAvg!(i), ".###") MID$(a$, 41, 29) = TblPRunsN(i).SSItem MID$(a$, 72, 6) = LFORMAT$(TblPRuns(i), "######") PRINT #OUTHdl, a$ END IF NEXT PRINT #OUTHdl, PRINT #OUTHdl, "Hits =============================== Home Runs ===========================" ' 1 \ #### \ \ ####" ' 2 \ #### " ' 3 \ \ ####" FOR i = 1 TO TblMax IF TblPHits(i) = 0 AND TblPHR(i) > 0 THEN a$ = SPACE$(80) MID$(a$, 41, 29) = TblPHRN(i).SSItem MID$(a$, 72, 6) = LFORMAT$(TblPHR(i), "######") PRINT #OUTHdl, a$ ELSEIF TblPHits(i) > 0 AND TblPHR(i) = 0 THEN a$ = SPACE$(80) MID$(a$, 1, 29) = TblPHitsN(i).SSItem MID$(a$, 31, 6) = LFORMAT$(TblPHits(i), "######") PRINT #OUTHdl, a$ ELSEIF TblPHits(i) > 0 AND TblPHR(i) > 0 THEN a$ = SPACE$(80) MID$(a$, 1, 29) = TblPHitsN(i).SSItem MID$(a$, 31, 6) = LFORMAT$(TblPHits(i), "######") MID$(a$, 41, 29) = TblPHRN(i).SSItem MID$(a$, 72, 6) = LFORMAT$(TblPHR(i), "######") PRINT #OUTHdl, a$ END IF NEXT PRINT #OUTHdl, PRINT #OUTHdl, "Doubles ============================ Triples =============================" FOR i = 1 TO TblMax IF TblP2B(i) = 0 AND TblP3B(i) > 0 THEN a$ = SPACE$(80) MID$(a$, 41, 29) = TblP3BN(i).SSItem MID$(a$, 72, 6) = LFORMAT$(TblP3B(i), "######") PRINT #OUTHdl, a$ ELSEIF TblP2B(i) > 0 AND TblP3B(i) = 0 THEN a$ = SPACE$(80) MID$(a$, 1, 29) = TblP2BN(i).SSItem MID$(a$, 31, 6) = LFORMAT$(TblP2B(i), "######") PRINT #OUTHdl, a$ ELSEIF TblP2B(i) > 0 AND TblP3B(i) > 0 THEN a$ = SPACE$(80) MID$(a$, 1, 29) = TblP2BN(i).SSItem MID$(a$, 31, 6) = LFORMAT$(TblP2B(i), "######") MID$(a$, 41, 29) = TblP3BN(i).SSItem MID$(a$, 72, 6) = LFORMAT$(TblP3B(i), "######") PRINT #OUTHdl, a$ END IF NEXT PRINT #OUTHdl, PRINT #OUTHdl, "RBI ================================ Walks ===============================" FOR i = 1 TO TblMax IF TblPRBI(i) = 0 AND TblPBB(i) > 0 THEN a$ = SPACE$(80) MID$(a$, 41, 29) = TblPBBN(i).SSItem MID$(a$, 72, 6) = LFORMAT$(TblPBB(i), "######") PRINT #OUTHdl, a$ ELSEIF TblPRBI(i) > 0 AND TblPBB(i) = 0 THEN a$ = SPACE$(80) MID$(a$, 1, 29) = TblPRBIN(i).SSItem MID$(a$, 31, 6) = LFORMAT$(TblPRBI(i), "######") PRINT #OUTHdl, a$ ELSEIF TblPRBI(i) > 0 AND TblPBB(i) > 0 THEN a$ = SPACE$(80) MID$(a$, 1, 29) = TblPRBIN(i).SSItem MID$(a$, 31, 6) = LFORMAT$(TblPRBI(i), "######") MID$(a$, 41, 29) = TblPBBN(i).SSItem MID$(a$, 72, 6) = LFORMAT$(TblPBB(i), "######") PRINT #OUTHdl, a$ END IF NEXT PRINT #OUTHdl, PRINT #OUTHdl, "Stolen Bases ======================= On-Base Pct. ========================" FOR i = 1 TO TblMax IF TblPSB(i) = 0 AND TblP2!(i) > 0 THEN a$ = SPACE$(80) MID$(a$, 41, 29) = TblP2N(i).SSItem MID$(a$, 74, 4) = FFORMAT$(TblP2!(i), ".###") PRINT #OUTHdl, a$ ELSEIF TblPSB(i) > 0 AND TblP2!(i) = 0 THEN a$ = SPACE$(80) MID$(a$, 1, 29) = TblPSBN(i).SSItem MID$(a$, 31, 6) = LFORMAT$(TblPSB(i), "######") PRINT #OUTHdl, a$ ELSEIF TblPSB(i) > 0 AND TblP2!(i) > 0 THEN a$ = SPACE$(80) MID$(a$, 1, 29) = TblPSBN(i).SSItem MID$(a$, 31, 6) = LFORMAT$(TblPSB(i), "######") MID$(a$, 41, 29) = TblP2N(i).SSItem MID$(a$, 74, 4) = FFORMAT$(TblP2!(i), ".###") PRINT #OUTHdl, a$ END IF NEXT PRINT #OUTHdl, PRINT #OUTHdl, "Slugging =========================== Runs Created Per 27 Outs ============" FOR i = 1 TO TblMax IF TblP3!(i) = 0 AND TblP1!(i) > 0 THEN a$ = SPACE$(80) MID$(a$, 41, 29) = TblP1N(i).SSItem MID$(a$, 73, 5) = FFORMAT$(TblP1!(i), "#0.##") PRINT #OUTHdl, a$ ELSEIF TblP3!(i) > 0 AND TblP1!(i) = 0 THEN a$ = SPACE$(80) MID$(a$, 1, 29) = TblP3N(i).SSItem MID$(a$, 32, 5) = FFORMAT$(TblP3!(i), "#.###") PRINT #OUTHdl, a$ ELSEIF TblP3!(i) > 0 AND TblP1!(i) > 0 THEN a$ = SPACE$(80) MID$(a$, 1, 29) = TblP3N(i).SSItem MID$(a$, 32, 5) = FFORMAT$(TblP3!(i), "#.###") MID$(a$, 41, 29) = TblP1N(i).SSItem MID$(a$, 73, 5) = FFORMAT$(TblP1!(i), "#0.##") PRINT #OUTHdl, a$ END IF NEXT 'Print League Pitching Leaders PRINT #OUTHdl, PRINT #OUTHdl, PRINT #OUTHdl, PRINT #OUTHdl, "==============================" PRINT #OUTHdl, "League Pitching Leaders - "; LeagueName$ PRINT #OUTHdl, "==============================" PRINT #OUTHdl, PRINT #OUTHdl, "Innings ============================ Wins ================================" ' 1 \####.# \ \ ####" ' 2 \####.# " ' 3 \ \ ####" FOR i = 1 TO TblMax IF TblPInn!(i) < .001 AND TblPWins(i) > 0 THEN a$ = SPACE$(80) MID$(a$, 41, 29) = TblPWinsN(i).SSItem MID$(a$, 72, 6) = LFORMAT$(TblPWins(i), "######") PRINT #OUTHdl, a$ ELSEIF TblPInn!(i) > .001 AND TblPWins(i) = 0 THEN a$ = SPACE$(80) MID$(a$, 1, 29) = TblPInnN(i).SSItem MID$(a$, 29, 8) = FFORMAT$(TblPInn!(i), "######.#") PRINT #OUTHdl, a$ ELSEIF TblPInn!(i) > .001 AND TblPWins(i) > 0 THEN a$ = SPACE$(80) MID$(a$, 1, 29) = TblPInnN(i).SSItem MID$(a$, 29, 8) = FFORMAT$(TblPInn!(i), "######.#") MID$(a$, 41, 29) = TblPWinsN(i).SSItem MID$(a$, 72, 6) = LFORMAT$(TblPWins(i), "######") PRINT #OUTHdl, a$ END IF NEXT PRINT #OUTHdl, PRINT #OUTHdl, "ERA (Based on"; QualIP; " Inn) ============= Strike Outs =========================" ' 1 \##.### \ \ ####" ' 2 \##.### " ' 3 \ \ ####" FOR i = 1 TO TblMax IF TblPERA!(i) > 99.999 THEN TblPERA!(i) = 99.999 IF TblPERAN(i).SSItem < "!" AND TblPSO(i) > 0 THEN a$ = SPACE$(80) MID$(a$, 41, 29) = TblPSON(i).SSItem MID$(a$, 72, 6) = LFORMAT$(TblPSO(i), "######") PRINT #OUTHdl, a$ ELSEIF TblPERAN(i).SSItem > "!" AND TblPSO(i) = 0 THEN a$ = SPACE$(80) MID$(a$, 1, 29) = TblPERAN(i).SSItem MID$(a$, 32, 5) = FFORMAT$(TblPERA!(i), "#0.##") PRINT #OUTHdl, a$ ELSEIF TblPERAN(i).SSItem > "!" AND TblPSO(i) > 0 THEN a$ = SPACE$(80) MID$(a$, 1, 29) = TblPERAN(i).SSItem MID$(a$, 32, 5) = FFORMAT$(TblPERA!(i), "#0.##") MID$(a$, 41, 29) = TblPSON(i).SSItem MID$(a$, 72, 6) = LFORMAT$(TblPSO(i), "######") PRINT #OUTHdl, a$ END IF NEXT PRINT #OUTHdl, PRINT #OUTHdl, "Saves ============================== Complete Games ======================" ' \ ####" FOR i = 1 TO TblMax IF TblPSaves(i) = 0 AND TblP4(i) > 0 THEN a$ = SPACE$(80) MID$(a$, 41, 29) = TblP4N(i).SSItem MID$(a$, 72, 6) = LFORMAT$(TblP4(i), "######") PRINT #OUTHdl, a$ ELSEIF TblPSaves(i) > 0 AND TblP4(i) = 0 THEN a$ = SPACE$(80) MID$(a$, 1, 29) = TblPSavesN(i).SSItem MID$(a$, 31, 6) = LFORMAT$(TblPSaves(i), "######") PRINT #OUTHdl, a$ ELSEIF TblPSaves(i) > 0 AND TblP4(i) > 0 THEN a$ = SPACE$(80) MID$(a$, 1, 29) = TblPSavesN(i).SSItem MID$(a$, 31, 6) = LFORMAT$(TblPSaves(i), "######") MID$(a$, 41, 29) = TblP4N(i).SSItem MID$(a$, 72, 6) = LFORMAT$(TblP4(i), "######") PRINT #OUTHdl, a$ END IF NEXT PRINT #OUTHdl, PRINT #OUTHdl, "ShutOuts =========================== OPS (OBP + Slug.) ===================" ' \ ####" FOR i = 1 TO TblMax IF TblP5(i) = 0 AND TblP6!(i) < 99999. THEN a$ = SPACE$(80) MID$(a$, 41, 29) = TblP6N(i).SSItem MID$(a$, 73, 5) = FFORMAT$(TblP6!(i), "#.###") PRINT #OUTHdl, a$ ELSEIF TblP5(i) > 0 AND TblP6!(i) > 99999. THEN a$ = SPACE$(80) MID$(a$, 1, 29) = TblP5N(i).SSItem MID$(a$, 31, 6) = LFORMAT$(TblP5(i), "######") PRINT #OUTHdl, a$ ELSEIF TblP5(i) > 0 AND TblP6!(i) < 99999. THEN a$ = SPACE$(80) MID$(a$, 1, 29) = TblP5N(i).SSItem MID$(a$, 31, 6) = LFORMAT$(TblP5(i), "######") MID$(a$, 41, 29) = TblP6N(i).SSItem MID$(a$, 73, 5) = FFORMAT$(TblP6!(i), "#.###") PRINT #OUTHdl, a$ END IF NEXT EscLeaders: LOOP 'End of File CLOSE #STBHdl CLOSE #STPHdl CLOSE #STFHdl CLOSE #OUTHdl QuickExit: OutFile$ = OutDevice$ COLOR deffor, defbac LOCATE 1, 1 EXIT SUB PrintDetail: IF BR.BABs <> 0 THEN PAvg! = BR.BHits / BR.BABs ELSE PAvg! = 0 'Expanded individual batting statistics TB = BR.BHits + BR.B2Bs + 2 * BR.B3Bs + 3 * BR.BHRs IF BR.BABs > 0 THEN Slug! = TB / BR.BABs ELSE Slug! = 0.0 END IF IF BR.BABs > 0 THEN HRPct! = BR.BHRs / BR.BABs * 100 ELSE HRPct! = 0.0 END IF IF BR.BABs > 0 THEN OnBase! = (BR.BBBs + BR.BHB + BR.BHits) / (BR.BBBs + BR.BHB + BR.BABs) ELSE OnBase! = 0.0 END IF Prod! = OnBase! + Slug! IF BR.BSBs <> 0 THEN Rate! = BR.BSBs / (BR.BSBs + BR.BCSs) * 100 ELSE Rate! = 0.0 END IF IF (BR.BCSs + BR.BABs - BR.BHits) > 0 THEN TotAvg! = (TB + BR.BSBs + BR.BBBs + BR.BHB) / (BR.BCSs + BR.BABs - BR.BHits) ELSE TotAvg! = 0.0 END IF rc27! = RunsCreated27!((BR.BABs), (BR.BHits), (BR.B2Bs), (BR.B3Bs), (BR.BHRs), (BR.BBBs), (BR.BHB), (BR.BSacB), (BR.BSacF), (BR.BSBs), (BR.BCSs), (BR.BGDP)) xS$ = LEFT$(BR.BNam, 15) i = INSTR(BR.BNam, ",") IF i > 0 THEN yS$ = MID$(BR.BNam, 1, i - 1) ELSE yS$ = xS$ IF PrtMain THEN 'old: ' Avg G AB Runs Hits TB 2B 3B HR RBI SH SF HB BB SO SB CS SB% GIDP ERR OB Slg HR OPS TAvg RC/27 ' \ X #.### #### #### #### ##### ##### #### ### #### #### #### #### ### ##### ##### #### ### ###.# #### #### #.### #.### ##.# #.### #.### ##.## \ \ 'new: ' Avg G AB Runs Hits TB 2B 3B HR RBI SH SF HB BB SO SB CS SB% GIDP ERR OB Slg HR OPS TAvg RC/27 ' #.### ###### ###### ###### ###### ###### ##### ##### ###### ###### ##### ##### ##### ###### ###### ##### ##### ###.# ##### ##### #.### #.### ##.# #.### #.### ##.## \ \" a$ = SPACE$(195) MID$(a$, 1, 15) = xS$ MID$(a$, 17, 1) = BR.BBats IF BR.BABs > 0 THEN MID$(a$, 19, 5) = FFORMAT$(PAvg!, "#.###") END IF MID$(a$, 25, 6) = LFORMAT$(BR.BGames, "######") MID$(a$, 32, 6) = LFORMAT$(BR.BABs, "######") MID$(a$, 39, 6) = LFORMAT$(BR.BRuns, "######") MID$(a$, 46, 6) = LFORMAT$(BR.BHits, "######") MID$(a$, 53, 6) = LFORMAT$(TB, "######") MID$(a$, 60, 5) = LFORMAT$(BR.B2Bs, "#####") MID$(a$, 66, 5) = LFORMAT$(BR.B3Bs, "#####") MID$(a$, 72, 6) = LFORMAT$(BR.BHRs, "######") MID$(a$, 79, 6) = LFORMAT$(BR.BRBIs, "######") MID$(a$, 86, 5) = LFORMAT$(BR.BSacB, "#####") MID$(a$, 92, 5) = LFORMAT$(BR.BSacF, "#####") MID$(a$, 98, 5) = LFORMAT$(BR.BHB, "#####") MID$(a$,104, 6) = LFORMAT$(BR.BBBs, "######") MID$(a$,111, 6) = LFORMAT$(BR.BKs, "######") MID$(a$,118, 5) = LFORMAT$(BR.BSBs, "#####") MID$(a$,124, 5) = LFORMAT$(BR.BCSs, "#####") MID$(a$,130, 5) = FFORMAT$(Rate!, "##0.#") MID$(a$,136, 5) = LFORMAT$(BR.BGDP, "#####") MID$(a$,142, 5) = LFORMAT$(BR.BERRs, "#####") MID$(a$,148, 5) = FFORMAT$(Onbase!, "#.###") MID$(a$,154, 5) = FFORMAT$(Slug!, "#.###") MID$(a$,160, 4) = FFORMAT$(HRPct!, "#0.#") MID$(a$,165, 5) = FFORMAT$(Prod!, "#.###") MID$(a$,171, 5) = FFORMAT$(TotAvg!, "#.###") MID$(a$,177, 5) = FFORMAT$(rc27!, "#0.##") MID$(a$,183, 12) = yS$ GOSUB StripNulls PRINT #OUTHdl, a$ IF RL THEN 'vs RHP a$ = SPACE$(170) IF BR.BABsRHP <> 0 THEN SAvg! = BR.BHitsRHP / BR.BABsRHP ELSE SAvg! = 0 MID$(a$, 1, 15) = " .vs RHP" IF SAvg! > 0 THEN MID$(a$, 19, 5) = FFORMAT$(SAvg!, "#.###") END IF MID$(a$, 32, 6) = LFORMAT$(BR.BABsRHP, "######") MID$(a$, 46, 6) = LFORMAT$(BR.BHitsRHP, "######") MID$(a$, 60, 5) = LFORMAT$(BR.B2BsRHP, "#####") MID$(a$, 66, 5) = LFORMAT$(BR.B3BsRHP, "#####") MID$(a$, 72, 6) = LFORMAT$(BR.BHRsRHP, "######") MID$(a$,104, 6) = LFORMAT$(BR.BBBsRHP, "######") MID$(a$,111, 6) = LFORMAT$(BR.BKsRHP, "######") 'Expanded individual batting statistics TB = BR.BHitsRHP + BR.B2BsRHP + 2 * BR.B3BsRHP + 3 * BR.BHRsRHP MID$(a$, 53, 6) = LFORMAT$(TB, "######") IF BR.BABsRHP > 0 THEN Slugx! = TB / BR.BABsRHP ELSE Slugx! = 0.0 END IF IF BR.BABsRHP > 0 THEN HRPctx! = BR.BHRsRHP / BR.BABsRHP * 100 ELSE HRPctx! = 0.0 END IF IF BR.BHB > 0 AND BR.BABs > 0 THEN BHBRHP = (BR.BABsRHP / BR.BABs) * BR.BHB ELSE BHBRHP = 0 END IF IF BR.BABs > 0 THEN OnBasex! = (BR.BBBsRHP + BHBRHP + BR.BHitsRHP) / _ (BR.BBBsRHP + BHBRHP + BR.BABsRHP) ELSE OnBasex! = 0.0 END IF MID$(a$,148, 5) = FFORMAT$(Onbasex!, "#.###") MID$(a$,154, 5) = FFORMAT$(Slugx!, "#.###") MID$(a$,160, 4) = FFORMAT$(HRPctx!, "#0.#") Prodx! = OnBasex! + Slugx! MID$(a$,165, 5) = FFORMAT$(Prodx!, "#.###") PRINT #OUTHdl, a$ 'vs LHP a$ = SPACE$(170) IF BR.BABsLHP <> 0 THEN SAvg! = BR.BHitsLHP / BR.BABsLHP ELSE SAvg! = 0 MID$(a$, 1, 15) = " .vs LHP" IF SAvg! > 0 THEN MID$(a$, 19, 5) = FFORMAT$(SAvg!, "#.###") END IF MID$(a$, 32, 6) = LFORMAT$(BR.BABsLHP, "######") MID$(a$, 46, 6) = LFORMAT$(BR.BHitsLHP, "######") MID$(a$, 60, 5) = LFORMAT$(BR.B2BsLHP, "#####") MID$(a$, 66, 5) = LFORMAT$(BR.B3BsLHP, "#####") MID$(a$, 72, 6) = LFORMAT$(BR.BHRsLHP, "######") MID$(a$,104, 6) = LFORMAT$(BR.BBBsLHP, "######") MID$(a$,111, 6) = LFORMAT$(BR.BKsLHP, "######") 'Expanded individual batting statistics TB = BR.BHitsLHP + BR.B2BsLHP + 2 * BR.B3BsLHP + 3 * BR.BHRsLHP MID$(a$, 53, 6) = LFORMAT$(TB, "######") IF BR.BABsLHP > 0 THEN Slugx! = TB / BR.BABsLHP ELSE Slugx! = 0.0 END IF IF BR.BABsLHP > 0 THEN HRPctx! = BR.BHRsLHP / BR.BABsLHP * 100 ELSE HRPctx! = 0.0 END IF IF BR.BHB > 0 AND BR.BABs > 0 THEN BHBLHP = (BR.BABsLHP / BR.BABs) * BR.BHB ELSE BHBLHP = 0 END IF IF BR.BABs > 0 THEN OnBasex! = (BR.BBBsLHP + BHBLHP + BR.BHitsLHP) / _ (BR.BBBsLHP + BHBLHP + BR.BABsLHP) ELSE OnBasex! = 0.0 END IF MID$(a$,148, 5) = FFORMAT$(Onbasex!, "#.###") MID$(a$,154, 5) = FFORMAT$(Slugx!, "#.###") MID$(a$,160, 4) = FFORMAT$(HRPctx!, "#0.#") Prodx! = OnBasex! + Slugx! MID$(a$,165, 5) = FFORMAT$(Prodx!, "#.###") PRINT #OUTHdl, a$ END IF END IF RETURN StripNulls: FOR ix = 1 TO LEN(a$) IF MID$(a$, ix, 1) = CHR$(0) THEN MID$(a$, ix, 1) = " " NEXT RETURN NewPage: PRINT #OUTHdl, PRINT #OUTHdl, PageNo = PageNo + 1 PRINT #OUTHdl, "SBS 4.9"; TAB(35); "Strategic Baseball Statistics" PRINT #OUTHdl, LineCtr = 3 RETURN SearchTable: i = 1 DO IF i > TblEnd THEN IF TblEnd < STATTEAMLIMIT THEN INCR TblEnd SA(TblEnd).ALeague = LeagueArg SA(TblEnd).ANam = NameArg ELSE PRINT " Team Limit Exceeded! " PauseIt END IF ndx = TblEnd EXIT DO END IF IF SA(i).ALeague = LeagueArg AND SA(i).ANam = NameArg THEN ndx = i EXIT DO END IF INCR i LOOP RETURN GetLeagueName: SELECT CASE UCASE$(SaveLeague$) CASE "A" LeagueName$ = "A.L." CASE "N" LeagueName$ = "N.L." CASE "F" LeagueName$ = "Federal" CASE ELSE LeagueName$ = SaveLeague$ END SELECT RETURN END SUB SUB StatRecordSetup (Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) CALL Drawfrm(2+rowO, 7+colO, 23+rowO, 73+colO, defattr, "Statistics Recording", "ESC (or close window) to Continue", 1, 0, 1) QPRINTs rowO+3,colO+22, "Specify Files to Save Statistical Data", defattr QPRINTs rowO+5,colO+9, "Note: These entries are all optional, but if you want to record ", dimattr QPRINTs rowO+6,colO+9, "basic statistics in order to generate a stat report, you must ", dimattr QPRINTs rowO+7,colO+9, "at least enter a filename for 'Statistics File'. To select an ", dimattr QPRINTs rowO+8,colO+9, "existing Statistics file press .", dimattr QPRINTs rowO+8,colO+40,"[F4]", defattr DATA 9,52," Clear", 0,0,0,"X " DATA 10,52,"Existing?",0,0,0,"X " DATA 11,15,"Statistics File: ",11,32,16,"X " DATA 0,00,"", 11,55,01,"XR" DATA 13,15,"Line Score File: ",13,32,18,"X " DATA 0,00,"", 13,55,01,"XR" DATA 15,15,"Box Score File: ",15,32,18,"X " DATA 0,00,"", 15,55,01,"XR" DATA 17,15,"Score Card File: ",17,32,18,"X " DATA 0,00,"", 17,55,01,"XR" DATA 19,15,"StarBox File: ",19,32,18,"X " DATA 0,00,"", 19,55,01,"XR" QPRINTs rowO+21, colO+9, "The STARBOX file contains box scores of outstanding individual ", dimattr QPRINTs rowO+22, colO+9, "performances. Leave fields BLANK where data is not desired. ", dimattr QPRINTs rowO+11, colO+49, "+", revattr QPRINTs rowO+11, colO+58, "Caution: ", dimattr QPRINTs rowO+12, colO+58, "[Y] will erase ", dimattr QPRINTs rowO+13, colO+58, "all data in ", dimattr QPRINTs rowO+14, colO+58, "specified file.", dimattr c = 1 FOR i = 1 TO 12 Flitrow(i) = VAL(READ$(c)) IF Flitrow(i) > 0 THEN Flitrow(i) = Flitrow(i) + rowO Flitcol(i) = VAL(READ$(c+1)) IF Flitcol(i) > 0 THEN Flitcol(i) = Flitcol(i) + colO Flit$(i) = READ$(c+2) Frow(i) = VAL(READ$(c+3)) IF Frow(i) > 0 THEN Frow(i) = Frow(i) + rowO Fcol(i) = VAL(READ$(c+4)) IF Fcol(i) > 0 THEN Fcol(i) = Fcol(i) + colO Flen(i) = VAL(READ$(c+5)) Fed$(i) = READ$(c+6) c = c + 7 NEXT Flds = 12 'Set Defaults REDIM FContents$(13) FContents$(3) = CmdStat$ 'May not be defined yet FContents$(4) = "N" FContents$(5) = CmdLinF$ FContents$(6) = "N" FContents$(7) = CmdBoxF$ FContents$(8) = "N" FContents$(9) = CmdScrF$ FContents$(10) = "N" FContents$(11) = CmdStar$ FContents$(12) = "N" END SUB SUB StatRecordIO (RetKey, Flds, CursorPtr, Plen(), Prow(), Pcol(), Ped$(), Plit$(), Plitrow(), Plitcol(), PContents$()) DO StatRecordLoop: CustomEscKey = -62 'F4 TakeFromAnywhere = 2 CALL ScreenIO(Keyed, KeyF3, CustomEscKey, KeyEsc, Flds, CursorPtr, Plen(), Prow(), Pcol(), Ped$(), Plit$(), Plitrow(), Plitcol(), PContents$()) TakeFromAnywhere = 0 IF Keyed = KeyF3 THEN RetKey = Keyed EXIT SUB END IF IF Keyed = CustomEscKey THEN 'F4 - Browse/Select .STS files CALL GetScreen(Scr3$, 3+rowO, 62+colO, 21+rowO, 76+colO) FileLimit = 500 REDIM List1(1 TO FileLimit) AS List1Type x$ = MenuOpt$ MenuOpt$ = "1" Fil$ = CmdWritePath$ + "*.STS" CALL PickAFile (Fil$, FileLimit, List1(), RetKey, Pick, mous, 0) MenuOpt$ = x$ IF Pick > 0 THEN x$ = RTRIM$(List1(Pick).ListItem) L = LEN(x$) PContents$(3) = LEFT$(x$, L - 4) END IF ERASE List1 CALL PutScreen(Scr3$, 3+rowO, 62+colO, 21+rowO, 76+colO) GOTO StatRecordLoop END IF ' Edit Field Contents Error1$ = "N" i = 4 DO IF PContents$(i) <> "Y" AND PContents$(i) <> "N" THEN Error1$ = "Y": CursorPtr = i: CALL MyBeep: GOTO StatRecordLoop END IF i = i + 2 LOOP UNTIL i > 12 IF PContents$(3) > "!" THEN IF PContents$(3) = PContents$(5) OR PContents$(3) = PContents$(7) OR PContents$(3) = PContents$(9) OR PContents$(3) = PContents$(11) THEN CALL PopMsg(18+rowO, 26+colO, " File names must be different! ", errattr, 2, kc) Error1$ = "Y" CursorPtr = 3 GOTO StatRecordLoop END IF END IF IF PContents$(7) > "!" AND LEFT$(PContents$(7), 3) <> "LPT" THEN IF PContents$(7) = PContents$(9) THEN CALL PopMsg(18+rowO, 26+colO, " File names must be different! ", errattr, 2, kc) Error1$ = "Y" CursorPtr = 8 GOTO StatRecordLoop END IF END IF IF PContents$(3) > "!" THEN zS$ = CmdWritePath$ + RTRIM$(PContents$(3)) + ".RES" IF CmdSCH$ > "!" THEN IF LEN(DIR$(zS$)) THEN OPEN zS$ FOR RANDOM AS #5 LEN = LEN(RestartRec) GET #5, 1, RestartRec CLOSE #5 IF UCASE$(RTRIM$(RestartRec.ResSCHName)) <> UCASE$(RTRIM$(CmdSCH$)) THEN QPush CALL Drawfrm(9, 14, 22, 64, linattr, "*** ERROR ***", nulls$, 0, 0, 0) QPRINTs 10, 16, " SBS believes this Stat File is currently ", errattr QPRINTs 11, 16, " being used by another Schedule file. ", errattr QPRINTs 13, 16, " Selected SCH Name: " + RTRIM$(CmdSCH$), errattr QPRINTs 14, 16, " Restart File : " + zS$, errattr QPRINTs 15, 16, " Restart SCH Name : " + RTRIM$(RestartRec.ResSCHName), errattr QPRINTs 16, 16, " Restart Date : " + RestartRec.ResSCHDate, errattr QPRINTs 17, 16, " Restart Slot : " + STR$(RestartRec.ResSCHSlotPtr), errattr QPRINTs 18, 16, " Slot Game : " + STR$(RestartRec.ResSlotGameCtr), errattr QPRINTs 19, 16, " of : " + STR$(RestartRec.ResSlotGames), errattr QPRINTs 20, 16, " Restart Sch Game : " + STR$(RestartRec.ResSimGameCtr), errattr QPRINTs 21, 16, " (The SCH names must match)", errattr PauseIt QPop Error1$ = "Y" CursorPtr = 3 GOTO StatRecordLoop END IF END IF ELSE 'NOT in SCH mode IF LEN(DIR$(zS$)) THEN 'but a .RES exists QPush CALL Drawfrm(9, 14, 14, 64, linattr, "*** WARNING ***", nulls$, 0, 0, 0) QPRINTs 10, 16, " SBS believes this Stat File may be currently ", errattr QPRINTs 11, 16, " in use by a Schedule file. ", errattr QPRINTs 12, 16, " Do you want to use it anyway? [y/N]:", errattr LOCATE 12, 54 xS$ = YESorNO$(revfor, revbac, deffor, defbac, "N") QPop IF xS$ <> "Y" THEN Error1$ = "Y" CursorPtr = 3 GOTO StatRecordLoop END IF END IF END IF END IF LOOP WHILE Error1$ = "Y" IF PContents$(3) > "!" THEN CmdStat$ = PContents$(3) i = INSTR(CmdStat$, ".") IF i > 0 THEN CmdStat$ = LEFT$(CmdStat$, i - 1) ELSE CmdStat$ = RTRIM$(CmdStat$) CmdStat$ = TRUNCFILENAME$(CmdStat$) IF PContents$(4) = "Y" THEN xS$ = CmdStat$ + ".STS" GOSUB SIOchkkill xS$ = CmdStat$ + ".STB" GOSUB SIOchkkill xS$ = CmdStat$ + ".STP" GOSUB SIOchkkill xS$ = CmdStat$ + ".STF" GOSUB SIOchkkill xS$ = CmdStat$ + ".STH" GOSUB SIOchkkill xS$ = CmdStat$ + ".RES" GOSUB SIOchkkill xS$ = CmdStat$ + ".ROT" GOSUB SIOchkkill xS$ = CmdStat$ + ".STD" GOSUB SIOchkkill END IF ELSE CmdStat$ = nulls$ END IF IF PContents$(5) > "!" THEN CmdLinF$ = RTRIM$(PContents$(5)) IF LEFT$(CmdLinF$, 3) <> "LPT" THEN IF LEN(DIR$(CmdWritePath$ + CmdLinF$)) THEN IF PContents$(6) = "Y" THEN KILL CmdWritePath$ + CmdLinF$ END IF END IF ELSE CmdLinF$ = nulls$ END IF IF PContents$(7) > "!" THEN CmdBoxF$ = RTRIM$(PContents$(7)) IF LEFT$(CmdBoxF$, 3) <> "LPT" THEN IF LEN(DIR$(CmdWritePath$ + CmdBoxF$)) THEN IF PContents$(8) = "Y" THEN KILL CmdWritePath$ + CmdBoxF$ END IF END IF ELSE CmdBoxF$ = nulls$ END IF IF PContents$(9) > "!" THEN CmdScrF$ = RTRIM$(PContents$(9)) IF LEFT$(CmdScrF$, 3) <> "LPT" THEN IF LEN(DIR$(CmdWritePath$ + CmdScrF$)) THEN IF PContents$(10) = "Y" THEN KILL CmdWritePath$ + CmdScrF$ END IF END IF ELSE CmdScrF$ = nulls$ END IF IF PContents$(11) > "!" THEN CmdStar$ = RTRIM$(PContents$(11)) IF LEFT$(CmdStar$, 3) <> "LPT" THEN IF LEN(DIR$(CmdWritePath$ + CmdStar$)) THEN IF PContents$(12) = "Y" THEN KILL CmdWritePath$ + CmdStar$ END IF END IF ELSE CmdStar$ = nulls$ END IF RetKey = Keyed EXIT SUB SIOchkkill: IF LEN(DIR$(CmdWritePath$ + xS$)) THEN KILL CmdWritePath$ + xS$ RETURN END SUB SUB STEALRoutine ON ERROR GOTO ERRORTRAP IF ir1 = 0 AND ir2 = 0 AND ir3 = 0 THEN CALL PopMsg(18+rowO, 26+colO, " There are no baserunners! ", errattr, 2, 0) GOTO 17900 END IF DoubleSteal = FALSE J1 = 0 J2 = 0 xF! = RND 'Who is the lead runner? IF ir3 THEN 'runner on third yF! = DataSpeed(ir3, it) / 10 IF POut THEN yF! = yF! * .50 'Cut chances (speed) by 50% if pitch-out GOTO 17500 END IF 'No runner on third IF ir2 = 0 THEN 'Only runner is on first IL = ir1 J1 = 1 ELSE 'Runner on 2nd (maybe 1st too) IL = ir2 J2 = 1 END IF 'Steal or H&Run IF HitAndRun THEN t$ = "02" ELSE t$ = "01" IF DelFac THEN CALL Msg ("25", "0", "0", t$, IL, it, man2, team2) 'Runners on 1st or 2nd or both; (and nobody on third) 17020 : IF ir1 AND ir2 THEN IF amgr(it) = 0 THEN 'Player is calling the shots x$ = " Attempt double steal? [y/N]" CALL PopMsg(10+rowO, 30+colO, x$, errattr, 0, kc) IF UCASE$(CHR$(kc)) = "Y" THEN DoubleSteal = TRUE ELSE 'Computer is in control IF RND < .75 THEN DoubleSteal = TRUE END IF END IF 'Calculate probability of being safe 'Examine CS column IF StBSw(it) <> 0 THEN 'Header indicates SB as opposed to Speed-Rating s = 0 'Sum CS for non-pitchers FOR i = 1 TO 9 IF DataPos(i, it) > 1 THEN s = s + DataCS(i, it) END IF NEXT END IF 'Using old "speed rating" IF StBSw(it) = 0 THEN yF! = DataSpeed(IL, it) / 10 ELSE 'Calculate raw success rate (yF!) IF s = 0 THEN n = DataSB(IL, it) * 0.27 '.40 ELSE n = DataCS(IL, it) END IF 'We have SB and CS data IF DataSB(IL, it) + n > 10 THEN 'Plenty of data yF! = DataSB(IL, it) / (DataSB(IL, it) + n) ELSEIF DataSB(IL, it) + n > 0 THEN 'Limited data yF! = DataSB(IL, it) / (DataSB(IL, it) + n) 'set limits for low-data situations IF yF! < .2 THEN yF! = .2 IF yF! > .7 THEN yF! = .7 IF DataPos(IL, it) = 1 THEN yF! = .6 ELSE 'No data yF! = .6 END IF END IF 'Cut success rate for pitchouts and lefties Adj! = 1.0 'No Pitchout IF POut = FALSE THEN INCR zzzNoPO IF J1 = 1 THEN 'Lead runner is on 1st IF UCASE$(DataHand(ip, id)) = "L" THEN Adj! = Adj! - .16 ELSE Adj! = Adj! + .02 END IF ELSE 'Lead runner is on 2nd IF UCASE$(DataHand(ip, id)) = "R" THEN Adj! = Adj! - .16 ELSE Adj! = Adj! + .02 END IF END IF ELSE 'Pitchout ' 4.7 ' yF! Succ w/PO Cut '.50 .16 68 '.60 .22 63 '.70 .32 54 '.80 .46 43 '.90 .70 22 '.99 .90 9 IF yF! < .50 THEN Adj! = Adj! - .68 ELSE zF! = .567 - (1.987 * yF!) + (2.340 * yF! * yF!) 'Success rate w/PO cutit! = 1 - (zF! / yF!) Adj! = Adj! - cutit! END IF IF yF! < .40 THEN INCR zz0 ELSEIF yF! < .5 THEN INCR zz1 ELSEIF yF! < .6 THEN INCR zz2 ELSEIF yF! < .7 THEN INCR zz3 ELSEIF yF! < .8 THEN INCR zz4 ELSEIF yF! < .9 THEN INCR zz5 ELSE INCR zz6 END IF INCR zzzPO END IF yF! = yF! * Adj! IF yF! < .02 THEN yF! = .02 IF yF! > .98 THEN yF! = .98 wag = WHOATGUY(2) IF DelFac THEN CALL Msg ("25", "0", "0", "07", wag, id, man2, team2) '*'s throw IF xF! < yF! THEN 'Safe! IF DataPos(IL, it) = 1 THEN INCR zzssbp IF DelFac THEN CALL Msg ("25", "0", "0", "03", IL, it, man2, team2) 'in there CALL Msg ("25", "0", "0", "04", IL, it, man2, team2) 'SB! END IF 'Credit Lead Runner with Stolen Base GOSUB CreditSB IF ir2 AND DoubleSteal = FALSE THEN CALL Advanc(0, 1, 0) ELSE CALL Advanc(1, 1, 0) END IF CALL AddToScoreCrd(it, DataRef(IL, it), "6", "SB") IF ITrail THEN CALL AddToScoreCrd(it, DataRef(ITrail, it), "6", "SB") zzzsb = zzzsb + 1 ELSE 'Out! or Catcher throws it away! f! = 4.7 - (TeamSpeed(it) / 2.) IF f! < 2. THEN f! = 2. defp! = DEFPCT!(wag) zF! = 1.0 - (f! * (1.0 - defp!)) IF zF! < .7 THEN zF! = .7 IF RND > zF! THEN 'Catcher throwing error INCR iterrs(id) INCR inne INCR innadverr i = DataRef(wag, id) INCR GpPos(i, id, 2) INCR merr(i, id) INCR SumErrors(2) IF DelFac THEN CALL Msg ("30", "0", "0", "02", 0, id, man2, team2) 'W.Throw CALL Msg ("30", "0", "0", "09", wag, id, man2, team2) 'E-2 END IF 'Credit Runner with Stolen base GOSUB CreditSB Errorx = TRUE CALL Advanc(2, 2, 1) 'Everybody advances Errorx = FALSE CALL AddToScoreCrd(it, DataRef(IL, it), "6", "SB/E-2") IF ITrail THEN CALL AddToScoreCrd(it, DataRef(ITrail, it), "6", "SB") zzzcer = zzzcer + 1 ELSE 'Out! IF DelFac THEN CALL Msg ("25", "0", "0", "05", IL, it, man2, team2) 'OUT INCR mcs(DataRef(IL, it), it) IF DelFac THEN CALL Msg ("25", "0", "0", "06", wag, id, man2, team2) 'Nails him IF J2 = 1 THEN ir2 = 0 IF J1 = 1 THEN ir1 = 0 ir2 = ir1 ir1 = 0 INCR Assists(DataRef(WHOATGUY(2), id), id, 2) IF J2 = 1 THEN 'out at 3rd Oat$ = "3" n = 5 ELSE 'out at 2nd Oat$ = "2" IF DataHand(ib, it) = "R" THEN n = 4 ELSE n = 6 END IF INCR PutOuts(DataRef(WHOATGUY(n), id), id, n) INCR iout INCR mpo(ip, id) CALL AddToScoreCrd(it, DataRef(IL, it), Oat$, "CS 2-" + LTRIM$(STR$(n)) ) fr7 = 90 'signals runner thrown out zzzcs = zzzcs + 1 END IF END IF GOTO 17900 'Trying to steal home - OR - 1st & 3rd and trying to steal 2nd 17500 : IF ir2 = 0 AND ir1 <> 0 THEN '1st & 3rd DoubleSteal = FALSE IF amgr(it) = 0 THEN 'Player is calling the shots x$ = " Attempt double steal? [y/N]" CALL PopMsg(10+rowO, 30+colO, x$, errattr, 0, kc) IF UCASE$(CHR$(kc)) = "Y" THEN DoubleSteal = TRUE ELSE 'Computer is in control IF RND < .10 THEN DoubleSteal = TRUE END IF IF NOT DoubleSteal THEN 'Just trying to steal 2nd IL = ir1: J1 = 1 IF DelFac THEN 'There goes *! CALL Msg ("25", "0", "0", "08", ir1, it, man2, team2) END IF GOTO 17020 ELSE 'Double Steal wF! = .28 END IF ELSE 'Lone runner on 3rd or bases-loaded wF! = .48 END IF IF DelFac THEN AddToAnnouncer it, "The 'Steal' is on!!" CALL Msg ("24", "0", "0", "10", ir3, it, man2, team2) 'here he comes END IF 'Runner on 3rd (maybe 1st and/or 2nd too) trying to steal home ' xF! is a RND ' wF! is either .28 or .48 ' yF! is Speed / 10 of guy on third IF (xF! + wF!) < yF! THEN 'Safe (not too often) '4:0% 5: 2% 6:12% 7:22% 8:32% 9:42% 'for wF! = .48 (naked steal of home) '4:12% 5:22% 6:32% 7:42% 8:52% 9:62% 'for wF! = .28 (double steal) 'Safe at home! IF DelFac THEN CALL Msg ("15", "0", "0", "04", ir3, it, man2, team2) 'safe AddToAnnouncer it, "He stole home!!!" CALL Msg ("40", "0", "0", "00", 0, it, man2, team2) '!!! END IF 'Credit guy who's about to score with SB IL = ir3 INCR msb(DataRef(ir3, it), it) DPsw = TRUE 'to fool Advanc into not awarding an RBI CALL Advanc(1, 1, 1) DPsw = FALSE CALL AddToScoreCrd(it, DataRef(IL, it), "6", "SB") 'to zero out score reference on additional score card lines: RunsBeforePlay = itruns(it) 'Credit guy now on third with a SB IF ir3 THEN INCR msb(DataRef(ir3, it), it) CALL AddToScoreCrd(it, DataRef(ir3, it), "6", "SB") END IF 'Credit guy now on second with a SB IF ir2 THEN INCR msb(DataRef(ir2, it), it) CALL AddToScoreCrd(it, DataRef(ir2, it), "6", "SB") END IF ELSE 'Out at home INCR mcs(DataRef(ir3, it), it) IF DelFac THEN CALL Msg ("14", "0", "0", "04", ir3, it, man2, team2) 'OUT CALL Msg ("40", "0", "0", "00", 0, it, man2, team2) '!!! END IF IL = ir3 ir3 = ir2 ir2 = ir1 ir1 = 0 IF ir2 THEN INCR msb(DataRef(ir2, it), it) IF ir3 THEN INCR msb(DataRef(ir3, it), it) INCR PutOuts(DataRef(WHOATGUY(2), id), id, 2) IF DataHand(ib, it) = "R" THEN n = 4 ELSE n = 6 INCR Assists(DataRef(WHOATGUY(n), id), id, n) INCR iout INCR mpo(ip, id) fr7 = 90 'signals runner thrown out ' CALL AddToScoreCrd(it, DataRef(IL, it), "1", "X-CS") CALL AddToScoreCrd(it, DataRef(IL, it), "4", "CS " + LTRIM$(STR$(n)) + "-2") END IF 17900 : 'Reset batter pointer and ABs CALL ResetBatter EXIT SUB CreditSB: 'Credit lead runner with Stolen Base 'We have not called ADVANC yet INCR msb(DataRef(IL, it), it) 'Credit trailing runner with SB also ITrail = 0 IF IL = ir2 THEN IF ir1 AND DoubleSteal THEN INCR msb(DataRef(ir1, it), it) ITrail = ir1 END IF END IF RETURN ErrorTrap: LOCATE 10, 30 PRINT "STEAL_Error"; ERRCLEAR x$ = WAITKEY$ END SUB SUB StrikeOutRoutine INCR iout INCR mso(ref, it) 'credit hitter IF UCASE$(DataHand(ip, id)) = "L" THEN INCR msoLHP(ref, it) ELSE INCR msoRHP(ref, it) END IF INCR mpo(ip, id) 'credit pitcher INCR mpk(ip, id) ' " " " " " INCR PutOuts(DataRef(WHOATGUY(2), id), id, 2) 'give catcher a PutOut 'Struck him out! IF DelFac THEN IF HitAndRun THEN AddtoAnnouncer it, "Swing and a miss!" AddtoAnnouncer it, "Struck him out!" CALL WavWhiff ELSE t$ = PADZEROS$( LTRIM$(STR$(RND(1, 2))) , 2) CALL Msg ("19", "0", "1", t$, ib, it, man2, team2) CALL Msg ("19", "0", "2", t$, ib, it, man2, team2) IF t$ = "01" THEN CALL WavWhiff ELSE CALL WavPopMitt END IF END IF Result$ = "K" ' ' DTS - Dropped Third Strike ' 'Not sure about the rule IF ir1 = 0 AND ir2 = 0 AND ir3 = 0 THEN 'nobody on 'Wild Pitch or Passed Ball on third strike? pbal = 0 wpit = 0 xF! = RND yF! = DataBB(ip,id) / BattersFacedByPit! (DataAB(ip,id), DataHits(ip,id), DataBB(ip,id), DataSO(ip,id)) wp! = .017 * (yF! / pwbaseF(id)) / 9 IF xF! < wp! THEN WildPit(id) = WildPit(id) + PADZEROS$(LTRIM$(STR$(ip)), 2) Result$ = Result$ + "-DTS WP" wpit = -1 ELSE nn = WHOATGUY(2) defperF! = DEFPCT!(nn) zF! = (1.0 - defperF!) * .03 IF xF! < wp! + zF! THEN PassedB(id) = PassedB(id) + PADZEROS$(LTRIM$(STR$(DataRef(nn, id))), 2) Result$ = Result$ + "-DTS PB" pbal = -1 ELSE EXIT SUB END IF END IF 'Back out of some of the stats DECR iout DECR mpo(ip, id) DECR PutOuts(DataRef(WHOATGUY(2), id), id, 2) 'Announcer IF DelFac THEN AddToAnnouncer id, "The ball gets away!" AddToAnnouncer it, "And the batter is going to be safe at first!" IF wpit THEN AddToAnnouncer id, "Score that one a 'wild pitch'" IF pbal THEN AddToAnnouncer id, "Score that one a 'passed ball'" END IF 'Put Batter on ir1 = ib mpp(ib) = ip mpp(ib) = -mpp(ib) END IF END SUB SUB Switch (p1, p2, team) IF p1 < 1 OR p1 > MAXPLAYERS THEN x$ = "Bad call to player switch: P1=" + STR$(p1) CALL ErrorBox (x$) GOTO SwEsc END IF IF p2 < 1 OR p2 > MAXPLAYERS THEN x$ = "Bad call to player switch: P2=" + STR$(p2) CALL ErrorBox (x$) GOTO SwEsc END IF IF team < 1 OR team > 2 THEN x$ = "Bad call to player switch: team=" + STR$(team) CALL ErrorBox (x$) GOTO SwEsc END IF SWAP iused(p1, team), iused(p2, team) SWAP DataName(p1, team), DataName(p2, team) SWAP DataPlat(p1, team), DataPlat(p2, team) SWAP DataHand(p1, team), DataHand(p2, team) SWAP DataCode(p1, team), DataCode(p2, team) SWAP DataRef(p1, team), DataRef(p2, team) SWAP DataPos(p1, team), DataPos(p2, team) SWAP DataAB(p1, team), DataAB(p2, team) SWAP DataHits(p1, team), DataHits(p2, team) SWAP Data2B(p1, team), Data2B(p2, team) SWAP Data3B(p1, team), Data3B(p2, team) SWAP DataHR(p1, team), DataHR(p2, team) SWAP DataBB(p1, team), DataBB(p2, team) SWAP DataHP(p1, team), DataHP(p2, team) SWAP DataSO(p1, team), DataSO(p2, team) SWAP DataRBI(p1, team), DataRBI(p2, team) SWAP DataDef(p1, team), DataDef(p2, team) SWAP DataSB(p1, team), DataSB(p2, team) SWAP DataCS(p1, team), DataCS(p2, team) SWAP DataGames(p1, team), DataGames(p2, team) FOR i = 1 TO 4 SWAP DataPosi(p1, team, i), DataPosi(p2, team, i) SWAP DataGByP(p1, team, i), DataGByP(p2, team, i) NEXT SWAP DataSpeed(p1, team), DataSpeed(p2, team) 'SWAP DataPBatAB(p1, team), DataPBatAB(p2, team) 'SWAP DataPBatHi(p1, team), DataPBatHi(p2, team) 'SWAP DataPBatHR(p1, team), DataPBatHR(p2, team) 'SWAP DataPBatBB(p1, team), DataPBatBB(p2, team) 'SWAP DataPBatSO(p1, team), DataPBatSO(p2, team) SwEsc: END SUB SUB SwitchToDH (tm) FOR i = 1 TO 9 IF DataPos(i, tm) = 10 AND DataName(i, tm) > "A" THEN EXIT SUB NEXT ' Create a hole for the DH and bring 1st player on bench into it CALL Switch(8, 9, tm) CALL Switch(7, 8, tm) CALL Switch(6, 7, tm) CALL Switch(5, 6, tm) 'Normally the pitcher will now be in slot 5, but that is not the case if 'in the .DAT file he bats something other than 9 'So, find the pitcher: ps = 0 FOR i = 1 TO 9 IF DataPos(i, tm) = 1 THEN ps = i : EXIT FOR NEXT IF ps > 0 THEN CALL Switch(ps, LastPiAd(tm) + 1, tm) DataPos(ps, tm) = 10 ELSE x$ = "No Pitcher Found in .DAT" CALL ErrorBox (x$) END IF 'Rotate the garbage in slot LastPiAd + 1 down to slot MAXPLAYERS i = LastPiAd(tm) + 1 DO CALL Switch(i, i + 1, tm) INCR i LOOP UNTIL i > MAXPLAYERS - 1 DataPos(MAXPLAYERS, tm) = 0 DataName(MAXPLAYERS, tm) = SPACE$(18) FOR i = 1 TO 4 DataPosi(MAXPLAYERS, tm, i) = 0 DataGByP(MAXPLAYERS, tm, i) = 0 NEXT END SUB SUB SwitchToNoDH (tm) 'Look for DH already in lineup s = 0 PitSlot = 0 FOR i = 1 TO 9 IF DataPos(i, tm) = 10 AND DataName(i, tm) > "A" THEN s = i IF DataPos(i, tm) = 1 THEN PitSlot = i NEXT IF s = 0 THEN IF PitSlot = 0 THEN PitSlot = 9 GOTO SwitchToNoDHX END IF ' DH is in slot "s" -- get rid of it ' we assume no pitcher is in the lineup ' Push down bench - clear spot in LastPiAd + 1 i = MAXPLAYERS DO CALL Switch(i - 1, i, tm) DECR i LOOP UNTIL i = LastPiAd(tm) + 1 ' Put former DH on the bench, position left field CALL Switch(s, LastPiAd(tm) + 1, tm) DataPos(LastPiAd(tm) + 1, tm) = 7 ' Collapse starting lineup around where DH used to be i = s DO UNTIL i > 8 CALL Switch(i + 1, i, tm) INCR i LOOP PitSlot = 9 SwitchToNoDHX: ' Move Pitcher's hitting stats to PitSlot CALL MovePitHitStats (PitSlot, tm) END SUB SUB ThrowOutCheck (B1, B2, ThrowOutChance1, ThrowOutChance2, ThrowToThird, ConcedeRun) STATIC ON ERROR GOTO ERRORTRAP 'Possibly throw out a baserunner: 'In: B1, B2 [number of bases to attempt to advance for 1st & 2nd, resp.] 'call this routine BEFORE Advanc 'We can't handle 2 people being thrown out on the same play, so as soon 'as someone gets nailed, return. IF HitAndRun THEN xF! = .999 ELSE xF! = RND IF HitType = 1 THEN 'Nobody gets thrown out if winning run will score from third IF inn >= RegInns AND it = 2 THEN IF ir3 > 0 THEN IF itruns(2) + 1 > itruns(1) THEN EXIT SUB END IF END IF END IF IF ir2 > 0 THEN IF B2 = 2 THEN 'On a single can R/2nd score? IF DelFac THEN IF ThrowToThird THEN ' * scores as the throw goes to third... CALL Msg ("31", "0", "0", "12", ir2, it, man2, team2) ELSE IF ConcedeRun = TRUE THEN '* will score without a throw... CALL Msg ("31", "0", "0", "15", ir2, it, man2, team2) ELSE 'Rounds third and heads for home... CALL Msg ("31", "0", "0", "01", ir2, it, man2, team2) AddToAnnouncer it, "He is...." END IF END IF END IF yF! = ThrowOutChance1 / 100.0 IF xF! < yF! THEN INCR mpo(ip, id) IF DelFac THEN CALL Msg ("14", "0", "0", "07", ir2, it, man2, team2) 'OUT ref2 = DataRef(ir2, it) ' "X-@Home" Result2$ = LTRIM$(STR$(WhoAtPos)) + "-2" Code2$ = "4" INCR Assists(DataRef(WHOATGUY(WhoAtPos), id), id, WhoAtPos) INCR PutOuts(DataRef(WHOATGUY(2), id), id, 2) ir2 = 0 EXIT SUB ELSE IF DelFac THEN IF ThrowToThird = FALSE AND ConcedeRun = FALSE THEN CALL Msg ("15", "0", "0", "09", ir2, it, man2, team2) 'SAFE END IF RunAnnounced = TRUE END IF ELSE 'slams on the brakes at third..." IF DelFac THEN CALL Msg ("16", "0", "0", "03", ir2, it, man2, team2) EXIT SUB END IF END IF IF ir1 > 0 THEN IF B1 = 2 THEN 'On a single can R/1st goto 3rd? '* heads for third IF DelFac THEN CALL Msg ("31", "0", "0", "02", ir1, it, man2, team2) yF! = ThrowOutChance2 / 100.0 IF xF! < yF! + .15 THEN IF DelFac THEN 'They've got a shot at him... CALL Msg ("31", "0", "0", "13", ir1, it, man2, team2) AddToAnnouncer it, "He is..." END IF END IF IF xF! < yF! THEN INCR mpo(ip, id) IF DelFac THEN CALL Msg ("14", "0", "0", "03", ir1, it, man2, team2) 'OUT ref2 = DataRef(ir1, it) ' Result2$ = "X-@3rd" Result2$ = LTRIM$(STR$(WhoAtPos)) + "-5" Code2$ = "3" INCR Assists(DataRef(WHOATGUY(WhoAtPos), id), id, WhoAtPos) INCR PutOuts(DataRef(WHOATGUY(5), id), id, 5) ir1 = 0 EXIT SUB ELSE IF ANx > 2 THEN t$ = "09" ELSE t$ = "06" IF DelFac THEN CALL Msg ("15", "0", "0", t$, ir1, it, man2, team2) 'SAFE 'He's in there... 'error possibility: END IF ELSE '* stops at 2nd IF DelFac THEN CALL Msg ("16", "0", "0", "02", ir1, it, man2, team2) 'HOLD END IF END IF END IF IF HitType = 2 AND ir1 > 0 THEN 'Nobody gets thrown out if winning run will score from 2nd or 3rd IF inn >= RegInns AND it = 2 THEN LeadRunners = 0 IF ir3 > 0 THEN INCR LeadRunners IF ir2 > 0 THEN INCR LeadRunners IF itruns(2) + LeadRunners > itruns(1) THEN EXIT SUB END IF END IF IF B1 = 3 THEN 'taking 3 bases on a double '* rounds third IF DelFac THEN CALL Msg ("31", "0", "0", "01", ir1, it, man2, team2) AddToAnnouncer it, "He is...." END IF yF! = ThrowOutChance1 / 100.0 IF xF! < yF! THEN INCR mpo(ip, id) 'OUT at the plate! IF DelFac THEN CALL Msg ("14", "0", "0", "07", ir1, it, man2, team2) 'OUT ref2 = DataRef(ir1, it) ' Result2$ = "X-@Home" Result2$ = LTRIM$(STR$(WhoAtPos)) + "-2" Code2$ = "4" INCR Assists(DataRef(WHOATGUY(WhoAtPos), id), id, WhoAtPos) INCR PutOuts(DataRef(WHOATGUY(2), id), id, 2) ir1 = 0 ELSE IF DelFac THEN 'SAFE AddToAnnouncer it, "SAFE!" RunAnnounced = TRUE END IF END IF ELSE '* holds on at third IF DelFac THEN CALL Msg ("16", "0", "0", "03", ir1, it, man2, team2) 'HOLD END IF END IF EXIT SUB ErrorTrap: LOCATE 10, 30 PRINT "THROWOUT_Error"; ERRCLEAR x$ = WAITKEY$ END SUB SUB TripleDialog (wag) x! = RND IF WhoAtPos = 8 THEN i = RND(1, 3) ELSEIF WhoAtPos = 7 THEN IF x! < .33 THEN i = 1 ELSEIF x! < .67 THEN i = 3 ELSE i = 4 END IF ELSE '9 IF x! < .33 THEN i = 1 ELSEIF x! < .67 THEN i = 2 ELSE i = 4 END IF END IF t$ = LTRIM$(STR$(i)) t$ = PADZEROS$(t$, 2) CALL Msg ("10", "0", "1", t$, 0, it, man2, team2) 'long drive IF t$ <> "04" THEN m = wag: n = id ELSE m = ib: n = it CALL Msg ("10", "0", "2", t$, m, n, man2, team2) '* going back IF t$ = "01" THEN m = wag: n = id ELSE m = ib: n = it CALL Msg ("10", "0", "3", t$, m, n, man2, team2) 'over his head IF ir3 > 0 THEN CALL AnnScoring(ir3) IF ir2 > 0 THEN CALL AnnScoring(ir2) IF ir1 > 0 THEN CALL AnnScoring(ir1) END SUB SUB TripleRoutine ppF! = FindPP! WhoAtPos = OUTFIELDWHOAT (ppF!) wag = WHOATGUY (WhoAtPos) IF DelFac THEN CALL TripleDialog (wag) CALL Advanc(3, 2, 1) IF DelFac THEN IF SoundOn THEN CALL WavRegularHit CALL Msg ("10", "0", "4", "00", ib, it, man2, team2) 'he's not stopping CALL Msg ("10", "0", "5", "00", ib, it, man2, team2) 'triple END IF ir3 = ib mpp(ib) = ip CALL CreditHit INCR m3b(ref, it) IF UCASE$(DataHand(ip, id)) = "L" THEN INCR m3bLHP(ref, it) ELSE INCR m3bRHP(ref, it) END IF INCR mp3b(ip, id) Result$ = "3B" END SUB SUB TwoTeamSetup (row, Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) CALL Drawfrm(row+rowO, 12+colO, row+rowO+16, 69+colO, defattr, "Simulation Options", "ESC (or close window) to continue", 1, 0, 1) COLOR 7, defbac DATA 02,14,"How many games do you want to simulate?",02,54,6,"N " DATA 04,14,"Auto-Lineup (Visitor) [y/N] ",04,53,01,"XR" DATA 06,14," (Home) [y/N] ",06,53,01,"XR" DATA 08,14,"Adjust Batting Order (Visitor) [y/N/c] ",08,53,01,"XR" DATA 10,14," (Home) [y/N/c] ",10,53,01,"XR" DATA 12,14,"Use Designated-Hitter? [Y/N] ",12,53,01,"XR" DATA 14,14,"Use Spot Starters? [y/N] ",14,53,01,"XR" Flds = 7 c = 1 FOR i = 1 TO Flds Flitrow(i) = VAL(READ$(c)) + row + rowO Flitcol(i) = VAL(READ$(c+1)) + colO Flit$(i) = READ$(c+2) Frow(i) = VAL(READ$(c+3)) + row + rowO Fcol(i) = VAL(READ$(c+4)) + colO Flen(i) = VAL(READ$(c+5)) Fed$(i) = READ$(c+6) c = c + 7 NEXT 'Set Defaults REDIM FContents$(13) FContents$(2) = "N" FContents$(3) = "N" FContents$(4) = "N" FContents$(5) = "N" FContents$(6) = DefaultDHResponse$ FContents$(7) = "N" END SUB SUB TwoTeamIO (RetKey, Flds, CursorPtr, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) DO TopOfTTLoop: CALL ScreenIO(Keyed, KeyEsc, 0, KeyEsc, Flds, CursorPtr, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$()) 'Edit Field Contents Error1$ = "N" i = 1 DO IF i = 1 THEN n = VAL(FContents$(i)) IF n < 1 THEN Error1$ = "Y": CursorPtr = i: CALL MyBeep: GOTO TopOfTTLoop END IF ELSEIF i = 4 OR i = 5 THEN IF FContents$(i) <> "Y" AND FContents$(i) <> "N" AND FContents$(i) <> "C" THEN Error1$ = "Y": CursorPtr = i: CALL MyBeep: GOTO TopOfTTLoop END IF ELSE IF FContents$(i) <> "Y" AND FContents$(i) <> "N" THEN Error1$ = "Y": CursorPtr = i: CALL MyBeep: GOTO TopOfTTLoop END IF END IF INCR i LOOP UNTIL i > 7 LOOP WHILE Error1$ = "Y" CURSOR OFF 'turn off cursor END SUB SUB TwoTeamStarters(tm, N) '[in: tm out: N] ResetList: REDIM SelectedPit$(5) REDIM SelectedRef(5) SelX = 0 DO CALL Drawfrm(18+rowO, 30+colO, 24+rowO, 50+colO, defattr, "Selected", nulls$, 0, 0, 0) FOR i = 1 TO SelX QPRINTs 18+rowO+i, 32+colO, SelectedPit$(i), dimattr NEXT r = 3 CALL PickTheStarter(tm, r, N) '[ENTER or [ESC] gets out of here IF N > 0 THEN '[ENTER] IF SelX < 5 THEN INCR SelX SelectedPit$(SelX) = DataName(N, tm) SelectedRef(SelX) = N END IF END IF IF N = 0 THEN '[ESC] '17,58 24,71 1,33 8,46 attr = (3 * 16) + 15 CALL GetScreen(Scr1$, 1+rowO, 33+colO, 8+rowO, 46+colO) CALL Drawfrm(1+rowO, 33+colO, 8+rowO, 46+colO, attr, nulls$, nulls$, 0, 0, 0) CALL Button( 2+rowO, 35+colO, errattr, " [O]K ", 1) CALL Button( 4+rowO, 35+colO, errattr, " C[L]ear ", 1) CALL Button( 6+rowO, 35+colO, errattr, " [C]ancel ", 1) xS$ = WAITKEY$ IF LEN(xS$) = 4 THEN msy = MOUSEY msx = MOUSEX xS$ = UCASE$(CHR$(SCREEN(msy, msx))) CALL FlashField (msy, msx, 1, 2, 100, 0) ELSE xS$ = UCASE$(xS$) END IF IF xS$ = "O" OR xS$ = CHR$(13) THEN 'OK EXIT DO ELSEIF xS$ = "C" THEN 'Cancel EXIT SUB ELSE 'Clear CALL PutScreen(Scr1$, 1+rowO, 33+colO, 8+rowO, 46+colO) GOTO ResetList END IF END IF LOOP 'Copy to rotation record [OK] i = ROTATIONLIST (DataFil(tm)) 'Find Rot record for this team IF i = 0 THEN IF RTx < 300 THEN INCR RTx i = RTx END IF END IF CmdSP$ = "S" + LTRIM$(STR$(SelX)) RotRec(i).RotTeam = DataFil(tm) 'Update this Rot record RotRec(i).RotMeth = CmdSP$ IF (tm = 1 AND CmdVSpot$ = "Y") OR _ (tm = 2 AND CmdHSpot$ = "Y") OR _ CmdSpot$ = "Y" THEN RotRec(i).RotSpot = "Y" ELSE RotRec(i).RotSpot = " " END IF RotRec(i).RotIndex = 1 FOR j = 1 TO 5 RotRec(i).RotList(j) = 0 NEXT FOR j = 1 TO SelX RotRec(i).RotList(j) = SelectedRef(j) NEXT N = RotRec(i).RotList(1) END SUB SUB UpdSCHRecord1 (a$) IF ProtectSCH THEN EXIT SUB 'Find CmdSTAT$ in the 1st record of the SCH file - or stop at 1st blank slot GET #2, 1, SchBuffer$ i = 3 DO i = i + 8 xS$ = MID$(SchBuffer$, i, 8) IF UCASE$(RTRIM$(xS$)) = UCASE$(RTRIM$(CmdStat$)) THEN EXIT DO LOOP UNTIL xS$ = SPACE$(8) 'Either found the current STAT file: i points to it OR 'Didn't find it: i points to first available slot OR 'There wasn't a STAT file: i = 11 IF a$ = "DEL" THEN 'Remove and collapse if found a STAT file IF xS$ > "!" THEN L = 91 - (i + 8) MID$(SchBuffer$, i, L) = MID$(SchBuffer$, i + 8, L) MID$(SchBuffer$, 83, 8) = SPACE$(8) END IF ELSE 'Update SCH w/current STAT file IF CmdStat$ > "!" THEN MID$(SchBuffer$, i, 8) = CmdStat$ END IF END IF PUT #2, 1, SchBuffer$ END SUB SUB VisitorOptions (Pick) REDIM List1(1 TO 10) AS List1Type IF it = 1 THEN List1(1).ListItem = " Pinch Hit " List1(2).ListItem = " Pinch Run " List1(3).ListItem = " View Lineup " List1(4).ListItem = " View Opponent " List1(5).ListItem = " Call Bullpen " IF WarmUpRule = FALSE THEN List1(5).ListItem = "%" + List1(5).ListItem List1(6).ListItem = STRING$(27,"Ž") List1(7).ListItem = " Steal " List1(8).ListItem = " Bunt/Squeeze " List1(9).ListItem = " Hit and Run " CALL Drawfrm(10+rowO, 8+colO, 20+rowO, 38+colO, defattr, RTRIM$(Names(1)), "", 0, 0, 2) CALL PickFromList(List1(), 9, 9, 1, 27, 10+rowO, 8+colO, 20+rowO, 38+colO, dimattr, revattr, Pick, RetKey, nulls$, mous, ms$) SELECT CASE Pick CASE 1 PH = TRUE CASE 2 PRun = TRUE CASE 3 ViewVisi = TRUE CASE 4 ViewHome = TRUE CASE 5 BullO = TRUE CASE 7 Steal = TRUE CASE 8 Bunt = TRUE CASE 9 HitAndRun = TRUE CASE ELSE END SELECT ELSE List1(1).ListItem = " Visit Mound " List1(2).ListItem = " Player Substitution " List1(3).ListItem = " Swap Positions " List1(4).ListItem = " View Line-up " List1(5).ListItem = " View Opponent " List1(6).ListItem = STRING$(27,"Ž") List1(7).ListItem = " Intentional Walk " List1(8).ListItem = " Infield Tight " List1(9).ListItem = " Pitch-Out " List1(10).ListItem =" Pitch-Around " CALL Drawfrm(10+rowO, 8+colO, 21+rowO, 38+colO, defattr, RTRIM$(Names(1)), "", 0, 0, 2) CALL PickFromList(List1(), 10, 10, 1, 27, 10+rowO, 8+colO, 21+rowO, 38+colO, dimattr, revattr, Pick, RetKey, nulls$, mous, ms$) SELECT CASE Pick CASE 1 BullD = TRUE CASE 2 SubX = TRUE CASE 3 SwPos = TRUE CASE 4 ViewVisi = TRUE CASE 5 ViewHome = TRUE CASE 7 IWalk = TRUE CASE 8 Tight = TRUE CASE 9 POut = TRUE CASE 10 PAround = TRUE CASE ELSE END SELECT END IF ERASE List1 END SUB SUB WalkRoutine IF DelFac THEN IF SoundOn THEN CALL WavPopMitt IF IWalk THEN CALL Msg ("18", "0", "0", "02", ib, it, man2, team2) ELSE CALL Msg ("18", "0", "0", "01", ib, it, man2, team2) END IF END IF IF ir3 <> 0 AND ir2 <> 0 AND ir1 <> 0 THEN 'Bases Loaded CALL Advanc(1, 1, 1) ELSEIF ir1 THEN 'Runner on First IF ir2 THEN 'Also on Second CALL Advanc(1, 1, 0) ELSE 'Nobody on Second CALL Advanc(1, 0, 0) END IF END IF ' ** PUT BATTER ON 1ST ** ir1 = ib mpp(ib) = ip DECR mab(ref, it) IF UCASE$(DataHand(ip, id)) = "L" THEN DECR mabLHP(ref, it) INCR mbbLHP(ref, it) ELSE DECR mabRHP(ref, it) INCR mbbRHP(ref, it) END IF INCR mbb(ref, it) INCR mpw(ip, id) IF IWalk THEN Result$ = "Int BB" ELSE Result$ = "BB" END IF END SUB SUB WavBunt IF NOT SoundOn THEN EXIT SUB DIM WavList$(2) WavList$(1) = "57435.wav" WavList$(2) = "57435.wav" i = FRND(2) L = PlayWav(WavList$(i)) SLEEP 400 END SUB SUB WavPopUp IF NOT SoundOn THEN EXIT SUB DIM WavList$(2) WavList$(1) = "3017.wav" WavList$(2) = "37979.wav" i = FRND(2) L = PlayWav(WavList$(i)) SLEEP 400 END SUB SUB WavShortFly IF NOT SoundOn THEN EXIT SUB DIM WavList$(2) WavList$(1) = "37880.wav" WavList$(2) = "3017.wav" i = FRND(2) L = PlayWav(WavList$(i)) SLEEP 400 END SUB SUB WavRegularFly IF NOT SoundOn THEN EXIT SUB DIM WavList$(4) WavList$(1) = "3017.wav" WavList$(2) = "57430.wav" WavList$(3) = "37979.wav" WavList$(4) = "hit.wav" i = FRND(4) L = PlayWav(WavList$(i)) SLEEP 400 END SUB SUB WavBigFly IF NOT SoundOn THEN EXIT SUB DIM WavList$(4) WavList$(1) = "37830.wav" WavList$(2) = "37830.wav" WavList$(3) = "57430.wav" WavList$(4) = "hit.wav" i = FRND(4) L = PlayWav(WavList$(i)) SLEEP 400 IF IGone AND CmdHRWav$ > "!" THEN L = PlayWav(CmdHRWav$) END IF END SUB SUB WavLineDrive IF NOT SoundOn THEN EXIT SUB DIM WavList$(2) WavList$(1) = "57430.wav" WavList$(2) = "hit.wav" i = FRND(2) L = PlayWav(WavList$(i)) SLEEP 400 END SUB SUB WavRegularHit IF NOT SoundOn THEN EXIT SUB DIM WavList$(4) WavList$(1) = "57430.wav" WavList$(2) = "57430.wav" WavList$(3) = "3017.wav" WavList$(4) = "hit.wav" i = FRND(4) L = PlayWav(WavList$(i)) SLEEP 400 END SUB SUB WavSoftGrounder IF NOT SoundOn THEN EXIT SUB DIM WavList$(2) WavList$(1) = "57435.wav" WavList$(2) = "37906.wav" i = FRND(2) L = PlayWav(WavList$(i)) SLEEP 400 END SUB SUB WavRegularGrounder IF NOT SoundOn THEN EXIT SUB DIM WavList$(3) WavList$(1) = "61400.wav" WavList$(2) = "61714.wav" WavList$(3) = "hit.wav" i = FRND(3) L = PlayWav(WavList$(i)) SLEEP 400 END SUB SUB WavWhiff IF NOT SoundOn THEN EXIT SUB DIM WavList$(2) WavList$(1) = "21904.wav" WavList$(2) = "61817.wav" i = FRND(2) L = PlayWav(WavList$(i)) SLEEP 400 END SUB SUB WavPopMitt IF NOT SoundOn THEN EXIT SUB DIM WavList$(4) WavList$(1) = "37909.wav" WavList$(2) = "37910.wav" WavList$(3) = "37910.wav" WavList$(4) = "60290.wav" i = FRND(4) L = PlayWav(WavList$(i)) SLEEP 400 END SUB '************* MISC GRAPHICS SUBROUTINES ***************** SUB HideGfx GfxWindow %GFX_HIDE END SUB SUB ShowGfx GfxWindow %GFX_SHOW END SUB SUB UnfreezeAndRefresh GfxWindow NOT %GFX_FREEZE GfxRefresh 0 GfxWindow %GFX_FREEZE END SUB SUB GraphHole (hole, row1, col1, row2, col2) IF NOT Gfx THEN EXIT SUB IF HoleStatus(hole) = -1 THEN EXIT SUB 'Could eliminate this non-sense if I passed the parameters "by value" I think trow1 = row1 tcol1 = col1 trow2 = row2 tcol2 = col2 IF tcol1 < 1 THEN tcol1 = 1 IF tcol2 < 1 THEN tcol2 = 1 IF tcol1 > ConsCols THEN tcol1 = ConsCols IF tcol2 > ConsCols THEN tcol2 = ConsCols IF tcol2 < tcol1 THEN EXIT SUB IF trow1 < 6 THEN trow1 = 6 IF trow2 < 6 THEN trow2 = 6 IF trow1 > ConsRows-1 THEN trow1 = ConsRows-1 IF trow2 > ConsRows-1 THEN trow2 = ConsRows-1 IF trow2 < trow1 THEN EXIT SUB res = GfxTextHole (hole, tcol1, trow1, tcol2, trow2) IF res = 0 THEN HoleStatus(hole) = -1 ELSE HoleStatus(hole) = 0 LOCATE 2, 50: PRINT " Bad Hole:" + STR$(hole) + " ": zz$ = WAITKEY$ END IF END SUB SUB EliminateHole (hole) IF NOT Gfx THEN EXIT SUB IF HoleStatus(hole) = 0 THEN EXIT SUB res = FillHole (hole) IF res = 0 THEN HoleStatus(hole) = 0 ELSE LOCATE 2, 50: PRINT " Bad fill:" + STR$(hole) + " ": zz$ = WAITKEY$ END IF END SUB