' ' #DEBUG ERROR ON ' (If you "uncomment" the statement above, don't forget to un-comment the "ON ERROR GOTO...") ' #COMPILE EXE #RESOURCE "SBS.PBR" ' ' ** Strategic Baseball Simulator v 4.9.1 for Windows under PB/CC 2.11 ' Copyright 1988-2009 David B. Schmidt ' ' #INCLUDE "WIN32API.INC" '========================================================================= ' Equates and declares extracted from Win32api.inc for following code file ' and all its includes: C:\PBCC21\sbs49\sbs491.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! '-------------------------------------------------------- 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 CmdRetroMode$ 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 REGISTER zz AS LONG ' 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 &h-------- 'Your Console Tools serial number goes here InitConsoleTools hCurInstance, 0, 0, 3, 0, 0 GraphicsToolsAuthorize &h-------- 'Your Graphics Tools serial number goes here 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 'hardcoded later at .952 DefChancesPerGameF(2) = 1.0 DefChancesPerGameF(3) = 2.2 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 CmdRetroMode$ = "N" CmdPitchersTank$ = "Y" 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, 9) = "TEXT-MODE" THEN IF MenuOpt$ <> "P" THEN IF MID$(rec$, 11, 1) <> "N" THEN ConsRows = 25 ConsCols = 80 END IF END IF ELSEIF MID$(rec$, 1, 10) = "RETRO-MODE" THEN IF MenuOpt$ <> "P" THEN IF MID$(rec$, 12, 1) <> "N" THEN ConsRows = 25 ConsCols = 80 CmdRetroMode$ = "Y" END IF END IF 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, 16) = "DISPLAY-FATIGUE=" THEN CmdPitchersTank$ = MID$(rec$, 17, 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 zS$ = "" 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 '---------------------------------------- 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) = CHR$(192)+CHR$(196)+" " 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) = CHR$(192)+CHR$(196)+" " 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) = CHR$(192)+CHR$(196)+" " 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" OR AdjustBO(it) = "F" THEN IF MMx THEN 'Dont mess with lineups on MM teams IF MMTeam(it) = FALSE THEN IF AdjustBO(it) = "Y" OR _ AdjustBO(it) = "F" OR _ (AdjustBO(it) = "C" AND LUAltered(it)) THEN CALL AdjustBattingOrder (it) END IF ELSE IF AdjustBO(it) = "Y" OR _ AdjustBO(it) = "F" 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 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) = CHR$(192)+CHR$(196)+" " 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$ <> CHR$(249)) THEN GOTO ReadDirs IF ms$ = CHR$(249) 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, CHR$(205)), 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 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 xS$ = CHR$(180) +" Hit/Click Any Key to Begin " + CHR$(195) QPRINTs 22+rowO, 28+colO, xS$, 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 ForceCLS = FALSE CLS IF RegDsply THEN it = 1: CALL ScoreBrd (TRUE, TRUE) CALL Prompt(0) ELSE IF RegDsply THEN CALL Prompt(0) 'experiment 2009 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 (text) 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 last pitcher IF DataGames(N, id) > 0 THEN CALL CountAvPitchers(id, AvP, LastGuy) IF ((DataGbyP(N, id, 1) / DataGames(N, id) < .26) AND RND < .5) OR AvP < 3 THEN 'starts / games < .26 'He's primarily a reliever OR we're low on pitchers 'Leave him in to pitch CALL Bullpen(N, id, N, 0) NeedNewPitcher = FALSE ivp = 0 ELSE 'He's primarily a starter - he should not stay in the game to pitch ivp = i END IF ELSE 'We don't have data on "games", so better not let him stay in and pitch ivp = i END IF ELSE 'No, he has no pitching data 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$ + "]" SaveDaysOffRule = DaysOffRule DaysOffRule = FALSE CALL CountAvPitchers(id, AvP, LastGuy) DaysOffRule = SaveDaysOffRule 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 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 ELSE IF CmdPitchersTank$ = "Y" THEN GOSUB DisplayPitchersTank END IF '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, 20+rowO, 54+colO) '7 30 19 53 CALL DrawFrm(7+rowO, 30+colO, 19+rowO, 52+colO, defattr, "Inning Summary", nulls$, 1, 0, 0) CALL Innsum (9+rowO, 34+colO) SLEEP 2500 CALL PutScreen(Scr3$, 7+rowO, 30+colO, 20+rowO, 54+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 the variable "ref" after this point for this batter! 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 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 DelFac THEN SLEEP DelFac * 800 GOTO AutoManage 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 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 ' ** 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, CHR$(193), defattr QPRINTs 17+rowO, 77+colO, UpPtr$, defattr QPRINTs 18+rowO, 77+colO, DnPtr$, defattr QPRINTs 19+rowO, 77+colO, CHR$(194), 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, CHR$(196)) + " Pitchers and Bench " + STRING$(28, CHR$(196)), 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 * 900 'Allow user time to read the messages, etc. 800 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 'J-u-s-t 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 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 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 'pitchers 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. CALL SearchStandingsTable (League(1), Div(1), Names(1), j) 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) = "F" OR _ (AdjustBO(1) = "C" AND c1) THEN CALL AdjustBattingOrder (1) IF AdjustBO(2) = "Y" OR _ AdjustBO(2) = "F" 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 GOTO MultiPromptLoop END IF ELSE CLOSE #2 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 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 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: 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 DisplayPitchersTank: n = nPitch(id) m = (n / ExpectedPitchCount(ipa(id), id)) * 100 pc$ = "(" + LTRIM$(STR$(m)) + "%)" L = LEN(pc$) IF L < 6 THEN pc$ = pc$ + SPACE$(6 - L) QPRINTs ConsRows, ConsCols - 17, pc$, scdattr 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 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 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 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 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 '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, CHR$(193), defattr QPRINTs MidRow+1, c2, UpPtr$, defattr QPRINTs MidRow+2, c2, DnPtr$, defattr QPRINTs MidRow+3, c2, CHR$(194), defattr RetKey = -98 'Display List only IF CmdScrF$ < "!" THEN xS$ = "SCORECRD.LOG" ELSE xS$ = CmdScrF$ 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$) 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 = CHR$(192)+CHR$(196)+" " + 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, ".DAT ", attr QPRINTs r+1, cp+5, MID$(a$, 6), revattr 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, " Sim ", attr QPRINTs r+2, cp+5, MID$(a$, 6), revattr 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, ".DAT ", attr QPRINTs r+1, cb+5, MID$(a$, 6), revattr 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, " Sim ", attr QPRINTs r+2, cb+5, MID$(a$, 6), revattr 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 IF CmdRetroMode$ = "Y" 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 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 = StretchBitmap(sFileName$, 1024, 512) ELSE 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 = StretchBitmap(sFileName$, 1024, 512) ELSE 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: IF CmdRetroMode$ = "Y" THEN ConsRows = 25 ConsCols = 80 END IF CONSOLE SCREEN ConsRows, ConsCols ConsoleTitle "Strategic Baseball Simulator 4.9.1" IF winver < 2 THEN ConsoleIcon %IDI_Console DeleteWindowMenuItem %MENUITEM_TOOLBAR DeleteWindowMenuItem %MENUITEM_CLOSE ConsoleToolbar %OFF, %NO_CHANGE ConsoleWindow %SHOW IF CmdRetroMode$ = "Y" THEN ConsoleWindow %FULLSCREEN ELSE 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 END FUNCTION FUNCTION DECRYPT$ (x$) 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)) / .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 '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 fewer 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 IF p = 4 THEN defperF! = defperF! * 1.0060 IF p = 5 THEN defperF! = defperF! * 1.0080 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 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 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 'Returns 7, 8 or 9 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 'Returns 7, 8 or 9 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 '2009 "F" 'Go through lineup. If a player's current slot is same as .DAT, do not mess with his slot IF AdjustBO(tm) = "F" THEN IF dh = 0 THEN L = 8 ELSE L = 9 FOR i = 1 TO L s = 0 FOR j = 1 TO L IF DataName$(i, tm) = NameRef$(j, tm) THEN s = j EXIT FOR END IF NEXT IF s > 0 THEN IF i <> s THEN CALL Switch(i, s, tm) INCR ProtectCtr Protect(ProtectCtr) = i END IF NEXT END IF 'Who has best OPS? i = 3 GOSUB SearchProtectList IF NOT InList THEN 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 END IF 'Who left has most RBI/P.A. ? i = 4 GOSUB SearchProtectList IF NOT InList THEN 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 END IF 'Who left has most SB/P.A.? i = 1 GOSUB SearchProtectList IF NOT InList THEN 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 END IF 'Who left has most SB/P.A.? i = 2 GOSUB SearchProtectList IF NOT InList THEN 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 END IF 'Of #1 and #2, who has the best OBP? 'Swap if #2 has a better OBP i = 1 GOSUB SearchProtectList IF NOT InList THEN i = 2 GOSUB SearchProtectList IF NOT InList THEN 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 END IF END IF 'Who left has highest Slug%? i = 5 GOSUB SearchProtectList IF NOT InList THEN 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 END IF 'Who left has highest Slug%? i = 6 GOSUB SearchProtectList IF NOT InList THEN 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 END IF 'Who left has highest Slug%? i = 7 GOSUB SearchProtectList IF NOT InList THEN 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 END IF 'Who left has highest Slug%? i = 8 GOSUB SearchProtectList IF NOT InList THEN 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 END IF IF dh THEN 'Who has not been picked? Should just be one left. s = 9 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 '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) 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 'Go thru entire bench 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 'OK to add "nn" to PosPool 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 'Block players marked "X" in DataPlat from starting against same-handed pitcher IF UCASE$(DataPlat(nn, tm)) = "X" THEN ij = 3 - tm IF ipa(ij) THEN IF DataHand(nn, tm) = UCASE$(DataHand(ipa(ij), ij)) THEN xF! = 1.0 END IF END IF 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 CALL ClipIfNecessary (x$, BatterRow, BatterCol, b1r1, b1c1, b1r2, b1c2, b2r1, b2c1, b2r2, b2c2, ca, cf) 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 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 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 #15 first: IF LastPiAd(tm) > 14 THEN IF iused(15, tm) = 0 AND DupNameFlag(i) = 0 THEN n = 15 END IF END IF IF n THEN RETURN 'Last desperate search: i = LastPiAd(tm) DO UNTIL i < 10 IF iused(i, tm) = 0 AND DupNameFlag(i) = 0 THEN n = i EXIT DO END IF DECR 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 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 '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 '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$ = CHR$(249) 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 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, CHR$(196)), 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) 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$ = CHR$(180) + CloseButton$ + CHR$(195) 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$ = CHR$(181) + CloseButton$ + CHR$(198) 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$ = CHR$(193): x2$ = CHR$(194) ELSE x1$ = CHR$(207): x2$ = CHR$(209) 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)) = CHR$(249) 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 RND < (.01 * DataSpeed(ib, it) - .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 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 + .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 END SUB SUB Gone i = 12 COLOR i, 0 IF Gfx THEN CALL GraphHole(30, 6+rowO, 16+colO, 22+rowO, 66+colO) CALL Drawfrm(6+rowO, 16+colO, 22+rowO, 66+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+01, c, " HHHH HHHH OOOOOO MMMM MMMM EEEEEEEE ", attr QPRINTs r+02, c, " HH HH OO OO MM MMMM MM EE ", attr QPRINTs r+03, c, " HHHHHHHH OO OO MM MM MM EEEEE ", attr QPRINTs r+04, c, " HH HH OO OO MM MM EE ", attr QPRINTs r+05, c, " HHHH HHHH OOOOOO MMMM MMMM EEEEEEEE ", attr QPRINTs r+06, c, " ", attr QPRINTs r+07, c, " RRRRRRR UUUU UUUU NNNN NNNN ", attr QPRINTs r+08, c, " RR RR UU UU NN N NN ", attr QPRINTs r+09, c, " RRRRRR UU UU NN N NN ", attr QPRINTs r+10, c, " RR R UU UU NN N NN ", attr QPRINTs r+11, c, " RRR RR UUUUUU NNNN NNNN ", 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 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 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 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) = 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,CHR$(196)) 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,CHR$(196)) 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, CHR$(196)), defattr QPRINTs r2-4, c1+36, CHR$(180) + " " + LPtr$ + " " + RPtr$ + " " + CHR$(195), defattr QPRINTs MidRow+3, c2, CHR$(193), defattr QPRINTs MidRow+4, c2, UpPtr$, defattr QPRINTs MidRow+5, c2, DnPtr$, defattr QPRINTs MidRow+6, c2, CHR$(194), 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,CHR$(196)) + " Bench " + STRING$(36, CHR$(196)) 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$) 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 a$ = "[X]:Close [" + CHR$(30) + " " + CHR$(31) + "]:PageUp/Dn [< >] [u d] [T]op [B]ot [P]rint [S]aveAs " + CHR$(195) + 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) 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