Skip to content

Instantly share code, notes, and snippets.

@pqnelson

pqnelson/sbs493-public.brs

Last active August 29, 2015 14:27
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save pqnelson/77bb6daf63fe1c624bac to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save pqnelson/77bb6daf63fe1c624bac to your computer and use it in GitHub Desktop.
Download ZIP
Pretty printed version of http://sbs-baseball.com/sbs493-public.txt
Raw
sbs493-public.brs
'
' #DEBUG ERROR ON
' (If you "uncomment" the statement above, don't forget to un-comment the "ON ERROR GOTO...")
'
' Changed RotRec to 1000 - May 28, 2011 (Teams to keep track of for Pitching Rotations)
' Changed RotRec to 1500 - June 4, 2011
' Changed WLRec to 1500 - June 4, 2011 (Teams to keep track of in Standings)
' If more than 300 teams involved, user needs to use STAT-TEAM-LIMIT= in .CMD
'
'
#COMPILE EXE
#RESOURCE "SBS.PBR"
'
' ** Strategic Baseball Simulator v 4.9.3 for Windows under PB/CC 2.11
' Copyright 1988-2012 David B. Schmidt
'
'#INCLUDE "WIN32API.INC"
'=========================================================================
' Equates and declares extracted from Win32api.inc for following code file
' and all its includes: C:\PBCC21\sbs49\sbs492.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 AnnouncerOn 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 CmdDeadBallAdj$
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 'Comment this out for production
REGISTER i AS INTEGER
REGISTER zz AS LONG
' GLOBAL:
DIM Announcer(12) AS GLOBAL MType
DIM HLRec(400) AS GLOBAL HiLiteType 'was 150
DIM SCRec(300) AS GLOBAL ScoreCardType
DIM WLRec(1 TO 1500) 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 &hXXXXXXXX 'Console Tools serial number
InitConsoleTools hCurInstance, 0, 0, 3, 0, 0
GraphicsToolsAuthorize &hXXXXXXXX 'Graphics Tools serial number
ConsoleWindow %HIDE
PAGE 1, 1
CURSOR OFF
RANDOMIZE TIMER
'Set default screen size depending on Windows version
winver = 0
ConsRows = 25
ConsCols = 80
j = WindowsVersion(%WIN_MAJORVERSION)
k = WindowsVersion(%WIN_MINORVERSION)
IF j = 4 AND k = 0 THEN 'Windows 95
ConsRows = 35
ConsCols = 102
winver = 0
END IF
IF j = 4 AND k > 0 THEN 'Windows 98/Me
ConsRows = 44
ConsCols = 102
winver = 1
END IF
IF j = 5 THEN
IF k = 0 THEN '2000
ConsRows = 44
ConsCols = 102
winver = 2
END IF
IF k > 0 THEN 'XP
ConsRows = 44
ConsCols = 102
winver = 3
END IF
END IF
IF j > 5 THEN
IF k = 0 THEN 'Vista ?
ConsRows = 44
ConsCols = 102
winver = 4
END IF
IF k = 1 THEN '7
ConsRows = 44
ConsCols = 102
winver = 5
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 forground
ColorDescTable$(11) = "BRIGHT CYAN" 'very light(powder) blue - need dark forground
ColorDescTable$(12) = "BRIGHT RED" 'bright red
ColorDescTable$(13) = "BRIGHT MAGENTA" 'almost pink
ColorDescTable$(14) = "YELLOW" 'bright yellow - need dark forground
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"
CmdDeadBallAdj$ = "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, 13) = "DEADBALL-ADJ=" THEN
CmdDeadBallAdj$ = MID$(rec$, 14, 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 is supposed to be a clear blue screen
PAGE 2
COLOR 15, 3
CLS
'Back to Page 1
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(1500) 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(1500) 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
'Copy the clear blue screen to Page 1
PCOPY 2, 1
REDIM RotRec(1500) 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 'Copy the blue screen to Page 1
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)
Fil$ = CmdWritePath$ + "*.PRN"
CALL LoadFilesToList1 (Fil$, List1(), FileLimit, n)
Fil$ = CmdWritePath$ + "*.LOG"
CALL LoadFilesToList1 (Fil$, List1(), FileLimit, n)
Fil$ = "*.DOC"
CALL LoadFilesToList1 (Fil$, List1(), FileLimit, n)
Fil$ = CmdWritePath$ + "*.RTF"
CALL LoadFilesToList1 (Fil$, List1(), FileLimit, n)
Fil$ = CmdWritePath$ + "*. "
CALL LoadFilesToList1 (Fil$, List1(), FileLimit, 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" OR UCASE$(RIGHT$(x$, 4)) = ".RTF" 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(1500) AS GLOBAL RotType
RTx = 0
REDIM MMList(100) AS GLOBAL MMType
MMx = 0
REDIM WLRec(1 TO 1500) 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 would like to quit now."
xS$ = SubDoubleQuote$ (xS$)
QPRINTs 22+rowO, 23+colO, xS$, dimattr
xS$ = WAITKEY$
IF LEN(xS$)= 4 THEN
msx = MOUSEX
msy = MOUSEY
xS$ = CHR$(SCREEN(msy, msx))
CALL FlashField (msy, msx, 1, 2, 100, 0)
END IF
'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
' x$ = "Back: " + BackgroundPic$ + " Last: " + LastPic$
' CALL ErrorBox (x$)
IF (BackgroundPic$ <> LastPic$) OR MMGame THEN
LastPic$ = BackgroundPic$
COLOR fldfor, fldbac
CLS
IF BackgroundPic$ > "!" THEN GOSUB GetPhotoSpecs
GOSUB DefineBitmap
END IF
END IF
GOTO StartUp
END IF
'--------- MANUAL / TWO-TEAM ----
'New location Statistics Recording
'Options M and T
'---------------------------
IF NOT CmdLine THEN
PCOPY 2, 1
CALL StatRecordSetup (Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
CALL StatRecordIO (RetKey, Flds, 3, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
IF RetKey = KeyF3 THEN
GOTO MenuOptions
ELSE
PCOPY 2, 1
END IF
IF CmdStat$ > "!" THEN GOSUB OpenStatFiles
END IF
'--------------------------------
'Load and sort list of .DAT files
'Options: Manual and Two-team
'--------------------------------
REM QPRINTs 11, 42, " Loading file names... ", defattr
r1 = ((ConsRows - 20) \ 5) + 1 'replaces 2
r2 = ConsRows - r1 'replaces 22
c1 = (ConsCols - 78) \ 2 'replaces 1
c2 = ConsCols - c1 'replaces 79
CmdSlotGames = 0
FileLimit = 1500
REDIM List1(1 TO FileLimit) AS List1Type
GOSUB GetCurrentDir 'return CurrentDir$
tm = 0
RetKey = -97
ReadDirs:
GOSUB LoadDirsToList1
'FOLDER Frame (right)
IF RetKey = -97 THEN
j = 0: c1$ = CHR$(193): c2$ = CHR$(194)
ELSE
j = 1: c1$ = CHR$(208): c2$ = CHR$(210)
END IF
IF tm = 0 THEN
a$ = " Dbl-click (or Enter) VISITING TEAM "
ELSE
a$ = " Dbl-click (or Enter) HOME TEAM "
END IF
CALL DrawFrm(r1, c2-20, r2, c2, defattr, "Dbl-click folder", nulls$, 0, j, 0)
QPRINTs MidRow-1, c2, c1$, defattr
QPRINTs MidRow , c2, UpPtr$, defattr
QPRINTs MidRow+1, c2, DnPtr$, defattr
QPRINTs MidRow+2, c2, c2$, defattr
'FILENAME Frame (left)
CALL DrawFrm(r1, c1, r2, c2-21, defattr, "[V]iew [E]dit [A]ux PgUp/PgDn", a$, 0, (1-j), 2)
'Change attributes for emphasis
attr = CalcAttr(14, 1) 'Yellow on dark blue
CALL ReadFromScreen (r2, 1, ConsCols, field$, " ", Valid$)
ii = INSTR(field$, "VISIT")
IF ii = 0 THEN ii = INSTR(field$, "HOME")
IF ii THEN CALL ChangeAttribute (r2, ii, 13, attr)
j = 1 - j
IF j = 0 THEN
c1$ = CHR$(193): c2$ = CHR$(194)
ELSE
c1$ = CHR$(208): c2$ = CHR$(210)
END IF
QPRINTs MidRow-1, c2-21, c1$, defattr
QPRINTs MidRow , c2-21, UpPtr$, defattr
QPRINTs MidRow+1, c2-21, DnPtr$, defattr
QPRINTs MidRow+2, c2-21, c2$, defattr
'Fill FOLDER frame and instantly return (-97) or pick a directory
CALL PickFromList(List1(), n, r2-r1-1, 1, 17, r1, c2-20, r2, c2, dimattr, revattr, Pick, RetKey, nulls$, mous, ms$)
IF Pick > 0 THEN
xS$ = RTRIM$(List1(Pick).ListItem)
IF xS$ < "!" THEN GOTO ReadDirs
IF LEFT$(xS$, 3) = 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$())
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 CmdLine OR (amgr(1) AND amgr(2)) THEN 'SetCmdWinData
GOSUB DefineBitmap
GOTO StartUp
END IF
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
GOSUB DefineBitmap
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 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)
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
SuspendWarmUpRule = FALSE
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 _
PitcherCloneUnused(DataName(i, id), id) AND _
i <> iyp(np(id), id) THEN
N = -1
'Debug:
' x$ = "Last Real Pitcher=" + STR$( iyp(np(id),id) ) + "|"
' x$ = x$ + "i=" + STR$(i) + "|"
' x$ = x$ + "WarmUpStatus(i, id)=" + STR$( WarmUpStatus(i,id) ) + "|"
' x$ = x$ + "iused(i, id)=" + STR$( iused(i, id) ) + "|"
' x$ = x$ + DataName(i, id)
' CALL ErrorBox (x$)
EXIT FOR
END IF
NEXT
IF N = 0 THEN
'Oops - Nobody is warm - this rarely happens, but just in case...
'Clone-pitcher pinch-hits or pinch-runs for pitcher but is then replaced before the
'clone-pitcher actually pitches in next 1/2 inning.
'
' -OR-
'Clone-pitcher pinch-hits or pinch-runs for pitcher and the next 1/2 inning the manual
'manager elects not to keep clone-pitcher in game
'
'Suspend WarmUpRule temporarily so we don't get stuck in the Bullpen without a "warm"
'pitcher
SuspendWarmUpRule = TRUE
WarmUpRule = FALSE
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 SuspendWarmUpRule THEN WarmUpRule = TRUE
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
IF RegDsply THEN 'Re-draw batting order
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..."
CALL PostAnnouncer (TRUE, FALSE)
SLEEP 1000
ELSE
AddToAnnouncer it, "We're set for the first pitch..."
CALL PostAnnouncer (FALSE, FALSE)
SLEEP 1500
END IF
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"): SLEEP 1000 '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 (TRUE, FALSE) 'was 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
Qpush
IF Gfx THEN CALL GraphHole(5, 7+rowO, 30+colO, 19+rowO, 53+colO)
'CALL GetScreen(Scr3$, 7+rowO, 30+colO, 19+rowO, 53+colO)
CALL DrawFrm(7+rowO, 30+colO, 19+rowO, 53+colO, defattr, "Inning Summary", nulls$, 0, 0, 0)
CALL Innsum (9+rowO, 34+colO)
SLEEP 2500
'CALL PutScreen(Scr3$, 7+rowO, 30+colO, 19+rowO, 53+colO)
Qpop
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
'Test update scoreboard here:
CALL ScoreBrd (DrawSBFrame, GenerateALLSB) 'Usually does not erase announcer
'Announce hitter, pause for keyboard input
'Throw in some box score history
BLN$ = LASTNAME$(DataName(ib, it))
IF NOT ExtraTalk THEN ANx = 0
ref = DataRef(ib, it) 'hitter's reference number for box
'Do not change "ref" after this point!
IF DelFac > 0 OR amgr(1) = 0 OR amgr(2) = 0 THEN
IF ResetHitter THEN 'Back from SB or POut
CALL AddToAnnouncer(it, BLN$ + " steps back in...")
GOTO DisplayAnnouncer
ELSE
CALL Msg ("01", "0", "0", "00", ib, it, man2, team2) 'Here comes...
END IF
IF ExtraTalk THEN GOTO DisplayAnnouncer
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
DisplayAnnouncer:
CALL PostAnnouncer (TRUE, FALSE) 'was FALSE
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 "ref" 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
QPush
CALL OptionSetup (row, Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
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$())
QPop
IF Gfx AND RegDsply THEN
CALL EliminateHole(30)
CALL UnfreezeAndRefresh
END IF
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))
StatLineDisplayed = FALSE
DO UNTIL (VisiReady AND HomeReady)
IF Gfx AND StatLineDisplayed = FALSE THEN
CALL UnfreezeAndRefresh
END IF
IF HomePopped = FALSE AND VisiPopped = FALSE AND StatLineDisplayed = FALSE THEN
SLEEP 40
CALL FlashField (ConsRows, 2, 3, 4, 100, 0) 'Flash enter prompt
END IF
INPUT FLUSH
a$ = WAITKEY$ 'Display current screen / wait for input
IF StatLineDisplayed = TRUE THEN
'Clean up previous stat mess no matter if next input is mouse or keyboard
CALL PutScreen(Scr4$, sr1, sc1, sr2+1, sc2+2)
IF Gfx THEN CALL EliminateHole(30)
StatLineDisplayed = FALSE
ITERATE DO
END IF
IF LEN(a$) = 4 THEN
msx = MOUSEX
msy = MOUSEY
IF msy = ConsRows THEN 'mouse clicks on option menu row
a$ = CHR$(SCREEN(msy, msx))
CALL FlashField (msy, msx, 1, 2, 100, 0)
ELSE
a$ = nulls$ 'random mouse clicks
'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
StatLineDisplayed = TRUE
p = msy - b1r1
tm = 1
CALL FlashField (msy, 3, 15, 2, 100, 0)
ELSEIF Inbox(b2r1, b2c1, b2r2, b2c2, msy, msx, 0) THEN
StatLineDisplayed = TRUE
p = msy - b1r1
tm = 2
CALL FlashField (msy, b2c1+1, 15, 2, 100, 0)
END IF
IF StatLineDisplayed 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
ITERATE DO
END IF 'Click was inside batting order box
END IF 'Click was not on last row
ELSE 'No click
'Keyboard input
a$ = UCASE$(a$)
msx = 0
msy = 0
END IF
IF a$ = "B" THEN Boxx = TRUE: EXIT DO
IF a$ = "D" AND VisiPopped = FALSE THEN Help = TRUE: EXIT DO
IF a$ = "C" THEN ScoreCard = TRUE: EXIT DO
'Force specific outcomes for testing purposes:
'Ground ball:
' IF a$ = "G" THEN
' COLOR fldfor, fldbac
' fr7 = 100
' fr7 = 201 'shallow fly
' CALL OutOrError
' fr7 = 0
' GOTO WRAPUPTHISAB
' END IF
'Wild Pitch:
' IF a$ = "T" THEN COLOR fldfor, fldbac: GOTO WildPitch
'Home Run:
' IF a$ = "H" THEN
' fr7 = 404
' a$ = CHR$(13)
' END IF
'Single:
' IF a$ = "1" THEN
' fr7 = 401
' a$ = CHR$(13)
' END IF
IF a$ = "Q" AND CmdNoOpt$ <> "Y" THEN
IF VisiPopped THEN 'check UI?
CALL PutScreen(Scr1$, 10+rowO, 8+colO, 21+rowO, 40+colO)
VisiPopped = FALSE
END IF
IF HomePopped THEN
CALL PutScreen(Scr2$, 10+rowO, 42+colO, 21+rowO, 74+colO)
HomePopped = FALSE
END IF
GOSUB CheckForQuit
GOTO AnnounceHitter
END IF
IF a$ = CHR$(13) OR a$ = CHR$(32) OR a$ = CHR$(17) OR a$ = CHR$(196) _
OR a$ = CHR$(217) THEN
IF VisiPopped = FALSE AND HomePopped = FALSE THEN
EXIT DO
END IF
END IF
IF a$ = "O" AND CmdNoOpt$ <> "Y" THEN
IF VisiPopped = FALSE AND HomePopped = FALSE THEN
QPush
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)
QPop
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)
QPRINTs 11+rowO+VisiPtr, 14+colO, CHR$(175), defattr
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)
QPRINTs 11+rowO+HomePtr, 45+colO, CHR$(175), defattr
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, FALSE)
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, FALSE)
SLEEP DelFac * 800
ANx = 0
END IF
' ELSEIF TightAtCorners THEN
' AddtoAnnouncer id, "Infield tight at the corners"
' CALL ScoreBrd
' SLEEP DelFac * 1000
' ANx = 0
' ** HELP SCREEN **
IF Help THEN
QPush
IF Gfx AND RegDsply THEN CALL HideGfx
CALL ShowDoc
IF Gfx AND RegDsply THEN CALL ShowGfx
QPop
GOTO AnnounceHitter
END IF
' ** SCORE CARD **
IF ScoreCard THEN
QPush
GOSUB ShowScoreCard
QPop
IF Gfx AND RegDsply THEN CALL UnfreezeAndRefresh
GOTO AnnounceHitter
END IF
' ** BOX SCORE **
IF Boxx THEN
CALL Box
IF Gfx AND RegDsply THEN CALL HideGfx
QPush
CALL ListFile (CmdWritePath$ +"~BOX.PRN")
QPop
IF Gfx AND RegDsply THEN CALL ShowGfx
itag = 1
GOTO AnnounceHitter
END IF
' ** BULLPEN **
IF BullO THEN
tm = it
GOSUB DisplayPitchCount 'corrupts n, m
CALL ClearInpBuffer
CALL Bullpen(0, it, 0, -1)
IF Gfx AND RegDsply THEN CALL UnfreezeAndRefresh
GOTO AnnounceHitter
END IF
IF BullD THEN
IF amgr(id) = 0 THEN
tm = id
GOSUB DisplayPitchCount
CALL ClearInpBuffer
END IF
ipsv = ip
CALL Bullpen(md, id, 0, 0)
IF Gfx AND RegDsply AND DelFac > 0 THEN
CALL UnfreezeAndRefresh
END IF
IF md = 0 THEN
Bull = FALSE
ELSE
HotBull = TRUE
DidDoubleSwitch = FALSE
CALL AddToScoreCrd (it, ip, "A", "[Relief] ")
'Consider Double-Switch
IF amgr(id) AND BlockDoubleSwitch = FALSE THEN
IF dh = FALSE THEN
DoIt = 2
IF inn = 9 AND iout = 0 THEN
IF ExpectedPitchCount(ip, id) < 22 THEN '1.4 innings
DoIt = FALSE
END IF
ELSEIF ExpectedPitchCount(ip, id) > 32 THEN '2 innings
DoIt = TRUE
END IF
IF DoIt = 2 THEN
IF RND < .50 THEN 'was .75 4.01
DoIt = TRUE
ELSE
DoIt = FALSE
END IF
END IF
IF DoIt THEN CALL DoubleSwitch (DidDoubleSwitch, inplayer, outplayer)
END IF
END IF
IF DidDoubleSwitch THEN zzzDSW = zzzDSW + 1
IF RegDsply THEN
CALL Msg ("26", "0", "0", "01", ipsv, id, 0, 0)
CALL Msg ("26", "0", "0", "02", ip, id, 0, 0)
CALL PostAnnouncer (TRUE, FALSE) 'was 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, FALSE)
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 < .3 THEN
'The sign
CALL Msg ("32", "0", "1", "00", ip, id, man2, team2)
END IF
i = NUMBERON
IF RND < .3 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 < .3 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, FALSE)
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, 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
IF Gfx THEN
CALL EliminateHole(30)
CALL UnfreezeAndRefresh
END IF
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
'pit per game
zzzpitpergame = zzzpitpergame + (PitchersPerGame(1) + PitchersPerGame(2)) / 2
zzzgames = zzzgames + 1
IF itruns(2) > itruns(1) THEN iwin = 2 ELSE iwin = 1
' Did anyone earn a "save"?
' If the Last Pitcher on the winning team is not the winning pitcher,
' then give a save to the last pitcher - maybe
lastpit = iyp(np(iwin), iwin)
IF lastpit <> WPpit THEN
i = mpo(lastpit, iwin) 'outs records by last pitcher
IF (lastpit = QualSave1IP AND iwin = QualSave1ID) THEN
SPteam = iwin
SPpit = lastpit
END IF
IF (lastpit = QualSave2IP AND iwin = QualSave2ID) AND i > 2 THEN
SPteam = iwin
SPpit = lastpit
END IF
IF i > 8 THEN
SPteam = iwin
SPpit = lastpit
END IF
END IF
'Enforce 5 inning rule for starting pitchers
IF iyp(1, iwin) = WPpit THEN
IF mpo(WPpit, iwin) < 15 THEN
WPpit = iyp(2, iwin)
END IF
END IF
'Record Exceptional Performances
ExSw = FALSE
GMx = 0
FOR it = 1 TO 2
ref = 10
DO
IF mpk(ref, it) >= HiLvlSOs THEN
xS$ = STR$(mpk(ref, it)) + " K's"
GOSUB BuildHiLiteMsg
GOSUB SaveHiLite
END IF
ref = ref + 1
IF ref > LastPiAd(it) THEN EXIT DO
LOOP UNTIL ref > TopPitLim
NEXT
FOR it = 1 TO 2
ref = 1
DO
IF mhits(ref, it) >= HiLvlHits THEN
xS$ = STR$(mhits(ref, it)) + " hits"
GOSUB BuildHiLiteMsg
GOSUB SaveHiLite
END IF
IF mrbi(ref, it) >= HiLvlRBIs THEN
xS$ = STR$(mrbi(ref, it)) + " RBI's"
GOSUB BuildHiLiteMsg
GOSUB SaveHiLite
END IF
IF mhr(ref, it) > 0 AND m3b(ref, it) > 0 AND m2b(ref, it) > 0 THEN
IF mhits (ref, it) > (mhr(ref, it) + m3b(ref, it) + m2b(ref, it)) THEN
xS$ = " hit for cycle"
GOSUB BuildHiLiteMsg
GOSUB SaveHiLite
END IF
END IF
IF mhr(ref, it) >= HiLvlHRs THEN
xS$ = STR$(mhr(ref, it)) + " HR's"
GOSUB BuildHiLiteMsg
GOSUB SaveHiLite
END IF
IF msb(ref, it) >= HiLvlSBs THEN
xS$ = STR$(msb(ref, it)) + " SB's"
GOSUB BuildHiLiteMsg
GOSUB SaveHiLite
END IF
IF ref = 9 THEN ref = LastPiAd(it)
ref = ref + 1
LOOP WHILE ref <= MAXPLAYERS
NEXT
FOR it = 1 TO 2
IF ithits(it) <= HiLvlPHits THEN
id = 3 - it
IF ithits(it) = 0 THEN zS$ = "No" ELSE zS$ = LTRIM$(STR$(ithits(it)))
IF np(id) = 1 THEN
Message$ = FULLNAME$(NameRef(iyp(1, id), id)) + ", " + zS$ + "-Hitter"
GOSUB SaveHiLite
ELSEIF ithits(it) = 0 THEN
Message$ = RTRIM$(Names(id)) + ", multi-pit. " + zS$ + "-Hitter"
GOSUB SaveHiLite
END IF
END IF
NEXT
'Former position of the dump star file
IF (MenuOpt$ = "T" OR MenuOpt$ = "E") AND DelFac > 0 THEN
PauseSw = TRUE
END IF
'Former position of showstandings
IF CmdPauseAftGame$ = "Y" THEN PauseSw = TRUE
IF CmdPauseAftDate$ = "Y" THEN
IF LastGameThisDate = TRUE THEN
LastGameThisDate = FALSE
PauseSw = TRUE
END IF
END IF
'Record-keeping
IF CmdStat$ > "!" THEN
GOSUB UpdateStats 'appends to .STS (#3) leaves #3 open
'updates bat and pit in memory
IF MenuOpt$ = "M" OR MMGame OR QuitPending OR PauseSw THEN
GOSUB SaveStatsToDisk 'opens and closes #4 for both bat & pit
Silence = TRUE
END IF
END IF
'Append LineScore to CmdLinF$ file
IF CmdLinF$ > "!" THEN
IF LEFT$(CmdLinF$, 3) = "LPT" THEN
OPEN CmdLinF$ FOR OUTPUT AS #6 LEN = 80
ELSE
OPEN CmdWritePath$ + CmdLinF$ FOR APPEND AS #6 LEN = 80
END IF
PRINT #6, DATE$; " "; TIME$;
PRINT #6, " #"; SimGameCtr + 1;
PRINT #6, STRING$(41, "-");
IF LEN(SCHDate$) THEN
PRINT #6, " "; SCHDate$
ELSE
PRINT #6, STRING$(10, "-"); " "
END IF
xS$ = LINESCORE$(1)
PRINT #6, SPACE$(LEN(xS$) - 9) + " R H E"
PRINT #6, xS$
xS$ = LINESCORE$(2)
PRINT #6, xS$
CLOSE #6
END IF
'Build box-score and append it to CmdStar$ file
IF ExSw AND CmdStar$ > "!" THEN
IF DelFac THEN
QPush
CALL DrawFrm(11, 16, 13 + GMx, 66, defattr, nulls$, nulls$, 1, 0, 0)
FOR i = 1 TO GMx
QPRINTs 11 + i, 18, GMMessage(i), dimattr
NEXT
QPRINTs 12 + GMx, 18, "The Box Score will be saved in " + CmdStar$, dimattr
SLEEP 1500
QPop
IF Gfx THEN
CALL UnfreezeAndRefresh
END IF
END IF
'ForceCLS = TRUE
CALL Box
n = 1
xS$ = CmdStar$
GOSUB AppendBox
REDIM GMMessage(5) AS GLOBAL STRING
END IF
'Build box-score and append it to CmdBoxF$ file
IF CmdBoxF$ > "!" THEN
CALL Box
n = 0
xS$ = CmdBoxF$
GOSUB AppendBox
END IF
'Append Score Card to CmdScrF$ file
IF CmdScrF$ > "!" THEN
REDIM List1(1 TO 300) AS List1Type
CALL LoadScoreCardToList1 (List1(), j) ' j returns items in list
IF LEFT$(CmdScrF$, 3) = "LPT" THEN
xS$ = CmdScrF$
ELSE
xS$ = CmdWritePath$ + CmdScrF$
END IF
CALL DumpList(List1(), j, xS$, TRUE)
ERASE List1
END IF
'Record win or loss for "Standings" - updates WLRec(), WLx, etc.
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
'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 SoundOn THEN
'Purge Announcer queue
ANx = 0
AddToAnnouncer id, "That's the ballgame!"
AddToAnnouncer id, RTRIM$(Names(iwin)) + " takes this one."
CALL PostAnnouncer (TRUE, FALSE)
END IF
IF PauseSw OR MMGame THEN
QPRINTs r+3, c, "Hit ENTER to continue your simulation.", dimattr
END IF
CALL Prompt(1)
IF CmdStat$ > "!" THEN
CLOSE #3 'Close .STS
STSOpen = FALSE 'bat & pit (#4) already saved & closed
END IF
'Wait until a menu key is pressed...
DO
i = 0
DO
IF Gfx AND RegDsply THEN
CALL UnfreezeAndRefresh
END IF
zS$ = WAITKEY$
IF LEN(zS$) = 4 THEN
msx = MOUSEX
msy = MOUSEY
IF msy = ConsRows THEN
zS$ = CHR$(SCREEN(msy, msx))
CALL FlashField (msy, msx, 1, 2, 100, 0)
ELSE
zS$ = nulls$
END IF
ELSE
zS$ = UCASE$(zS$)
msx = 0
msy = 0
END IF
i = INSTR("BCNRSDQ " + CHR$(27) + CHR$(13), zS$)
LOOP UNTIL i
SELECT CASE zS$
CASE "B"
IF Gfx AND RegDsply THEN CALL HideGfx
QPush
CALL Box
CALL ListFile (CmdWritePath$ + "~BOX.PRN")
COLOR deffor, defbac
QPop
IF Gfx AND RegDsply THEN CALL ShowGfx
CASE "C"
QPush
GOSUB ShowScoreCard
QPop
CASE "N", CHR$(27), CHR$(13), CHR$(32)
IF PauseSw THEN
PauseSw = FALSE
ForceCLS = TRUE
GOTO MultiGames
END IF
IF MMGame OR QuitPending THEN '.SCH Files only
CALL Button(17+rowO, 20+colO, errattr, " Want to continue the Simulation? [Y/n] ", 0)
LOCATE 17+rowO, 60+colO
IF YESorNO$(revfor, revbac, deffor, defbac, "Y") = "N" THEN
SlotGameCtr = SlotGameCtr + 1 'counts /n: games in this slot
SimGameCtr = SimGameCtr + 1 'total number of games
CALL SetSCHBookMark
CALL UpdSCHRecord1 (" ")
'Start over with a "clean slate"
GOSUB ResetData
GOTO MenuOptions 'closes all files
ELSE
QuitPending = FALSE
ForceCLS = TRUE
GOTO MultiGames
END IF
END IF
'Normal manual mode
IF STSOpen THEN
CLOSE #3
STSOpen = FALSE
END IF
QPush
CALL SameTeamsSetup (kc, Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
IF kc = KeyF3 THEN
QPop
ELSE
IF FContents$(1) = "Y" THEN
CALL RestFrSnapShot
GOSUB ClearGameData
RANDOMIZE TIMER
REDIM amgr(2) AS GLOBAL LONG
QPop
IF Gfx THEN CALL EliminateHole(32)
IF Gfx THEN CALL HideGfx
PCOPY 2, 1
GOTO PickStarters
ELSE
GOSUB ResetData
QPop
GOTO MenuOptions
END IF
END IF
CASE "R"
IF Gfx AND RegDsply THEN CALL HideGfx
QPush
COLOR deffor, defbac
CLS
CALL ShowStandings (TRUE)
CALL Prompt(1)
QPop
IF Gfx AND RegDsply THEN CALL ShowGfx
CASE "S"
QPush
IF CmdStat$ > "!" THEN
CALL StatsIO (Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
ELSE
CALL Button(18+rowO, 15+colO, errattr, " You didn't specify a statistics file during setup. ", 0)
SLEEP 2000
END IF
QPop
CASE "D"
QPush
CALL ShowDoc
QPop
CASE "Q"
IF MMGame OR QuitPending OR PauseSw THEN
SlotGameCtr = SlotGameCtr + 1 'counts /n: games in this "slot"
SimGameCtr = SimGameCtr + 1 'total number of games
IF SchedSw THEN
CALL SetSCHBookMark
CALL UpdSCHRecord1 (" ")
END IF
END IF
GOTO ReturnToDOS
END SELECT
LOOP
'----------------------------------------------
'Simulation Ends
'Go back to MenuOptions if you want to continue
'----------------------------------------------
' Two-Team / Schedule / Series/ Command-line closing
MultiPromptLoop:
'DrawSBFrame = TRUE
ForceCLS = TRUE
'Debug screen. Use command line switch /debug to get here.
IF CmdDeBug$ = "Y" THEN
CLS
LOCATE 2, 45
PRINT "SB Attempts by Succ.Rate";
LOCATE 3, 45
PRINT "< 40%", zz0;
LOCATE 4, 45
PRINT "40-50:",zz1;
LOCATE 5, 45
PRINT "50-60:",zz2;
LOCATE 6, 45
PRINT "60-70:",zz3;
LOCATE 7, 45
PRINT "70-80:",zz4;
LOCATE 8, 45
PRINT "80-90:",zz5;
LOCATE 9, 45
PRINT "90-99:",zz6;
j = 0
k = 0
LOCATE 2, 2
PRINT "Pos ERR Chances %Err %Chances";
FOR i = 1 TO 9
LOCATE 2+i, 2
Chances = SumErrors(i) + SumPutouts(i) + SumAssists(i)
PRINT i; ":"; SumErrors(i); Chances;
j = j + SumErrors(i)
k = k + Chances
NEXT
LOCATE 12, 2
PRINT "Tot:"; j; k;
FOR i = 1 TO 9
LOCATE 2+i, 23
PRINT FFORMAT$(SumErrors(i) / j * 100, "###.#");
Chances = SumErrors(i) + SumPutouts(i) + SumAssists(i)
PRINT FFORMAT$(Chances / k * 100, "###.#");
NEXT
LOCATE 16, 2
PRINT "SB:"; zzzsb;
LOCATE 17, 2
PRINT "CS:"; zzzcs;
LOCATE 18, 2
PRINT "Catcher Throw. Errs:"; zzzcer;
LOCATE 19, 2
PRINT "DP:"; zzzdp;
LOCATE 20, 2
PRINT "WP:"; zzzwp;
LOCATE 21, 2
PRINT "PB:"; zzzpb;
LOCATE 22, 2
PRINT "PRun:"; zzzprun;
LOCATE 23, 2
PRINT "Dbl-Sw:"; zzzDSW;
LOCATE 3, 68
PRINT "SacOK:"; zzsacok;
LOCATE 4, 68
PRINT "SacFail:"; zzsacfa;
LOCATE 5, 68
PRINT "I-Walk1:"; zzziwalk1;
LOCATE 6, 68
PRINT "I-Walk2:"; zzziwalk2;
LOCATE 7, 68
PRINT "I-Walk3:"; zzziwalk3;
LOCATE 8, 68
PRINT "P-Hit:"; zzzPH;
LOCATE 9, 68
PRINT "St-Att-P:"; zzsabp;
LOCATE 10, 68
PRINT "St-Suc-P:"; zzssbp;
LOCATE 16, 30
PRINT "AvgTeamSpeed:"; zzzSumR / zzzSumN;
LOCATE 17, 30
PRINT "Walk Adj:"; zzzWalkAdj;
LOCATE 18, 30
PRINT "No Walk Adj:"; zzzNoWalkAdj;
LOCATE 19, 30
PRINT "PitchOut:"; zzzPO;
LOCATE 20, 30
PRINT "No PitchOut:"; zzzNoPO;
LOCATE 21, 30
PRINT "Tot shutouts:"; zzzshutouts;
LOCATE 22, 30
PRINT "Pit-p-Game(DAT):"; zzzpitpergame / zzzgames;
LOCATE 15, 65
PRINT "Start. Pit. Removal";
FOR i = 1 TO 8
LOCATE i+15, 64
PRINT i; RemoveReason(i);
NEXT
IF ConsCols > 99 THEN
LOCATE 16, 75: PRINT "Bombed early";
LOCATE 17, 75: PRINT "Bombed (7+)";
LOCATE 18, 75: PRINT "Bombed other";
LOCATE 19, 75: PRINT "Pitch Count";
LOCATE 20, 75: PRINT "C.G. Reduction";
LOCATE 21, 75: PRINT "PH - Gen Reliever";
LOCATE 22, 75: PRINT "PH - Closer";
LOCATE 23, 75: PRINT "PH (All)";
END IF
x$ = WAITKEY$
CLS
END IF
IF RegDsply THEN
COLOR deffor, defbac
IF HoleStatus(32) THEN CALL EliminateHole(32)
IF Gfx THEN CALL GraphHole(32, 11+rowO, 16+colO, 14+rowO, 65+colO)
CALL DrawFrm(11+rowO, 16+colO, 14+rowO, 65+colO, defattr, nulls$, nulls$, 1, 0, 0)
QPRINTs 12+rowO, 21+colO, "Your" + STR$(SimGameCtr) + " game simulation is complete! ", dimattr
QPRINTs 13+rowO, 21+colO, "Select an Option from the list below.", dimattr
ELSE
IF CmdAutoExit$ <> "Y" THEN
QPRINTs 19+rowO, 21+colO, "Your" + STR$(SimGameCtr) + " game simulation is complete! ", defattr
IF Gfx THEN CALL HideGfx
CALL ShowStandings (FALSE)
END IF
END IF
IF CmdAutoExit$ <> "Y" THEN CALL Prompt(1)
IF CmdStat$ > "!" THEN
CLOSE #3 'closes .STS
STSOpen = FALSE
GOSUB SaveStatsToDisk 'opens #4 - dumps pit & bat -- closes #4
END IF
IF CmdAutoExit$ = "Y" THEN GOTO QuickEnd
DO
i = 0
DO
IF Gfx AND RegDsply THEN
CALL UnfreezeAndRefresh
END IF
zS$ = WAITKEY$
IF LEN(zS$) = 4 THEN
msx = MOUSEX
msy = MOUSEY
IF msy = ConsRows THEN
zS$ = CHR$(SCREEN(msy, msx))
CALL FlashField (msy, msx, 1, 2, 100, 0)
ELSE
zS$ = nulls$
END IF
ELSE
zS$ = UCASE$(zS$)
msx = 0
msy = 0
END IF
i = INSTR("BCNRSDQ " + CHR$(27), zS$)
LOOP UNTIL i
SELECT CASE zS$
CASE "B"
IF Gfx THEN CALL HideGfx
QPush
CALL Box
CALL ListFile (CmdWritePath$ + "~BOX.PRN")
COLOR deffor, defbac
QPop
IF Gfx AND RegDsply THEN CALL ShowGfx
CASE "C"
QPush
GOSUB ShowScoreCard
QPop
CASE "N", CHR$(27), CHR$(32)
'Reset vital information and go back to menu
GOSUB ResetData
GOTO MenuOptions
CASE "R"
IF Gfx AND RegDsply THEN CALL HideGfx
QPush
COLOR deffor, defbac
CLS
CALL ShowStandings (TRUE)
CALL Prompt(1)
QPop
IF Gfx AND RegDsply THEN CALL ShowGfx
CASE "S"
QPush
IF CmdStat$ > "!" THEN
CALL StatsIO (Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
ELSE
CALL Button(18+rowO, 15+colO, errattr, " You didn't specify a statistics file during setup. ", 0)
SLEEP 2000
END IF
QPop
CASE "D"
QPush
CALL ShowDoc
QPop
CASE "Q"
GOTO LastChance
END SELECT
LOOP
ReturnToDOS:
IF CmdStat$ > "!" THEN
GOSUB SaveStatsToDisk
END IF
'One Last Chance to return to main menu if this is a schedule situation
LastChance:
CALL Button(17+rowO, 25+colO, defattr, " Return to Main Menu? [y/N] ", 0)
LOCATE 17+rowO, 53+colO
IF YESorNO$(revfor, revbac, deffor, defbac, "N") = "Y" THEN
GOSUB ResetData
GOTO MenuOptions
END IF
QuickEnd:
CLOSE
IF Gfx = FALSE THEN
COLOR 7, 0
END IF
EXIT FUNCTION
' ********************* GOSUBS begin here **************************
SetAutoMgr:
amgr(1) = TRUE
amgr(2) = TRUE
RETURN
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
' LOCATE 8, 37
' PRINT arg$; " = "; LAvg(ndx).LAvgYr; LAvg(ndx).LAvgLg;
' SLEEP 10000
ELSE
'Load Default Case - No .CFG data found
pwbaseF(it) = .0815
pkbaseF(it) = .230
psbaseF(it) = .140
p1baseF(it) = .1575
p2baseF(it) = .0385
p3baseF(it) = .0053
p4baseF(it) = .019
TeamsInLeague(it) = 0
RunsPerGame(it) = 5.0
LeagueRating(it) = 100
LgTotInns(it) = 23107
LgTotHits(it) = 23624
LgTot2B(it) = 4622
LgTot3B(it) = 516
LgTotHR(it) = 2997
LgTotBB(it) = 9847
' LOCATE 8, 37
' PRINT arg$; " = SYS ";
' SLEEP 9000
END IF
' Percentage of hits which are singles, doubles, etc. for this league
bF! = p1baseF(it) + p2baseF(it) + p3baseF(it) + p4baseF(it)
phit1bF(it) = p1baseF(it) / bF!
phit2bF(it) = p2baseF(it) / bF!
phit3bF(it) = p3baseF(it) / bF!
phit4bF(it) = p4baseF(it) / bF!
'Check Column headers for clues to interpret data
x$ = UCASE$(MID$(rec$, 65, 3))
y$ = UCASE$(MID$(rec$, 68, 3))
IF INSTR(x$, "SB") AND INSTR(y$, "CS") THEN
StBSw(it) = -1
ELSEIF INSTR(x$, "SB") THEN
StBSw(it) = 1
ELSE
StBSw(it) = 0
END IF
ERRSw(it) = (UCASE$(MID$(rec$, 62, 2)) = "ER") 'Errors instead of Def. Percentage
END IF
'Second occurence of "*" is ignored (*Pitchers)
'Third occurence of "*" is start of bench (*Bench)
'Fourth occurence of "*" is start of optional information
IF MID$(rec$, 1, 1) = "*" THEN
IF i > 9 THEN 'was 11 for 3 pitchers
IF LastPiAd(it) = 0 THEN
LastPiAd(it) = i
ELSE
x$ = UCASE$(RTRIM$(MID$(rec$, 2)))
IF LEN(x$) THEN
n = PARSECOUNT(x$)
FOR nn = 1 TO n
p$ = RTRIM$(LTRIM$(PARSE$(x$, nn)))
pp$ = LEFT$(p$, 3)
IF pp$ = "PE=" THEN
j = INSTR(p$, "/")
IF j THEN
HBF!(it) = VAL(MID$(p$, 4, j-4)) / 100
HPF!(it) = VAL(MID$(p$, j+1)) / 100
ELSE
HBF!(it) = VAL(MID$(p$, 4)) / 100
HPF!(it) = HBF!(it)
END IF
'Test de-magnification (20% - use .8)
HBF!(it) = 1.00 + (HBF!(it) - 1) * .8
HPF!(it) = 1.00 + (HPF!(it) - 1) * .8
IF HBF!(it) < .20 THEN HBF!(it) = .2
IF HBF!(it) > 5. THEN HBF!(it) = 5.0
IF HPF!(it) < .20 THEN HPF!(it) = .2
IF HPF!(it) > 5. THEN HPF!(it) = 5.0
IF it = 2 THEN
CurrParkBF! = HBF!(2)
CurrParkPF! = HPF!(2)
END IF
END IF
IF it = 2 THEN
IF pp$ = "PH=" THEN
z$ = MID$(p$, 4)
IF LEN(DIR$(z$)) > 0 THEN BackgroundPic$ = z$
END IF
END IF
IF LEFT$(p$, 4) = "DH=Y" THEN
DHDATOvr(it) = -1
END IF
IF LEFT$(p$, 4) = "DH=N" THEN
DHDATOvr(it) = 1
END IF
IF LEFT$(p$, 5) = "GEN=F" THEN
Gender(it) = -1
END IF
IF LEFT$(p$, 4) = "COL=" THEN
z$ = MID$(p$, 5)
j = 0
DO
IF ColorDescTable$(j) = z$ THEN EXIT DO
INCR j
LOOP WHILE j < 16
IF j < 16 THEN
'Foreground color is always 15(bright) unless background is similar
'IF j = 7 OR j = 15 THEN m = 0 ELSE m = 15
SELECT CASE j
CASE 7, 10, 11, 14, 15
m = 0
CASE ELSE
m = 15
END SELECT
TeamAttr(it) = CALCATTR(m, j)
END IF
IF it = 2 THEN
IF TeamAttr(1) = TeamAttr(2) THEN
TeamAttr(1) = CALCATTR(0, 7) 'black on grey
END IF
END IF
END IF
IF LEFT$(p$, 5) = "LOGO=" THEN
z$ = MID$(p$, 6)
IF LEN(DIR$(z$)) > 0 THEN TeamLogo(it) = z$
END IF
NEXT
END IF
END IF
END IF
END IF
'Regular data line:
IF MID$(rec$, 1, 1) <> "*" AND i < MAXPLAYERS THEN
INCR i
DataRef(i, it) = i
DataPlat(i, it) = MID$(rec$, 5, 1)
DataPos(i, it) = VAL(MID$(rec$, 7, 2))
'In case somebody puts a pitcher on the bench, change the position!
IF LastPiAd(it) > 0 AND DataPos(i, it) = 1 THEN DataPos(i, it) = 9
xS$ = MID$(rec$, 10, 18)
IF LEN(FIRSTNAME$(xS$)) THEN
DataName(i, it) = LASTNAME$(xS$) + ", " + FIRSTNAME$(xS$)
ELSE
DataName(i, it) = LASTNAME$(xS$)
END IF
DataAB(i, it) = VAL(MID$(rec$, 28, 3))
IF DataAB(i, it) = 0 THEN DataAB(i, it) = 1
DataHits(i, it) = VAL(MID$(rec$, 32, 3))
Data2B(i, it) = VAL(MID$(rec$, 36, 3))
Data3B(i, it) = VAL(MID$(rec$, 40, 3))
DataHR(i, it) = VAL(MID$(rec$, 44, 3))
DataBB(i, it) = VAL(MID$(rec$, 48, 3))
DataHP(i, it) = MID$(rec$, 51, 1)
DataSO(i, it) = VAL(MID$(rec$, 52, 3))
DataRBI(i, it) = VAL(MID$(rec$, 56, 3))
DataHand(i, it) = MID$(rec$, 60, 1)
DataDef(i, it) = VAL(MID$(rec$, 62, 3)) '/Wins
DataSB(i, it) = VAL(MID$(rec$, 65, 3)) '/Losses (old speed)
DataCS(i, it) = VAL(MID$(rec$, 68, 3)) '/Saves
DataGames(i, it)= VAL(MID$(rec$, 72, 3))
DataCode(i, it) = MID$(rec$, 81, 1) 'Pit. Hit. Code
FOR n = 1 TO 4 '/n=1 Starts
DataGbyP(i, it, n) = VAL(MID$(rec$, 70 + (n * 6), 3))
IF DataGbyP(i, it, n) > 0 THEN
cS$ = MID$(rec$, 74 + (n * 6), 1)
IF UCASE$(cS$) = "D" THEN
DataPosi(i, it, n) = 10
ELSE
DataPosi(i, it, n) = VAL(cS$)
END IF
ELSE
DataPosi(i, it, n) = 0
END IF
NEXT
'Get rid of any games listed as pitcher
FOR n = 1 TO 4
IF DataPosi(i, it, n) = 1 THEN
nn = n
DO WHILE nn < 4
DataPosi(i, it, nn) = DataPosi(i, it, nn+1)
DataGbyP(i, it, nn) = DataGbyP(i, it, nn+1)
INCR nn
LOOP
DataPosi(i, it, 4) = 0
DataGbyP(i, it, 4) = 0
END IF
NEXT
'Batting stats for pitchers
IF i > 9 AND i <= TopPitLim THEN
IF LastPiAd(it) = 0 AND DataPos(i, it) = 1 THEN
DataPBatAB(i, it) = VAL(MID$(rec$, 83, 3)) 'AB
DataPBatHi(i, it) = VAL(MID$(rec$, 87, 3)) 'Hits
DataPBatHR(i, it) = VAL(MID$(rec$, 91, 2)) 'HR
DataPBatBB(i, it) = VAL(MID$(rec$, 94, 3)) 'BB
DataPBatSO(i, it) = VAL(MID$(rec$, 98, 3)) 'SO
END IF
END IF
'Reference attributes
NameRef(i, it) = DataName(i, it)
OrgPos(i, it) = DataPos(i, it)
HandRef(i, it) = DataHand(i, it)
END IF
LOOP
CLOSE #1
Last = i
'Scan pitchers to determine MgrStyle and Data format
pHRind(it) = FALSE
NewStyle(it) = FALSE
NewStyleWithSaves(it) = FALSE
PitchersPerGame(it) = 2.5
l = 0: m = 0: n = 0
FOR i = 10 TO LastPiAd(it)
IF DataHR(i, it) THEN pHRind(it) = TRUE
l = l + DataGames(i, it) 'games
m = m + DataGbyP(i, it, 1) 'starts
n = n + DataCS(i, it) 'saves
NEXT
IF l > 0 AND m > 0 THEN
NewStyle(it) = TRUE
IF n > 0 THEN NewStyleWithSaves(it) = TRUE
PitchersPerGame(it) = l / m
'x$ = "Team" + STR$(it) + " - PitchersPerGame:" + STR$(PitchersPerGame(it))
'CALL ErrorBox (x$)
END IF
'Scan hitters for speed rating (Sum CS for non-pitchers)
m = 0
FOR i = 1 TO 9
IF DataPos(i, it) > 1 THEN m = m + DataCS(i, it)
NEXT
l = 0 'sum speed-ratings
p = 0 'player counter
FOR i = 1 TO Last
IF DataPos(i, it) > 1 THEN
'Calculate a speed-rating
xF! = DataHits(i, it) + DataBB(i, it) - Data2B(i, it) - Data3B(i, it) - DataHR(i, it)
IF xF! < 1 THEN xF! = 1
IF StBSw(it) <> 0 THEN 'Header is "SB & CS" or "SB"
IF m > 0 THEN
n = DataCS(i, it)
ELSE
n = DataSB(i, it) * .27
END IF
'SB%
SpS1! = ((DataSB(i, it) + 3)/(DataSB(i, it) + n + 7) - 0.4) * 20
'Attempts
SpS2! = SQR( (DataSB(i, it) + n) / xF! ) / 0.07
'Triples
SpS3! = Data3B(i, it) / (DataAB(i, it) - DataHR(i, it) - DataSO(i, it) ) / 0.02 * 10
'Some old-timer seasons have so many triples is makes everyone a speed demon...
IF SpS3! > 11. THEN SpS3! = 11.
'Weighted-average with triples 40% less important than
'the other two factors
DataSpeed(i, it) = (SpS1! * 10 + SpS2! * 10 + SpS3! * 6) / 26
IF DataSpeed(i, it) > 9 THEN DataSpeed(i, it) = 9
IF DataSpeed(i, it) < 1 THEN DataSpeed(i, it) = 1
ELSE 'Header is presumably "S"
DataSpeed(i, it) = VAL(MID$(rec$, 66, 2))
DataSB(i, it) = 0
DataCS(i, it) = 0
IF DataSpeed(i, it) < 1 THEN DataSpeed(i, it) = 1
END IF
l = l + DataSpeed(i, it)
INCR p
END IF
NEXT
TeamSpeed(it) = l / p
IF TeamSpeed(it) < 1.0 THEN TeamSpeed(it) = 1.0 '2.5
'LOCATE 10, 20
'print " ";
'locate 10, 20
'print "team speed "; DataFil(it); TeamSpeed(it);
'PauseIt
'Scan for Duplicate Last Names and record them in the DLN array
FOR i = 1 TO Last - 1
xS$ = LASTNAME$(NameRef(i, it))
FOR j = (i + 1) TO Last
yS$ = LASTNAME$(NameRef(j, it))
IF xS$ = yS$ THEN
DLN(i, it) = TRUE
DLN(j, it) = TRUE
END IF
NEXT
NEXT
'See if any pitchers are also on the bench or in lineup in the .DAT
DupNameTeam(it) = FALSE
FOR i = 10 TO LastPiAd(it)
SearchName$ = DataName(i, it)
c3 = SearchDAT(1, 9, it, SearchName$, 0)
IF c3 THEN DupNameTeam(it) = TRUE: EXIT FOR
c4 = SearchDAT(LastPiAd(it) + 1, Last, it, SearchName$, 0)
IF c4 THEN DupNameTeam(it) = TRUE: EXIT FOR
NEXT
'Is there a pitcher's slot (or DH) in the starting lineup?
m = FALSE
FOR i = 1 TO 9
IF DataPos(i, it) = 1 OR DataPos(i, it) = 10 THEN m = TRUE : EXIT FOR
NEXT
IF m = FALSE THEN
MyBeep
x$ = "Team Data-File: " + CmdPath$ + DataFil(it) + "|"
x$ = x$ + "No pitcher or DH in Lineup|"
x$ = x$ + "This is a problem. Please correct the .DAT file.|"
x$ = x$ + "(Make sure a '1' is in column 8 in the pitcher's batting|"
x$ = x$ + "slot if a DH is not used in your default line-up.)"
CALL ErrorBox(x$)
END IF
RETURN
SearchLAvg:
' LAvg must be DIMed
' In: arg$
' Out: ndx, FoundSw
' Don't use "i" in here!
FoundSw = FALSE
ndx = 1
DO UNTIL ndx > LAvgNdx OR ndx > 300
xS$ = LAvg(ndx).LAvgYr + LAvg(ndx).LAvgLg
IF arg$ = xS$ THEN FoundSw = TRUE: RETURN
ndx = ndx + 1
LOOP
' "YYYYL" not found in table. Does "DEF L" exist in table?
newarg$ = "DEF " + MID$(arg$, 5, 1)
ndx = 1
DO UNTIL ndx > LAvgNdx OR ndx > 300
xS$ = LAvg(ndx).LAvgYr + LAvg(ndx).LAvgLg
IF newarg$ = xS$ THEN FoundSw = TRUE: RETURN
ndx = ndx + 1
LOOP
RETURN
ShowScoreCard:
REDIM List1(1 TO 300) AS List1Type
CALL LoadScoreCardToList1 (List1(), j) 'j returns items in list
rr = ConsRows - 9
re = ConsRows - 2
c1 = (ConsCols - 78) \ 2 '68
c2 = ConsCols - c1
IF Gfx THEN CALL GraphHole(30, 6, c1, re, c2)
CALL DrawFrm(6, c1, re, c2, defattr, "Score Card", "ESC PgUp PgDown [P]rint [F]ile", 0, 0, 1)
QPRINTs MidRow, c2, 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$
' 32, 6, c1, re, c2, dimattr, revattr, Pick, RetKey, xS$, mous, ms$)
CALL PickFromList(List1(), j, rr, 2, 37, 6, c1, re, c2, dimattr, revattr, Pick, RetKey, xS$, mous, ms$)
IF Gfx THEN CALL EliminateHole(30)
ERASE List1
RETURN
OpenStatFiles:
REDIM NameList$(MAXPLAYERS)
'If CmdStat$ already exists, check for current format
IF LEN(DIR$(CmdWritePath$ + CmdStat$ + ".STP")) THEN
CALL CheckForValidFile (CmdWritePath$ + CmdStat$ + ".STP", 126, Valid1)
ELSE
Valid1 = TRUE
END IF
IF LEN(DIR$(CmdWritePath$ + CmdStat$ + ".STB")) THEN
CALL CheckForValidFile (CmdWritePath$ + CmdStat$ + ".STB", 162, Valid2)
ELSE
Valid2 = TRUE
END IF
IF NOT Valid1 OR NOT Valid2 THEN
MyBeep
x$ = " Hmmm. The stat file you selected appears to have been | generated from "
x$ = x$ + "an older version of SBS and cannot be used | with this version. "
x$ = x$ + "Returning to the main menu."
CALL ErrorBox(x$)
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 1500) 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
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, a$, revattr
' CALL ChangeAttribute (r+1, cp, 5, attr)
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, a$, revattr
' CALL ChangeAttribute (r+2, cp, 5, attr)
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, a$, revattr
' CALL ChangeAttribute (r+1, cb, 5, attr)
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, a$, revattr
' CALL ChangeAttribute (r+2, cb, 5, attr)
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, 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 = BitmapParam(sFileName$, %IMAGE_WIDTH_HEIGHT)
lWidth = LOWRD(lResult)
lHeight= HIWRD(lResult)
lResult = StretchBitmap(sFileName$, 1024, 512)
ELSE
lResult = ImageParam(sFileName$, %IMAGE_WIDTH_HEIGHT)
lWidth = LOWRD(lResult)
lHeight= HIWRD(lResult)
lResult = StretchImage(sFileName$, 1024, 512)
END IF
'The graphic window is from row 6 to (ConsRows - 1),
'so there are (ConsRows - 1) - 6 + 1 rows inside the window.
' (ConsRows - 6)
'The first row is 1
'The last row is (ConsRows - 6)
r = DrawToRow (ConsRows-6, ConsRows-6)
c = DrawToCol (2, ConsCols)
GfxFontName "Arial"
GfxFontSize 13
DrawFrom c, r-1 'r+2
x$ = "Photo credit: " + PhotoCredit$
DrawTextRow x$, 0
ELSE
ObsD = -130: ObsY = 0: ObsH = 350: ObsTz = -50: ObsTy = 0
END IF
RETURN
DefineBigBitmap:
m = LEN(DIR$(CmdPic$))
IF m THEN
ConsoleGfx 1, 1, ConsCols, ConsRows
sFileName$ = CmdPic$
IF UCASE$(RIGHT$(sFileName$, 3)) = "BMP" THEN
lResult = BitmapParam(sFileName$, %IMAGE_WIDTH_HEIGHT)
lWidth = LOWRD(lResult)
lHeight= HIWRD(lResult)
lResult = StretchBitmap(sFileName$, 1024, 512)
ELSE
lResult = ImageParam(sFileName$, %IMAGE_WIDTH_HEIGHT)
lWidth = LOWRD(lResult)
lHeight= HIWRD(lResult)
lResult = StretchImage(sFileName$, 1024, 512)
END IF
IF PhotoCredit$ > "!" THEN
r = DrawToRow (ConsRows-1, ConsRows)
c = DrawToCol (2, ConsCols)
GfxFontName "Arial"
GfxFontSize 14
DrawFrom c, r+4
x$ = "Photo credit: " + PhotoCredit$
DrawTextRow x$, 0
END IF
END IF
RETURN
ChangePhotoManually:
CmdChangePhoto$ = "N"
SaveBackgroundPic$ = BackgroundPic$
'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)
IF Gfx THEN CALL GraphHole(30, 2+rowO, 3+colO, 21+rowO, 78+colO)
CALL SelectPhotoIO(List1(), choices, BackgroundPic$)
IF Gfx THEN CALL EliminateHole(30)
IF BackgroundPic$ = "" THEN 'Make no changes
BackgroundPic$ = SaveBackgroundPic$
IF Gfx THEN CALL UnfreezeAndRefresh
RETURN
END IF
IF BackgroundPic$ <> "--NONE--" AND BackgroundPic$ > "!" THEN 'Real picture selected
r = 17 + rowO
c = 20 + colO
QPRINTs r, c, " One moment please, stretching photograph... ", defattr
GOSUB GetPhotoSpecs
ELSE 'Apparently selected NONE
PhotoCredit$ = ""
Gfx = FALSE 'test
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.3"
IF winver < 2 THEN ConsoleIcon %IDI_Console
DeleteWindowMenuItem %MENUITEM_TOOLBAR
DeleteWindowMenuItem %MENUITEM_CLOSE
ConsoleToolbar %OFF, %NO_CHANGE
ConsoleWindow %SHOW
' TEST
'ConsoleWindow %MINIMIZE
'ConsoleWindow %RESTORE
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
'PRINT "result = "; result
END FUNCTION
FUNCTION DECRYPT$ (x$)
'Dim z$, c$, i, n
z$ = ""
FOR i = 1 TO LEN(x$)
c$ = MID$(x$, i, 1)
n = ASC(c$) XOR 171
z$ = z$ + CHR$(n)
NEXT
DECRYPT$ = z$
END FUNCTION
FUNCTION DEFPCT!(n) STATIC
IF DataPos(n, id) = 1 THEN
defperF! = NormDEF(1)
GOTO ExitDEFPCT
ELSEIF ERRSw(id) THEN
DatErrors = DataDef(n, id)
' Adj! = (1.0 - pkbaseF(id)) / .753 'League K's vs 2003 NL Standard
Adj! = (1.0 - pkbaseF(id)) / .7496 'League K's vs 1998 NL Standard
'Results < 1 result in more errors
'Results > 1 result in less errors
'Exaggerate the result a little for low-strike-out leagues
'(We seem to get too many errors in the AL if we don't)
IF dh THEN
Adj! = Adj! + .06
END IF
'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
' PitchCount = 4.81 * SOs& + 5.14 * BBs& + 3.27 * (Hits& + HB&) + 3.16 * (TotOuts& - SOs&)
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 appearances
MostlyStarter = 0
MostlyReliever = 0
x! = Starts / Games
IF x! > .66 THEN MostlyStarter = TRUE
IF x! < .33 THEN MostlyReliever = TRUE
IF np(tm) = 1 THEN 'starter
IF MostlyReliever THEN
PitchesExpected = 105
ELSE
ReliefInnings = (Games - Starts) * 1.7
StartInnings = TotalInnings - ReliefInnings
StartPitches& = TotalPitches& * (StartInnings / TotalInnings)
PitchesExpected = StartPitches& / Starts
IF PitchesExpected < 64 THEN PitchesExpected = 64 '4 innings
IF PitchesExpected > 145 THEN PitchesExpected = 145 '9+ innings
END IF
ELSE 'reliever
IF MostlyStarter THEN
PitchesExpected = 50
ELSE
StartInnings = Starts * 5.7
ReliefInnings = TotalInnings - StartInnings
ReliefPitches& = TotalPitches& * (ReliefInnings / TotalInnings)
PitchesExpected = ReliefPitches& / (Games - Starts)
IF PitchesExpected < 15 THEN PitchesExpected = 15 '1 inning
IF PitchesExpected > 116 THEN PitchesExpected = 116 '7 innings
END IF
END IF
ELSE 'Almost all appearances are starts
IF Games > 0 THEN 'Or all appearances are relief
PitchesExpected = TotalPitches& / Games
IF PitchesExpected < 15 THEN PitchesExpected = 15 '1 inning
ELSE
PitchesExpected = 116
END IF
END IF
IF PitchersPerGame(tm) < 2.5 AND CmdDeadBallAdj$ = "Y" 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
'EXPERIMENTAL 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 > 1499 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
'f1$ = "\\\ \ # # # # \ \ \\\ \ # # # # \ \"
'f2$ = "\\\ \ # # # # \ \ \ \"
'f3$ = " \ \ \\\ \ # # # # \ \"
'f4$ = " \ \ \ \"
PRINT #OUTHdl, "~"; LEFT$(Names(1), 11) + " AB R H B W K"; TAB(47);LEFT$(Names(2), 11) + " AB R H B W K"
lin = 1
DO UNTIL lin > TotLines
Txt1$ = TxtTbl(1,lin).ScrLine
Txt2$ = TxtTbl(2,lin).ScrLine
Pos1$ = BoxPosit(1,lin).ScrLine
Pos2$ = BoxPosit(2,lin).ScrLine
IF Txt1$ < " " THEN Txt1$ = " "
IF Txt2$ < " " THEN Txt2$ = " "
IF BoxRefByLine(1, lin) > 0 THEN
rf1 = BoxRefByLine(1, lin)
player = rf1
team = 1
GOSUB BSGetName
x1S$ = LEFT$(RS$, 11)
END IF
IF BoxRefByLine(2, lin) > 0 THEN
rf2 = BoxRefByLine(2, lin)
player = rf2
team = 2
GOSUB BSGetName
x2S$ = LEFT$(RS$, 11)
END IF
a$ = SPACE$(90)
IF BoxRefByLine(1, lin) > 0 AND BoxRefByLine(2, lin) > 0 THEN
MID$(a$, 1, 2) = Pos1$
MID$(a$, 3, 11) = x1S$
MID$(a$, 15, 1) = LTRIM$(STR$(mab(rf1, 1)))
MID$(a$, 17, 1) = LTRIM$(STR$(mruns(rf1, 1)))
MID$(a$, 19, 1) = LTRIM$(STR$(mhits(rf1, 1)))
MID$(a$, 21, 1) = LTRIM$(STR$(mrbi(rf1, 1)))
MID$(a$, 23, 1) = LTRIM$(STR$(mbb(rf1, 1)))
MID$(a$, 25, 1) = LTRIM$(STR$(mso(rf1, 1)))
MID$(a$, 27, 18) = Txt1$
MID$(a$, 46, 2) = Pos2$
MID$(a$, 48, 11) = x2S$
MID$(a$, 60, 1) = LTRIM$(STR$(mab(rf2, 2)))
MID$(a$, 62, 1) = LTRIM$(STR$(mruns(rf2, 2)))
MID$(a$, 64, 1) = LTRIM$(STR$(mhits(rf2, 2)))
MID$(a$, 66, 1) = LTRIM$(STR$(mrbi(rf2, 2)))
MID$(a$, 68, 1) = LTRIM$(STR$(mbb(rf2, 2)))
MID$(a$, 70, 1) = LTRIM$(STR$(mso(rf2, 2)))
MID$(a$, 72, 18) = Txt2$
PRINT #OUTHdl, a$
ELSEIF BoxRefByLine(1, lin) > 0 THEN
MID$(a$, 1, 2) = Pos1$
MID$(a$, 3, 11) = x1S$
MID$(a$, 15, 1) = LTRIM$(STR$(mab(rf1, 1)))
MID$(a$, 17, 1) = LTRIM$(STR$(mruns(rf1, 1)))
MID$(a$, 19, 1) = LTRIM$(STR$(mhits(rf1, 1)))
MID$(a$, 21, 1) = LTRIM$(STR$(mrbi(rf1, 1)))
MID$(a$, 23, 1) = LTRIM$(STR$(mbb(rf1, 1)))
MID$(a$, 25, 1) = LTRIM$(STR$(mso(rf1, 1)))
MID$(a$, 27, 18) = Txt1$
MID$(a$, 72, 18) = Txt2$
PRINT #OUTHdl, a$
ELSEIF BoxRefByLine(2, lin) > 0 THEN
MID$(a$, 27, 18) = Txt1$
MID$(a$, 46, 2) = Pos2$
MID$(a$, 48, 11) = x2S$
MID$(a$, 60, 1) = LTRIM$(STR$(mab(rf2, 2)))
MID$(a$, 62, 1) = LTRIM$(STR$(mruns(rf2, 2)))
MID$(a$, 64, 1) = LTRIM$(STR$(mhits(rf2, 2)))
MID$(a$, 66, 1) = LTRIM$(STR$(mrbi(rf2, 2)))
MID$(a$, 68, 1) = LTRIM$(STR$(mbb(rf2, 2)))
MID$(a$, 70, 1) = LTRIM$(STR$(mso(rf2, 2)))
MID$(a$, 72, 18) = Txt2$
PRINT #OUTHdl, a$
ELSE
MID$(a$, 27, 18) = Txt1$
MID$(a$, 72, 18) = Txt2$
PRINT #OUTHdl, a$
END IF
INCR lin
LOOP
'Pitcher stats
i = 2
j = 15
REDIM PitTbl(i, j) AS PitTblType
PRINT #OUTHdl,
PRINT #OUTHdl, "~Pitcher IP H R ER BB SO"; TAB(47); "Pitcher IP H R ER BB SO"
'f$ = "\ \## \ \ ## ## ## ## ##"
Savlin = 0
FOR t = 1 TO 2
lin = 0
FOR n = 1 TO np(t)
p = iyp(n, t)
'See if we've already done this pitcher.
'It's possible that a pitcher can enter a game more than once...
i = 1
Found = FALSE
DO WHILE i < n
IF p = iyp(i, t) THEN
Found = TRUE
EXIT DO
END IF
INCR i
LOOP
IF Found THEN ITERATE FOR
IF WPteam = t AND WPpit = p THEN
flag$ = " W"
ELSEIF LPteam = t AND LPpit = p THEN
flag$ = " L"
ELSEIF SPteam = t AND SPpit = p THEN
flag$ = " S"
ELSE
flag$ = " "
END IF
y$ = " "
IF flag$ > " " THEN
IF CmdStat$ > "!" THEN
Find$ = League(t) + PADRIGHT$(Names(t), 12) + PADRIGHT$(NameRef(p, t), 16)
TotalRecs = PSum(0).PGameCtr
CALL BinarySearchP (PSum(), 1, 29, 1, TotalRecs, Find$, FoundAt, mini)
IF FoundAt THEN
IF flag$ = " W" THEN
w = PSum(FoundAt).PWin
l = PSum(FoundAt).PLoss
y$ = "(" + LTRIM$(STR$(w)) + "-" + LTRIM$(STR$(l)) + ")"
END IF
IF flag$ = " L" THEN
w = PSum(FoundAt).PWin
l = PSum(FoundAt).PLoss
y$ = "(" + LTRIM$(STR$(w)) + "-" + LTRIM$(STR$(l)) + ")"
END IF
IF flag$ = " S" THEN
s = PSum(FoundAt).PSave
y$ = "(" + LTRIM$(STR$(s)) + ")"
END IF
END IF
END IF
END IF
player = p
team = t
GOSUB BSGetName
xS$ = RTRIM$(RS$ + flag$)
L = LEN(y$)
IF L > 1 THEN
d = L + LEN(xS$)
IF d > 18 THEN xS$ = LEFT$(xS$, LEN(xS$) - (d-18))
xS$ = xS$ + y$
END IF
i = mpo(p, t) MOD 3
SELECT CASE i
CASE 0
zS$ = " "
CASE 1
zS$ = "1/3"
CASE 2
zS$ = "2/3"
END SELECT
INCR lin
' f$ = "\ \## \ \ ## ## ## ## ##"
a$ = SPACE$(39)
MID$(a$, 1, 18) = xS$
MID$(a$, 19, 2) = FFORMAT$(INT(mpo(p,t) / 3) , "##")
MID$(a$, 22, 3) = zS$
MID$(a$, 26, 2) = LFORMAT$(mph(p,t), "##")
MID$(a$, 29, 2) = LFORMAT$(mpr(p,t), "##")
MID$(a$, 32, 2) = LFORMAT$(mper(p,t), "##")
MID$(a$, 35, 2) = LFORMAT$(mpw(p,t), "##")
MID$(a$, 38, 2) = LFORMAT$(mpk(p,t), "##")
PitTbl(t, lin).ScrLine = a$
NEXT n
IF lin > Savlin THEN Savlin = lin
NEXT t
FOR i = 1 TO Savlin
Txt1$ = PitTbl(1, i).ScrLine
Txt2$ = PitTbl(2, i).ScrLine
IF Txt1$ < " " THEN Txt1$ = " "
IF Txt2$ < " " THEN Txt2$ = " "
PRINT #OUTHdl, Txt1$; TAB(46); Txt2$
NEXT
i = 2
j = 15
REDIM PitTbl (i, j) AS PitTblType
Savlin = 0
FOR t = 1 TO 2
lin = 0
FOR i = 10 TO TopPitLim
L = mpBS(i, t)
IF L THEN
INCR lin
IF lin = 1 THEN PitTbl(t, lin).ScrLine = "Blown Save:"
player = i
team = t
GOSUB BSGetName
xS$ = LEFT$(RS$, 11)
IF L > 1 THEN xS$ = xS$ + "(" + LTRIM$(STR$(L)) + ")"
INCR lin
PitTbl(t, lin).ScrLine = " " + xS$
END IF
NEXT
L = LEN(WildPit(t))
IF L THEN
INCR lin
PitTbl(t, lin).ScrLine = "WP:"
n = 1
DO WHILE n < L
r = VAL(MID$(WildPit(t), n, 2))
player = r
team = t
GOSUB BSGetName
xS$ = LEFT$(RS$, 11)
INCR lin
PitTbl(t, lin).ScrLine = " " + xS$
n = n + 2
LOOP
END IF
L = LEN(PassedB(t))
IF L THEN
INCR lin
PitTbl(t, lin).ScrLine = "Passed Ball:"
n = 1
DO WHILE n < L
r = VAL(MID$(PassedB(t), n, 2))
player = r
team = t
GOSUB BSGetName
xS$ = LEFT$(RS$, 11)
INCR lin
PitTbl(t, lin).ScrLine = " " + xS$
n = n + 2
LOOP
END IF
L = LEN(HitByPit(t))
IF L THEN
INCR lin
PitTbl(t, lin).ScrLine = "HBP:"
n = 1
DO WHILE n < L
r = VAL(MID$(HitByPit(t), n, 2))
player = r
team = t
GOSUB BSGetName
xS$ = LEFT$(RS$, 11)
r = VAL(MID$(HitByPit(t), n + 2, 2))
player = r
team = 3 - t
GOSUB BSGetName
yS$ = LEFT$(RS$, 11)
INCR lin
PitTbl(t, lin).ScrLine = " " + xS$ + "(" + yS$ + ")"
n = n + 4
LOOP
END IF
IF lin > Savlin THEN Savlin = lin
NEXT
IF Savlin THEN PRINT #OUTHdl,
FOR i = 1 TO Savlin
Txt1$ = PitTbl(1, i).ScrLine
Txt2$ = PitTbl(2, i).ScrLine
IF Txt1$ < " " THEN Txt1$ = " "
IF Txt2$ < " " THEN Txt2$ = " "
PRINT #OUTHdl, Txt1$; TAB(46); Txt2$
NEXT
'Print line score
PRINT #OUTHdl,
xS$ = LINESCORE$(1)
i = LEN(xS$) - 6
PRINT #OUTHdl, TAB(i); "R H E"
PRINT #OUTHdl, xS$
xS$ = LINESCORE$(2)
PRINT #OUTHdl, xS$
PRINT #OUTHdl,
CLOSE #OUTHdl
'Return
ERASE TxtTbl
ERASE BoxPosit
ERASE PitTbl
EXIT SUB
BSGetName:
RS$ = FLASTNAMER$(player, team)
RETURN
LookUpBatStats:
Find$ = League(t) + PADRIGHT$(Names(t), 12) + PADRIGHT$(NameRef(i, t), 16)
TotalRecs = BSum(0).BGameCtr
FoundAt = 0
CALL BinarySearchB (BSum(), 1, 29, 1, TotalRecs, Find$, FoundAt, mini)
RETURN
ErrorTrap:
LOCATE 10, 30
PRINT "ERROR: BoxScore"; ERRCLEAR
x$ = WAITKEY$
END SUB
SUB BubbleSortFlt (ArrayFlt!(), ArrayStr() AS SortStrType, O$) 'STATIC
DO
OutOfOrder = 0
FOR x = 1 TO UBOUND(ArrayFlt!) - 1
IF O$ = "A" THEN
IF ArrayFlt!(x) > ArrayFlt!(x + 1) THEN
SWAP ArrayFlt!(x), ArrayFlt!(x + 1)
SWAP ArrayStr(x).SSItem, ArrayStr(x + 1).SSItem
OutOfOrder = -1
END IF
ELSE
IF ArrayFlt!(x) < ArrayFlt!(x + 1) THEN
SWAP ArrayFlt!(x), ArrayFlt!(x + 1)
SWAP ArrayStr(x).SSItem, ArrayStr(x + 1).SSItem
OutOfOrder = -1
END IF
END IF
NEXT
LOOP WHILE OutOfOrder
END SUB
SUB BubbleSortInt (ArrayInt(), ArrayStr() AS SortStrType) 'STATIC
DO
OutOfOrder = 0
FOR x = 1 TO UBOUND(ArrayInt) - 1
IF ArrayInt(x) < ArrayInt(x + 1) THEN
' < is descending
' > is ascending
SWAP ArrayInt(x), ArrayInt(x + 1)
SWAP ArrayStr(x).SSItem, ArrayStr(x + 1).SSItem
OutOfOrder = -1
END IF
NEXT
LOOP WHILE OutOfOrder
END SUB
SUB BuildBullpenPlyList (tm, PlyList() AS PlyListType, Av, CalledFromOffense)
Av = 0
IF NewStyle(tm) AND LastPiAd(tm) > 10 THEN 'New Style has "Games" and "Starts"
'Put Relievers in first, then starters if appropriate
'relief1 is "normal" address of 1st reliever in .DAT
'If less than 6 pitchers, relief1 is the last pitcher
relief1 = MIN&(15, LastPiAd(tm))
j = relief1
DO
Pass = 0
IF j < relief1 THEN
IF DataGames(j, tm) > DataGbyP(j, tm, 1) THEN '+2
Pass = -1
END IF
ELSE
Pass = -1
END IF
IF Pass THEN
IF Av < 25 THEN
a$ = BUBuildLine$ (j, tm, CalledFromOffense)
INCR Av
PlyList(Av).Item = a$
PlyList(Av).Ref = j
END IF
END IF
INCR j
IF j > LastPiAd(tm) THEN j = 10
IF j = relief1 THEN EXIT DO
LOOP
ELSE
'Old Style - we know nothing about Games and Starts
IF LastPiAd(tm) > 17 THEN 'More than 8 pitchers [take #14+ ]
n1 = 14
ELSE
n1 = 10 '8 or less pitchers [take all]
END IF
FOR j = n1 TO LastPiAd(tm)
IF Av < 25 THEN
a$ = BUBuildLine$ (j, tm, CalledFromOffense)
INCR Av
PlyList(Av).Item = a$
PlyList(Av).Ref = j
END IF
NEXT
END IF
END SUB
SUB BuildTeamWin (tm, beg, endd, hdg, pend)
REGISTER j AS INTEGER, k AS INTEGER, m AS INTEGER
wlim = MAXPLAYERS + 4
REDIM VirtualWin(wlim) AS GLOBAL VirtualWinType
Bhdg = FALSE
Phdg = FALSE
pend = endd
FOR j = beg TO endd
jj = j
IF DataName(j, tm) < "!" THEN pend = j - 1: EXIT FOR
IF DataPos(j, tm) = 1 AND j > 9 AND j <= LastPiAd(tm) THEN 'Pitchers
IF hdg THEN
IF Phdg = FALSE THEN
IF m < wlim THEN
INCR m
VirtualWin(m).item = "~ Name L/R W L S G St Inn Hits HR BB SO ERA"
END IF
Phdg = TRUE
Bhdg = FALSE
END IF
END IF
IF iused(j, tm) THEN flag$ = "x" ELSE flag$ = " "
a$ = SPACE$(70)
MID$(a$, 1, 2) = LFORMAT$(jj, "##")
MID$(a$, 4, 1) = flag$
MID$(a$, 5, 17) = DataName(j, tm)
MID$(a$, 24, 1) = DataHand(j, tm)
MID$(a$, 28, 2) = LFORMAT$(DataDef(j, tm), "##")
MID$(a$, 31, 2) = LFORMAT$(DataSB(j, tm), "##")
MID$(a$, 34, 2) = LFORMAT$(DataCS(j, tm), "##")
MID$(a$, 37, 2) = LFORMAT$(DataGames(j, tm), "##")
MID$(a$, 41, 2) = LFORMAT$(DataGbyP(j, tm, 1), "##")
MID$(a$, 45, 4) = LFORMAT$(DataAB(j, tm), "####")
MID$(a$, 51, 4) = LFORMAT$(DataHits(j, tm), "####")
MID$(a$, 56, 2) = LFORMAT$(DataHR(j, tm), "##")
MID$(a$, 59, 3) = LFORMAT$(DataBB(j, tm), "###")
MID$(a$, 63, 3) = LFORMAT$(DataSO(j, tm), "###")
MID$(a$, 67, 4) = FFORMAT$(DataRBI(j, tm)/100, "#.##")
ELSE
IF hdg THEN 'Position Players
IF Bhdg = FALSE THEN
IF m < wlim THEN
INCR m
VirtualWin(m).item = "~ Name Pos AB Hit 2B 3B HR RBI BB SO B S SB CS Def Avg Games@Pos"
IF ERRSw(tm) THEN MID$(VirtualWin(m).item, 65, 3) = "ERR"
END IF
Bhdg = TRUE
Phdg = FALSE
END IF
END IF
IF DataAB(j, tm) = 0 THEN
BAF! = 0
ELSE
BAF! = DataHits(j, tm) / DataAB(j, tm)
END IF
IF iused(j, tm) THEN flag$ = "x" ELSE flag$ = " "
a$ = SPACE$(114)
MID$(a$, 1, 2) = LFORMAT$(jj, "##")
MID$(a$, 4, 1) = flag$
MID$(a$, 5, 15) = DataName(j, tm)
MID$(a$, 21, 2) = Pos(DataPos(j, tm))
MID$(a$, 24, 3) = LFORMAT$(DataAB(j, tm), "###")
MID$(a$, 28, 3) = LFORMAT$(DataHits(j, tm), "###")
MID$(a$, 32, 3) = LFORMAT$(Data2B(j, tm), "###")
MID$(a$, 36, 2) = LFORMAT$(Data3B(j, tm), "##")
MID$(a$, 39, 2) = LFORMAT$(DataHR(j, tm), "##")
MID$(a$, 42, 3) = LFORMAT$(DataRBI(j, tm), "###")
MID$(a$, 46, 3) = LFORMAT$(DataBB(j, tm), "###")
MID$(a$, 50, 3) = LFORMAT$(DataSO(j, tm), "###")
MID$(a$, 54, 1) = DataHand(j, tm)
MID$(a$, 56, 1) = LFORMAT$(DataSpeed(j, tm), "#")
MID$(a$, 58, 3) = LFORMAT$(DataSB(j, tm), "###")
MID$(a$, 62, 2) = LFORMAT$(DataCS(j, tm), "##")
MID$(a$, 65, 3) = LFORMAT$(DataDef(j, tm), "###")
MID$(a$, 69, 4) = FFORMAT$(BAF!, ".###")
b$ = ""
FOR k = 1 TO 4
IF DataGByP(j,tm,k) > 0 THEN
b$ = b$ + LFORMAT$(DataGbyP(j,tm,k), "####") + " at"
IF DataPosi(j,tm,k) = 10 THEN
b$ = b$ + " DH"
ELSE
b$ = b$ + LFORMAT$(DataPosi(j,tm,k), "###")
END IF
END IF
NEXT
bl = LEN(b$)
IF bl THEN
MID$(a$, 73, bl) = b$
END IF
END IF
IF m < wlim THEN
INCR m
VirtualWin(m).item = a$
END IF
NEXT
END SUB
SUB Bullpen (n, tm, ForceN, CalledFromOffense) STATIC
'Be aware that we pass back "n" and "tm", so don't use them as variables in this routine
REGISTER i AS INTEGER
'Check if we already have selected pitcher
IF ForceN THEN
n = ForceN
GOTO BU150
END IF
IF CalledFromOffense = FALSE AND amgr(tm) THEN GOTO BU1000
REDIM PlyList(1 TO 25) AS PlyListType 'was 14
'Build list of relief pitchers
CALL BuildBullpenPlyList (tm, PlyList(), Av, CalledFromOffense) 'Returns PlyList() and Av
'Save the screen
QPush
r = MIN&(Av+7+rowO, ConsRows-1)
IF Gfx THEN CALL GraphHole(30, 5+rowO, 5+colO, r+1, 77+colO)
BU10:
'Display the pitchers selected
CALL Drawfrm(5+rowO, 5+colO, r, 75+colO, defattr, "'" + RTRIM$(Names(tm)) + " Bullpen", "Dbl-click (or Enter) selection or ESC", 1, 0, 2)
QPRINTs 6+rowO, 7+colO, " Name L/R W L S G St Inn Hits BB SO ERA", defattr
'Row and Col are coordinates of the upper-left corner of the FRAME
CALL PickFromPlyList (PlyList(), Av, r-7-rowO, 1, 66, 6+rowO, 5+colO, r, 75+colO, dimattr, revattr, Pick, RetKey, nulls$, 0)
IF Pick > 0 THEN
n = PlyList(Pick).Ref
ELSE
n = 0
ERASE PlyList
GOTO BU999
END IF
r2 = MIN&(Av+9+rowO, ConsRows-1)
IF iused(n, tm) THEN
CALL PopMsg(r2, 20+colO, " Sorry, that pitcher has already been used. ", errattr, 2, kc)
GOTO BU10
END IF
IF SimDaysOff(n, tm) > 0 AND DaysOffRule = TRUE THEN
x$ = " This pitcher needs the day off. | Hit 'Y' to select anyway (with performance penalty). "
CALL PopMsg(r2, 10+colO, x$, errattr, 0, kc)
IF UCASE$(CHR$(kc)) <> "Y" THEN GOTO BU10
SimDaysOff(n, tm) = 0 - SimDaysOff(n, tm)
END IF
IF PitcherCloneUnused(DataName(n, tm), tm) = 0 THEN
CALL PopMsg(r2, 23+colO, " Sorry, that pitcher is/has been in the lineup! ", errattr, 2, kc)
GOTO BU10
END IF
'Reject if current pitcher is picked
IF n = ipa(tm) THEN
CALL PopMsg(r2, 24+colO, " Oops, that player is pitching now! ", errattr, 2, kc)
GOTO BU10
END IF
IF WarmUpRule = TRUE THEN
'Pitcher selected is "cold"
IF WarmUpStatus(n, tm) < 1 THEN
NowThrowing = 0
FOR i = 10 TO TopPitLim
IF CalledFromOffense = FALSE THEN
IF WarmUpStatus(i, tm) > 10 THEN INCR NowThrowing
ELSE
IF WarmUpStatus(i, tm) > 8 THEN INCR NowThrowing
END IF
NEXT
'Get up and start throwing if there's room (only 2 can throw at same time)
IF NowThrowing > 1 THEN
CALL PopMsg(r2, 23+colO, " You already have two people throwing! ", errattr, 2, kc)
GOTO BU10
END IF
IF CalledFromOffense = FALSE THEN
WarmUpStatus(n, tm) = 12
ELSE
WarmUpStatus(n, tm) = 10
END IF
IF Gender(tm) THEN
xS$ = " She'll get up and start throwing! "
ELSE
xS$ = " He'll get up and start throwing! "
END IF
CALL PopMsg(r2, 25+colO, xS$, errattr, 2, kc)
CALL BuildBullpenPlyList (tm, PlyList(), Av, CalledFromOffense) 'Returns PlyList() and Av
GOTO BU10
'Pitcher selected has just started throwing, not warm yet
ELSEIF WarmUpStatus(n, tm) > 10 THEN
IF Gender(tm) THEN
xS$ = " She's not quite warm yet! "
ELSE
xS$ = " He's not quite warm yet! "
END IF
CALL PopMsg(r2, 28+colO, xS$, errattr, 2, kc)
GOTO BU10
END IF
END IF
ERASE PlyList
'Just in case WarmUpRule = FALSE and somehow we get here from offense
IF CalledFromOffense = TRUE THEN
GOTO BU999
END IF
'We now have a new pitcher
iused(ip, tm) = TRUE 'mark old ip as used
BU150:
ip = n 'set new IP
ipa(tm) = ip 'store the pitchers address
INCR np(tm) 'add to count of pitchers
iyp(np(tm), tm) = ip 'store pitchers number by order of appearance
nPitch(tm) = 0 'reset pitch-count (by team only)
CALL AssignFatigue (tm)
'Reset WarmUpStatus of new pitcher
IF WarmUpRule = TRUE THEN WarmUpStatus(ip, tm) = 0
'Check to see if pitcher has a save situation brewing
DefLead = itruns(tm) - itruns(it)
IF DefLead > 0 THEN
'Faces tying run on-deck
IF DefLead < (NUMBERON + 3) THEN
QualSave1IP = ip
QualSave1ID = tm
END IF
'Has a three-run (or less) lead with nobody on
IF DefLead < 4 AND (NUMBERON = 0) THEN
QualSave2IP = ip
QualSave2ID = tm
END IF
END IF
IF NOT dh THEN 'we have to put pitcher in batting order
ps = 0 'find slot where the last pitcher was hitting (=ps)
DO
INCR ps
IF ps > 9 THEN
x$ = "ERROR(BULL1): No Pitcher Found in Lineup:" + DataFil(tm)
CALL ErrorBox (x$)
END IF
LOOP UNTIL DataPos(ps, tm) = 1
'If the current guy in the pitcher's slot is a pinch-hitter,
'the pitcher he pinch-hit for is on the bench! Do a swap which
'puts the pinch-hitter back on the bench (he's not staying in the
'game) and the old pitcher temporarily back in the lineup.
'Then we'll copy the new pitcher into the lineup.
'Check the pitcher list to see if the guy in the pitcher's slot is here
LastRealPitcher$ = DataName(iyp(np(tm)-1, tm), tm)
IF DataName(ps, tm) <> LastRealPitcher$ THEN
'Must be a pinch hitter/runner
'Find LastRealPitcher$ on bench - with position of pitcher
ps2 = SearchDAT(LastPiAd(tm)+1, MAXPLAYERS, tm, LastRealPitcher$, 1)
IF ps2 THEN
CALL Switch(ps, ps2, tm)
'Mark PH as used and restore his .DAT position
iused(ps2, tm) = TRUE
DataPos(ps2, tm) = OrgPos(DataRef(ps2, tm), tm)
ELSE
x$ = "ERROR(BULL1): Failed to locate previous pitcher on bench"
x$ = x$ + "|" + DataFil(tm)
CALL ErrorBox (x$)
END IF
END IF
'Copy pitcher's name and reference to slot ps
'Insert hitting stats
'Does new pitcher's name exist on bench?
SearchName$ = DataName(ip, tm)
n2 = SearchDAT (LastPiAd(tm)+1, MAXPLAYERS, tm, SearchName$, 0)
IF n2 THEN
CALL CopyStats(n2, ps, tm)
ELSE
DataAB(ps, tm) = 100
xS$ = UCASE$(DataCode(ip, tm))
code = ASC(xS$) - 64
IF code < 1 OR code > 5 THEN
IF RND < .5 THEN
DataHits(ps, tm) = 16
ELSE
DataHits(ps, tm) = 17
END IF
ELSE
DataHits(ps, tm) = 30 - (5 * code)
END IF
'1 A = 24 25
'2 B = 19 20
'3 C = 14 15
'4 D = 09 10
'5 E = 04 05
DataHR(ps, tm) = DataHits(ps, tm) * .025
DataSO(ps, tm) = 49.1 - DataHits(ps, tm) * 0.9
DataBB(ps, tm) = 5
IF DataPBatAB(ip, tm) > 0 THEN
DataAB(ps, tm) = DataPBatAB(ip, tm)
DataHits(ps, tm) = DataPBatHi(ip, tm)
DataHR(ps, tm) = DataPBatHR(ip, tm)
DataBB(ps, tm) = DataPBatBB(ip, tm)
DataSO(ps, tm) = DataPBatSO(ip, tm)
END IF
Data2B(ps, tm) = DataHits(ps, tm) * .14
Data3B(ps, tm) = DataHits(ps, tm) * .02
DataRBI(ps, tm) = DataHits(ps, tm) / 2.4
IF DataHand(ip, tm) = "r" THEN
DataHand(ps, tm) = "L"
ELSEIF DataHand(ip, tm) = "l" THEN
DataHand(ps, tm) = "R"
ELSE
DataHand(ps, tm) = DataHand(ip, tm)
END IF
DataDef(ps, tm) = 0
DataSpeed(ps, tm) = 3
DataSB(ps, tm) = 1 'was 3
DataCS(ps, tm) = 1 'was 2
END IF
DataName(ps, tm) = DataName(ip, tm)
DataRef(ps, tm) = ip
'Mark New pitcher as NOT used in case he's coming in because
'the last pitcher was PH'ed for
iused(ps, tm) = FALSE
CALL AddToRefByBO (ps, tm, ip) 'bat position, team, ref
END IF
GOTO BU999
BU1000:
'Automatic manager side trip
'Mark old IP as used - guarantees we won't select the current pitcher
' "SUB Manage" guarantees there IS at least one more to select
REDIM DupNameFlag (10:TopPitLim) AS LONG
nn = LastPiAd(tm)
IF DupNameTeam(tm) THEN
FOR i = 10 TO nn
SearchName$ = DataName(i, tm)
IF PitcherCloneUnused(SearchName$, tm) = 0 THEN DupNameFlag(i) = TRUE
NEXT
END IF
iused(ip, tm) = TRUE
DefLead = itruns(tm) - itruns(it)
CloserSituation = FALSE
IF DefLead > -1 AND DefLead < 4 THEN
IF StrictCloserRule THEN
IF inn > 8 THEN
IF DefLead > 0 THEN
CloserSituation = TRUE
END IF
END IF
ELSE
IF inn > 8 THEN
CloserSituation = TRUE
ELSEIF inn = 8 AND (iout > 0 OR NUMBERON) THEN
CloserSituation = TRUE
END IF
END IF
END IF
IF CloserSituation THEN
GOSUB BUGetAvClosers
IF AvCls > 0 THEN
Closers = TRUE
GOSUB BUSelectReliever
CloserIn(tm) = TRUE
ELSE
GOSUB BUGetAvGeneral
IF AvGen > 0 THEN
Closers = FALSE
GOSUB BUSelectReliever
ELSE
GOSUB BUFindAnyOne
IF n = 0 THEN
GOSUB DumpScoreCard
x$ = "Bullpen Error-Closer: Out of Pitchers"
x$ = x$ + "|" + DataFil(tm)
CALL ErrorBox (x$)
GOTO BU999
END IF
END IF
END IF
ELSE 'Setup Pitcher Situation
GOSUB BUGetAvGeneral
IF AvGen > 0 THEN
Closers = FALSE
GOSUB BUSelectReliever
ELSE
GOSUB BUFindAnyOne
IF n = 0 THEN
GOSUB DumpScoreCard
x$ = "Bullpen Error-General: Out of Pitchers"
x$ = x$ + "|" + DataFil(tm)
CALL ErrorBox (x$)
GOTO BU999
END IF
END IF
END IF
GOTO BU150 'Back to Primary Routine
BUGetAvClosers:
'Games = DataGames(i, tm)
'Starts = DataGbyP(i, tm, 1)
'Saves = DataCS(i, tm)
REDIM PitList(1 TO 25) AS TotPctType
AvCls = 0
IF NewStyleWithSaves(tm) THEN
TotSaves = 0
TopCloser = 0
TopCloserSaves = 0
IF LastPiAd(tm) < 15 THEN '5 or less pitchers [take all]
nb = 10
ELSEIF LastPiAd(tm) < 18 THEN '6 - 8 pitchers
nb = 14
ELSE '9 or more pitchers
nb = 15
END IF
FOR i = nb TO LastPiAd(tm)
IF DataCS(i, tm) > 0 AND iused(i, tm) = 0 THEN
IF SimDaysOff(i, tm) = 0 OR DaysOffRule = FALSE THEN
IF NOT DupNameFlag(i) THEN
IF DataCS(i, tm) > TopCloserSaves THEN
TopCloserSaves = DataCS(i, tm)
TopCloser = i
END IF
TotSaves = TotSaves + DataCS(i, tm)
END IF
END IF
END IF
NEXT
FOR i = nb TO LastPiAd(tm)
IF DataCS(i, tm) > 0 AND iused(i, tm) = 0 THEN
IF SimDaysOff(i, tm) = 0 OR DaysOffRule = FALSE THEN
IF NOT DupNameFlag(i) THEN
IF TotSaves > 0 THEN
IF i = TopCloser THEN 'the "Go-To Guy"
xF! = (DataCS(i, tm) * 1.2) / TotSaves
ELSE
xF! = DataCS(i, tm) / TotSaves
END IF
IF xF! > 0 AND AvCls < 25 THEN
INCR AvCls
PitList(AvCls).PctOfTot = xF!
PitList(AvCls).Slot = i
END IF
END IF
END IF
END IF
END IF
NEXT
ELSE
'Old Style
j = MIN&(15, LastPiAd(tm)) 'usually 15 unless not that many pitchers
IF iused(j, tm) = 0 THEN
IF SimDaysOff(j, tm) = 0 OR DaysOffRule = FALSE THEN
IF NOT DupNameFlag(j) THEN
AvCls = 1
PitList(1).Slot = j
END IF
END IF
END IF
END IF
RETURN
BUGetAvGeneral:
'Games = DataGames(i, tm)
'Starts = DataGbyP(i, tm, 1)
'Saves = DataCS(i, tm)
REDIM PitList(1 TO 25) AS TotPctType
TotInn = 0
IF NewStyleWithSaves(tm) THEN 'Have Games, Starts and Saves
FOR i = 10 TO LastPiAd(tm)
'If no spot starters, skip pitchers in starting rotation
GOSUB CheckIfInRotation
IF SkipHim = FALSE AND iused(i, tm) = 0 THEN
IF SimDaysOff(i, tm) = 0 OR DaysOffRule = FALSE THEN
RA = DataGames(i, tm) - DataGbyP(i, tm, 1)
IF RA > 0 THEN
IF (DataCS(i, tm) / RA) < .2 THEN 'We skip high-save guys
IF NOT DupNameFlag(i) THEN
'Primarily Starter or Reliever?
IF DataGbyP(i, tm, 1) < (DataGames(i, tm) \ 2) THEN
'Primarily a reliever
ReliefInn = DataAB(i, tm) - (DataGbyP(i, tm, 1) * 6)
ELSE
'Primarily a starter (w/2 innings per relief appearance)
ReliefInn = RA * 2
END IF
IF ReliefInn < 0 THEN ReliefInn = 0
TotInn = TotInn + ReliefInn
END IF
END IF
END IF
END IF
END IF
NEXT
AvGen = 0
TopDogInn = 0
TopDog = 0
FOR i = 10 TO LastPiAd(tm)
'If no spot starters, skip pitchers in starting rotation
GOSUB CheckIfInRotation
IF SkipHim = FALSE AND iused(i, tm) = 0 THEN
IF SimDaysOff(i, tm) = 0 OR DaysOffRule = FALSE THEN
RA = DataGames(i, tm) - DataGbyP(i, tm, 1)
IF RA > 0 THEN
IF (DataCS(i, tm) / RA) < .2 THEN 'We skip high-save guys
IF NOT DupNameFlag(i) THEN
IF TotInn > 0 THEN
'Primarily Starter or Reliever?
IF DataGbyP(i, tm, 1) < (DataGames(i, tm) \ 2) THEN
'Primarily a reliever
ReliefInn = DataAB(i, tm) - (DataGbyP(i, tm, 1) * 6)
ELSE
'Primarily a starter (w/2 innings per relief appearance)
ReliefInn = RA * 2
END IF
IF ReliefInn > TopDogInn THEN
TopDogInn = ReliefInn
TopDog = i
END IF
IF ReliefInn > 0 AND AvGen < 25 THEN
INCR AvGen
xF! = ReliefInn / TotInn
PitList(AvGen).PctOfTot = xF!
PitList(AvGen).Slot = i
END IF
END IF
END IF
END IF
END IF
END IF
END IF
NEXT
ELSE
'Old Style .DAT (we know nothing about Games, Starts & Saves)
IF LastPiAd(tm) < 15 THEN '5 or less pitchers [take last]
nb = LastPiAd(tm)
ELSEIF LastPiAd(tm) = 15 THEN '6
nb = 14
ELSE '7 or more
nb = 16 'we assume slot 15 is closer
END IF
TotInn = 0
FOR i = nb TO LastPiAd(tm)
IF i <> 15 THEN
IF iused(i, tm) = 0 THEN
IF SimDaysOff(i, tm) = 0 OR DaysOffRule = FALSE THEN
IF NOT DupNameFlag(i) THEN
TotInn = TotInn + DataAB(i, tm)
END IF
END IF
END IF
END IF
NEXT
AvGen = 0
FOR i = nb TO LastPiAd(tm)
IF i <> 15 THEN
IF iused(i, tm) = 0 THEN
IF SimDaysOff(i, tm) = 0 OR DaysOffRule = FALSE THEN
IF NOT DupNameFlag(i) THEN
IF TotInn > 0 THEN
IF AvGen < 25 THEN
INCR AvGen
xF! = DataAB(i, tm) / TotInn
PitList(AvGen).PctOfTot = xF!
PitList(AvGen).Slot = i
END IF
END IF
END IF
END IF
END IF
END IF
NEXT
END IF
RETURN
CheckIfInRotation:
'Input: i
SkipHim = FALSE
'Does rotation record exist?
Fil$ = DataFil(tm)
j = ROTATIONLIST (Fil$) 'RotationList does not exist in Single Game mode, so SBS can pick anyone
IF j > 0 THEN
IF RotRec(j).RotSpot = " " OR AllowStartersInRelief = FALSE THEN
'We will not allow relivers to be pulled from the starting rotation
' 1. If Spot Starters are not used, OR
' 2. STARTERS-MAY-RELIEVE was specified in baseball.cfg
'Check if pitcher "i" is in starting rotation
jj = 1
DO UNTIL jj > 5 OR SkipHim = TRUE
IF i = RotRec(j).RotList(jj) THEN SkipHim = TRUE
INCR jj
LOOP
END IF
END IF
RETURN
BUFindANYONE:
n = 0
'Try #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 = 10
'DO UNTIL i > LastPiAd(tm)
' IF iused(i, tm) = 0 AND DupNameFlag(i) = 0 THEN
' n = i
' EXIT DO
' END IF
' INCR i
'LOOP
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 (DataSpeed(ib, it) / 2) + FRND(10) > 13 THEN 'Its a hit! 9/19
'7 - 10%
'8 - 10%
'9 - 20%
IF DelFac THEN
IF SoundOn THEN CALL WavBunt
CALL Msg ("24", "0", "0", "01", ib, it, man2, team2) 'sq's around
CALL Msg ("24", "0", "0", "02", ib, it, man2, team2) 'down
CALL Msg ("02", "4", "2", "00", wag, id, man2, team2) 'fields & throws
CALL Msg ("23", "0", "0", "01", 0, it, man2, team2) 'safe
END IF
CALL Advanc(1, 1, 1)
ir1 = ib
mpp(ib) = ip
'Credit the hit. Bump "Batters Faced".
CALL CreditHit
INCR mpbf(ip, id)
Result$ = "1B"
EXIT SUB
END IF
'Nobody on base! OR two-out: Just an out.
IF (ir1 = 0 AND ir2 = 0 AND ir3 = 0) OR iout = 2 THEN
IF DelFac THEN
IF SoundOn THEN CALL WavBunt
CALL Msg ("24", "0", "0", "01", ib, it, man2, team2) 'sq's around
CALL Msg ("24", "0", "0", "02", ib, it, man2, team2) 'down
CALL Msg ("02", "4", "2", "00", wag, id, man2, team2) 'fields & throws
CALL Msg ("02", "4", "3", "00", ib, it, man2, team2) 'out
END IF
INCR iout
INCR mpo(ip, id)
IF WhoAtPos <> 3 THEN
Result$ = Result$ + "-3"
INCR Assists(DataRef(wag, id), id, WhoAtPos)
ELSE
Result$ = Result$ + "UN"
END IF
INCR PutOuts(DataRef(WHOATGUY(3), id), id, 3)
INCR mpbf(ip, id)
EXIT SUB
END IF
CheckSqueeze:
'Calculate bunting ability (successrate!)
singles = DataHits(ib,it) - Data2B(ib,it) - Data3B(ib,it) - DataHR(ib,it)
x! = (singles + DataSB(ib,it) - DataCS(ib,it)) / (DataAB(ib,it) + DataBB(ib,it))
x1! = x! / p1baseF(it)
'around 1.0 would be a bit less than average
'get pitchers rate
IF DataPos(ib, it) = 1 AND DataRef(ib, it) <= LastPiAd(it) THEN
SuccessRate! = x1! - .1
' zzzSumR = zzzSumR + SuccessRate!
' zzzSumN = zzzSumN + 1
ELSE
SuccessRate! = x1! - .2
END IF
IF SuccessRate! < .35 THEN SuccessRate! = .35
IF SuccessRate! > .85 THEN SuccessRate! = .85
IF ir3 THEN 'RUNNER ON THIRD
SqueezeAttempt = FALSE
IF ir1 <> 0 AND ir2 = 0 THEN '1st and 3rd situation
IF amgr(it) = 0 THEN
'Player is calling the shots
x$ = " Attempt squeeze? [y/N]"
CALL PopMsg(10+rowO, 30+colO, x$, errattr, 0, kc)
IF UCASE$(CHR$(kc)) = "Y" THEN SqueezeAttempt = TRUE
ELSE
'Computer is in control
IF RND < DataSpeed(ir3, it) / 9 THEN SqueezeAttempt = TRUE '8
'Also, make SqueezeAttempt true is pitcher is next
IF ib < 9 THEN ibp1 = ib + 1 ELSE ibp1 = 1
IF DataPos(ibp1, it) = 1 THEN SqueezeAttempt = TRUE
'No Squeeze if infield is in
IF Tight THEN SqueezeAttempt = FALSE
END IF
ELSE
SqueezeAttempt = TRUE
END IF
IF SqueezeAttempt THEN
IF DelFac THEN CALL Msg ("24", "0", "0", "04", 0, it, man2, team2) 'sq is on!
Success = FALSE
IF NOT Tight THEN
IF RND < SuccessRate! THEN Success = TRUE
ELSE
'IF FRND(10) + DataSpeed(ir3) > 15 THEN Success = TRUE
IF RND < SuccessRate! * 0.66 THEN Success = TRUE
END IF
IF POut THEN Success = FALSE
IF Success THEN
IF DelFac THEN
IF SoundOn THEN CALL WavBunt
CALL Msg ("24", "0", "0", "10", ir3, it, man2, team2) 'here comes
CALL Msg ("15", "0", "0", "05", ir3, it, man2, team2) 'SAFE
END IF
CALL Advanc(1, 1, 1)
IF DelFac THEN CALL Msg ("02", "4", "3", "00", ib, it, man2, team2) 'batter out
INCR iout
INCR mpo(ip, id)
'credit a squeeze as a sacrifice
INCR mSacB(ref, it)
mab(ref, it) = mab(ref, it) - 1
IF UCASE$(DataHand(ip, id)) = "L" THEN
mabLHP(ref, it) = mabLHP(ref, it) - 1
ELSE
mabRHP(ref, it) = mabRHP(ref, it) - 1
END IF
IF WhoAtPos <> 3 THEN
Result$ = Result$ + "-3 SQZ"
n = 3
INCR Assists(DataRef(wag, id), id, WhoAtPos)
ELSE
Result$ = Result$ + "-4 SQZ"
n = 4
END IF
INCR PutOuts(DataRef(WHOATGUY(n), id), id, n)
INCR mpbf(ip, id)
ELSE
IF DelFac THEN 'Squeeze Unsuccessful
IF POut THEN AddToAnnouncer id, "They Pitchout!"
CALL Msg ("24", "0", "0", "03", ib, it, man2, team2) 'no contact
CALL Msg ("24", "0", "0", "10", ir3, it, man2, team2) 'here comes
AddToAnnouncer it, "He is...OUT at the plate!"
CALL Msg ("29", "0", "0", "11", 0, id, man2, team2) 'boo
END IF
INCR iout
INCR mpo(ip, id)
i = ir3
ir3 = ir2
ir2 = ir1
ir1 = 0
Result$ = ""
CALL AddToScoreCrd(it, DataRef(i, it), "4", "1-2 Bad SQZ")
INCR PutOuts(DataRef(WHOATGUY(2), id), id, 2)
'Runner on 3rd should get tagged with a caught stealing
INCR mcs(DataRef(i, it), it)
'No assist unless the pitcher gets one (this was a pitchout)
CALL ResetBatter
WhoAtPos = 0 'to keep defense from flashing
END IF
EXIT SUB
END IF
END IF
' Either NO Runner on Third
' [1st only, 2nd only or 1st and 2nd]
' OR
' 1st and 3rd and NO Squeeze Attempt
'Basic Sacrifice attempt
IF DelFac THEN
IF SoundOn THEN CALL WavBunt
CALL Msg ("24", "0", "0", "01", ib, it, man2, team2) 'sq's around
END IF
Success = FALSE
IF NOT Tight THEN
IF RND < SuccessRate! THEN Success = TRUE
ELSE
IF RND < .55 THEN Success = TRUE
END IF
IF Success THEN
zzsacok = zzsacok + 1
IF DelFac THEN
CALL Msg ("24", "0", "0", "02", ib, it, man2, team2) 'bunt is down
CALL Msg ("24", "0", "0", "11", wag, id, man2, team2) '* up with it
END IF
INCR iout 'Success - runners advance (except 3rd)
INCR mpo(ip, id)
INCR mSacB(ref, it)
mab(ref, it) = mab(ref, it) - 1
IF UCASE$(DataHand(ip, id)) = "L" THEN
mabLHP(ref, it) = mabLHP(ref, it) - 1
ELSE
mabRHP(ref, it) = mabRHP(ref, it) - 1
END IF
CALL Advanc(1, 1, 0)
IF DelFac THEN
CALL Msg ("02", "4", "3", "00", ib, it, man2, team2) 'batter out
CALL Msg ("24", "0", "0", "07", ib, it, man2, team2) 'nice bunt
END IF
IF WhoAtPos <> 3 THEN
Result$ = Result$ + "-3 SAC"
n = 3
INCR Assists(DataRef(wag, id), id, WhoAtPos)
ELSE
Result$ = Result$ + "-1 SAC"
n = 1
END IF
INCR PutOuts(DataRef(WHOATGUY(n), id), id, n)
ELSE 'Unsuccessful!
zzsacfa = zzsacfa + 1
INCR iout
INCR mpo(ip, id)
IF Tight THEN x! = .9 ELSE x! = .5
IF RND < x! THEN 'Lead runner out - batter reaches first
i = 4
Rezult$ = " FO"
IF ir3 = 0 THEN
IF ir2 THEN 'Get lead runner at third
ir2 = ir1
'Proposed fix:
IF ir1 = 0 THEN Rezult$ = " FC"
'---
IF WhoAtPos <> 5 THEN
i = 5
ELSE
i = 6
'Proposed change - no more 5-6 force outs
'change to 1-5
WhoAtPos = 1
wag = WHOATGUY(WhoAtPos)
Result$ = "1"
i = 5
'---
END IF
END IF
END IF
ir1 = ib
mpp(ib) = ip
Result$ = Result$ + "-" + LTRIM$(STR$(i)) + Rezult$
INCR Assists(DataRef(wag, id), id, WhoAtPos)
INCR PutOuts(DataRef(WHOATGUY(i), id), id, i)
IF DelFac THEN
CALL Msg ("24", "0", "0", "02", ib, it, man2, team2) 'bunt is down
CALL Msg ("24", "0", "0", "11", wag, id, man2, team2) '* up with it
CALL Msg ("24", "0", "0", "06", 0, id, man2, team2) 'get lead
CALL Msg ("24", "0", "0", "08", ib, it, man2, team2) 'batter on
END IF
ELSE 'Batter pops it up
INCR PutOuts(DataRef(wag, id), id, WhoAtPos)
IF DelFac THEN
CALL Msg ("05", "0", "3", "00", 0, it, man2, team2) 'popped it up
CALL Msg ("24", "0", "0", "09", wag, id, man2, team2) '* grabes it
END IF
END IF
END IF
INCR mpbf(ip, id)
EXIT SUB
ErrorTrap:
LOCATE 10, 30
PRINT "BUNT_Error"; ERRCLEAR
LOCATE 11, 30
PRINT "wag="; wag; "WhoAtPos="; WhoAtPos; "n="; n;
x$ = WAITKEY$
END SUB
SUB Button (row, col, attr, xS$, shadow)
QPRINTs row, col, xS$, attr
IF shadow THEN
L = LEN(xS$)
a = SCREENATTR(row + 1, col + i) 'return color attr at shadow point
bac = (a AND &H70) \ 16 'background color at shadow point
attr2 = bac * 16 'black on background color
FOR i = 1 TO L
QPRINTs row + 1, col + i, CHR$(223), attr2
NEXT
QPRINTs row, col + L, CHR$(220), attr2
END IF
END SUB
SUB ChangeAttribute (row, col, leng, attr) STATIC
'Pure PB/CC method
LOCATE row, col
forg = attr MOD 16
bacg = attr \ 16
IF (col + leng) < (ConsCols + 2) THEN COLOR forg, bacg, leng
END SUB
SUB CheckForValidFile (File$, RecLen, Valid)
'Is File$ the old format or the new?
'Check for existence of File$ before going here
OPEN File$ FOR BINARY AS #4
L& = LOF(4)
IF (L& MOD RecLen <> 0) THEN 'Wrong Record Length
Valid = 0
ELSE
Valid = -1
END IF
CLOSE #4
END SUB
SUB ClearActiveSTATRec
OPEN CmdPath$ + CmdSCH$ FOR BINARY AS #2
Buffer$ = SPACE$(90)
GET #2 ,, Buffer$ 'Read 1st 90 bytes (active stat files)
MID$(Buffer$, 11, 80) = SPACE$(80)
PUT #2, 1, Buffer$ 'Rewrite 1st 90 bytes
CLOSE #2
STx = 0
REDIM ActiveSTAT(10) AS GLOBAL STRING
END SUB
SUB ClipIfNecessary (xS$, tr, tc, b1r1, b1c1, b1r2, b1c2, b2r1, b2c1, b2r2, b2c2, ca, cf)
'Input:
' xS$
' Object origin and length: tr, tc
' Box to protect: b1r1, b1c1, b1r2, b1c2
'Output:
' xS$
' first column: ca
' last column: cf
ce = tc + LEN(xS$) - 1
cf = ce
ca = 0
cb = 0
'Does any part of the name overlap the batting orders?
FOR i = tc TO ce
IF Inbox(b1r1, b1c1, b1r2, b1c2, tr, i, -1) THEN
IF cb = 0 THEN cb = i
ELSE
IF ca = 0 THEN ca = i
END IF
NEXT
IF cb = 0 THEN 'we didn't clip anything -- try other box
ca = 0
FOR i = tc TO ce
IF Inbox(b2r1, b2c1, b2r2, b2c2, tr, i, -1) THEN
IF cb = 0 THEN cb = i
ELSE
IF ca = 0 THEN ca = i
END IF
NEXT
END IF
IF cb = 0 THEN 'we still didn't clip anything
ca = tc
cf = ce
EXIT SUB
END IF
IF ca > 0 THEN
IF cb > ca THEN 'clipped on right
xS$ = MID$(xS$, 1, cb-ca)
cf = cb - 1
ELSE 'clipped on left
xS$ = MID$(xS$, ca-tc+1)
cf = ce
END IF
END IF
END SUB
SUB ClearInpBuffer
DO
x$ = INKEY$
LOOP WHILE LEN(x$)
END SUB
SUB CopyStats(fr, tw, tm)
DataAB(tw, tm) = DataAB(fr, tm)
DataHits(tw, tm) = DataHits(fr, tm)
DataHR(tw, tm) = DataHR(fr, tm)
DataSO(tw, tm) = DataSO(fr, tm)
DataBB(tw, tm) = DataBB(fr, tm)
Data2B(tw, tm) = Data2B(fr, tm)
Data3B(tw, tm) = Data3B(fr, tm)
DataRBI(tw, tm) = DataRBI(fr, tm)
DataHand(tw, tm) = DataHand(fr, tm)
DataDef(tw, tm) = DataDef(fr, tm)
DataSB(tw, tm) = DataSB(fr, tm)
DataCS(tw, tm) = DataCS(fr, tm)
DataSpeed(tw,tm) = DataSpeed(fr,tm)
FOR i = 1 TO 4
DataPosi(tw, tm, i) = DataPosi(fr, tm, i)
DataGByP(tw, tm, i) = DataGByP(fr, tm, i)
NEXT
END SUB
SUB CountActiveSTATFiles
OPEN CmdPath$ + CmdSCH$ FOR BINARY AS #2
Buffer$ = SPACE$(90)
GET #2 ,, Buffer$
STx = 0
REDIM ActiveSTAT(10) AS GLOBAL STRING
a$ = MID$(Buffer$, 11, 8)
n = 11
DO WHILE a$ <> SPACE$(8) AND STx < 10
INCR STx
ActiveSTAT(STx) = RTRIM$(a$)
a$ = MID$(Buffer$, n + 8, 8)
n = n + 8
LOOP
CLOSE #2
END SUB
SUB CountAvPitchers (t, Av, LastGuy) STATIC
Av = 0
LastGuy = 0
FOR i = 10 TO LastPiAd(t)
IF iused(i, t) = 0 AND i <> ipa(t) THEN
IF SimDaysOff(i, t) = 0 OR DaysOffRule = FALSE THEN
IF DupNameTeam(t) THEN
IF PitcherCloneUnused(DataName(i, t), t) THEN
OK = TRUE
ELSE
OK = FALSE
END IF
ELSE
OK = TRUE
END IF
IF OK THEN
IF NewStyle(t) THEN 'Games > Starts
IF DataGames(i, t) > DataGbyP(i, t, 1) THEN
INCR Av
LastGuy = i
END IF
ELSE
INCR Av
LastGuy = i
END IF
END IF
END IF
END IF
NEXT
END SUB
SUB CreditHit
'pitcher:
INCR mph(ip, id)
'hitter:
INCR mhits(ref, it)
IF UCASE$(DataHand(ip, id)) = "L" THEN
INCR mhitsLHP(ref, it)
ELSE
INCR mhitsRHP(ref, it)
END IF
INCR ithits(it)
INCR innh
END SUB
SUB DefCheck (OutOfPositionMsg)
FOR i = 1 TO 9
OK = FALSE
CurrPos = DataPos(i, id)
IF CurrPos = 1 OR CurrPos = 10 THEN
OK = TRUE
ELSE
IF DataPosi(i, id, 1) > 0 AND DataGbyP(i, id, 1) > 0 THEN 'Strict
IF FoundPosition(CurrPos, i, id) THEN
OK = TRUE
END IF
ELSE
ListedPos = OrgPos(DataRef(i, id), id) 'Loose
SELECT CASE CurrPos
CASE 2
IF ListedPos = 2 THEN OK = TRUE
CASE 3
IF ListedPos = 3 OR ListedPos = 5 THEN OK = TRUE
CASE 4
IF ListedPos = 4 OR ListedPos = 6 THEN OK = TRUE
CASE 5
IF ListedPos = 5 OR ListedPos = 6 THEN OK = TRUE
CASE 6
IF ListedPos = 6 THEN OK = TRUE
CASE 7, 8, 9
IF ListedPos = 7 OR ListedPos = 8 OR ListedPos = 9 THEN OK = TRUE
END SELECT
END IF
END IF
IF OK = FALSE AND OutOfPositionMsg = TRUE THEN
zS$ = LASTNAME$(DataName(i, id))
xS$ = "Note: " + zS$ + " is playing out-of-position. "
CALL PopMsg(9+rowO, 20+colO, xS$, errattr, 2, kc)
END IF
NEXT
'Are all positions occupied?
IF dh THEN p1 = 2: p2 = 10 ELSE p1 = 1: p2 = 9
FOR p = p1 TO p2
OK = FALSE
FOR i = 1 TO 9
IF p = DataPos(i, id) THEN
OK = TRUE
EXIT FOR
END IF
NEXT
IF NOT OK THEN
xS$ = STR$(p)
CALL PopMsg(10+rowO, 20+colO, "Lineup error: No Position" + xS$, errattr, 2, kc)
END IF
NEXT
END SUB
SUB DefCoordinates (p, r, c, ObsD, ObsY, ObsH, ObsTz, ObsTy)
ON ERROR GOTO ERRORTRAP
IF ConsRows < 28 OR ConsCols < 85 THEN
SELECT CASE p
CASE 1
r = MidRow + 4: c = MidCol - 6
CASE 2
r = MidRow + 9: c = MidCol - 4
CASE 3
r = MidRow + 2: c = MidCol + 11
CASE 4
r = MidRow : c = MidCol + 4
CASE 5
r = MidRow + 2: c = MidCol - 16
CASE 6
r = MidRow : c = MidCol - 12
CASE 7
r = MidRow - 3: c = MidCol - 26
CASE 8
r = MidRow - 5: c = MidCol - 4
CASE 9
r = MidRow - 3: c = MidCol + 16
CASE 10
r = 0: c = 0
END SELECT
EXIT SUB
END IF
DIM ax(10)
DIM ay(10)
DIM az(10)
ax(1) = 58: ay(1) = -10: az(1) = 0 'pitcher
ax(2) = -3: ay(2) = -3: az(2) = 0 'catcher
ax(3) = 73: ay(3) = 53: az(3) = 0 '1st
ax(4) = 128: ay(4) = 32: az(4) = 0 '2nd
ax(5) = 73: ay(5) = -63: az(5) = 0 '3rd
ax(6) = 128: ay(6) = -38: az(6) = 0 'short
ax(7) = 250: ay(7) = -150: az(7) = 0 'lf
ax(8) = 350: ay(8) = -15: az(8) = 0 'cf
ax(9) = 250: ay(9) = 150: az(9) = 0 'rf
ox = ObsD
oy = ObsY
oz = ObsH
xw! = .8
sfv! = ConsRows
sfh! = ConsCols * .85
TiltZ! = ObsTz * .01745 'convert to radians
TiltY! = ObsTy * .01745 'convert to radians
TiltZ! = CircularFcn(TiltZ!)
TiltY! = CircularFcn(TiltY!)
'Verticle (row)
IF ox = ax(p) AND oy = ay(p) THEN
ThetaZ! = 0
ELSE
ThetaZ! = ATN( (oz - az(p)) / SQR( (ox - ax(p))^2 + (oy - ay(p))^2 ) )
ThetaZ! = CircularFcn(ThetaZ!)
END IF
ThetaZ! = CircularFcn(ThetaZ! + TiltZ!)
IF ThetaZ! > 3.14159 THEN SignFac! = 1.0 ELSE SignFac! = -1.0
cv! = SignFac! * TAN(ThetaZ!) * xw! * sfv!
'Horizontal (column)
IF ox = ax(p) AND oy = ay(p) THEN
ThetaY! = 0
ELSE
ThetaY! = ATN( (oy - ay(p)) / SQR( (ox - ax(p))^2 + (oy - ay(p))^2 ) )
ThetaY! = CircularFcn(ThetaY!)
END IF
ThetaY! = CircularFcn(ThetaY! + TiltY!)
IF ThetaY! > 3.14159 THEN SignFac! = 1.0 ELSE SignFac! = -1.0
ch! = SignFac! * TAN(ThetaY!) * xw! * sfh!
c = ch! + MidCol
TotGraphRows = ConsRows - 6
'Calculate mid-row for graphics window, then add 5 because window starts at 6
mr! = (TotGraphRows \ 2) + 5
r = mr! - cv!
IF c < 1 THEN c = 1
IF c > ConsCols THEN c = ConsCols
IF r < 6 THEN r = 6
IF r > ConsRows - 1 THEN r = ConsRows - 1
GOTO DefCoordEXIT
ErrorTrap:
LOCATE 10, 30
PRINT "ERROR: DefCoordinates "; ERRCLEAR
LOCATE 11, 30
x$ = WAITKEY$
DefCoordEXIT:
END SUB
SUB DefSwitch (row, tm)
DIM Llitrow(3), Llitcol(3), Llit$(3), Lrow(3), Lcol(3), Llen(3), Led$(3), LContents$(3)
IF Gfx THEN CALL GraphHole(30, row+rowO, 1+colO, row+18+rowO, 80+colO)
CALL Drawfrm(row+rowO, 1+colO, row+17+rowO, 78+colO, defattr, "'" + RTRIM$(Names(tm))+ " Lineup", "ESC (or close window) to Continue", 1, 0, 1)
QPRINTs row+2+rowO, 18+colO, "Change DEFENSIVE POSITIONING in Current Lineup", defattr
DATA 16,35,"",16,37,01,"X "
DATA 16,39,"",16,43,01,"X "
Flds = 2
c = 1
FOR i = 1 TO Flds
Llitrow(i) = VAL(READ$(c)) + row + rowO
Llitcol(i) = VAL(READ$(c+1)) + colO
Llit$(i) = READ$(c+2)
Lrow(i) = VAL(READ$(c+3)) + row + rowO
Lcol(i) = VAL(READ$(c+4)) + colO
Llen(i) = VAL(READ$(c+5))
Led$(i) = READ$(c+6)
c = c + 7
NEXT
DoneSw = FALSE
DO
x$ = " Name Pos Gam Avg AB Hit HR Def Games@Pos"
IF ERRSw(tm) THEN MID$(x$, 40, 3) = "ERR"
QPRINTs row+4+rowO, 3+colO, x$, defattr
FOR j = 1 TO 9
IF DataAB(j, tm) = 0 THEN
BAF! = 0
ELSE
BAF! = DataHits(j, tm) / DataAB(j, tm)
END IF
a$ = SPACE$(75)
MID$(a$, 1, 1) = LFORMAT$(j, "#")
MID$(a$, 3, 13) = DataName(j, tm)
MID$(a$, 17, 2) = Pos(DataPos(j, tm))
MID$(a$, 20, 3) = LFORMAT$(DataGames(j, tm), "###")
MID$(a$, 24, 4) = FFORMAT$(BAF!, ".###")
MID$(a$, 29, 3) = LFORMAT$(DataAB(j, tm), "###")
MID$(a$, 33, 3) = LFORMAT$(DataHits(j, tm), "###")
MID$(a$, 37, 2) = LFORMAT$(DataHR(j, tm), "##")
MID$(a$, 40, 3) = LFORMAT$(DataDef(j, tm), "###")
b$ = ""
FOR k = 1 TO 4
IF DataGByP(j,tm,k) > 0 THEN
b$ = b$ + LFORMAT$(DataGbyP(j,tm,k), "####") + " @"
IF DataPosi(j,tm,k) > 9 THEN
b$ = b$ + "DH"
ELSE
b$ = b$ + LFORMAT$(DataPosi(j,tm,k), "##")
END IF
END IF
NEXT
bl = LEN(b$)
IF bl THEN
MID$(a$, 44, bl) = b$
END IF
QPRINTs row+4+j+rowO, 3+colO, a$, dimattr
NEXT
FOR i = row+5+rowO TO row+13+rowO
CALL ChangeAttribute(i, 19+colO, 2, revattr)
NEXT
QPRINTs row+15+rowO, 9+colO, "Enter the player numbers whose POSITION you want to switch.", defattr
x$ = LPtr$ + "-" + RPtr$
QPRINTs row+16+rowO, 39+colO, x$, defattr
LContents$(1) = " "
LContents$(2) = " "
CursorPtr = 1
DO
TakeFromAnywhere = 1 'Grabs any mouse-clicked character
CALL ScreenIO(Keyed, KeyEsc, 0, KeyEsc, Flds, CursorPtr, Llen(), Lrow(), Lcol(), Led$(), Llit$(), Llitrow(), Llitcol(), LContents$())
TakeFromAnywhere = 0
IF LContents$(1) = " " AND LContents$(2) = " " THEN DoneSw = TRUE: EXIT DO
p1 = VAL(LContents$(1))
p2 = VAL(LContents$(2))
IF p1 > 0 AND p1 <= 9 AND p2 > 0 AND p2 <= 9 THEN
IF p1 = p2 THEN EXIT DO
n1 = 0
n2 = 0
IF DataPos(p1, tm) = 1 THEN
'Can p2 pitch?
SearchName$ = DataName(p2, tm)
n2 = SearchDAT (10, LastPiAd(tm), tm, SearchName$, 0)
IF n2 = 0 THEN
CALL PopMsg(13+rowO, 28+colO, LASTNAME$(SearchName$) + " can't pitch. ", errattr, 2, kc)
EXIT DO
END IF
END IF
IF DataPos(p2, tm) = 1 THEN
'Can p1 pitch?
SearchName$ = DataName(p1, tm)
n1 = SearchDAT (10, LastPiAd(tm), tm, SearchName$, 0)
IF n1 = 0 THEN
CALL PopMsg(13+rowO, 28+colO, LASTNAME$(SearchName$) + " can't pitch. ", errattr, 2, kc)
EXIT DO
END IF
END IF
SWAP DataPos(p1, tm), DataPos(p2, tm)
'Score Card
IF inn > 0 THEN
x$ = "[DEF]" + FLASTNAME$(p1, tm) _
+ " to " + Pos(DataPos(p1, tm))
CALL AddToScoreCrd (0, 0, "X", x$)
x$ = "[DEF]" + FLASTNAME$(p2, tm) _
+ " to " + Pos(DataPos(p2, tm))
CALL AddToScoreCrd (0, 0, "X", x$)
END IF
'Is a pitcher involved?
n = 0
IF DataPos(p1, tm) = 1 THEN
n = n1
p = p1
otherguy = p2
END IF
IF DataPos(p2, tm) = 1 THEN
n = n2
p = p2
otherguy = p1
END IF
IF n THEN
ip = n 'set new IP
ipa(tm) = ip 'store the pitchers address
INCR np(tm) 'add to count of pitchers
iyp(np(tm), tm) = ip 'store pitchers number by order of appearance
nPitch(tm) = 0 'clear pitch count
CALL AssignFatigue (tm)
'Check to see if pitcher has a save situation brewing
DefLead = itruns(tm) - itruns(it)
IF DefLead > 0 THEN
'Faces tying run on-deck
IF DefLead < (NUMBERON + 3) THEN
QualSave1IP = ip
QualSave1ID = tm
END IF
'Has a three-run (or less) lead with nobody on
IF DefLead < 4 AND (NUMBERON = 0) THEN
QualSave2IP = ip
QualSave2ID = tm
END IF
END IF
'For Box Score ??
' CALL AddToRefByBO (p, tm, ip) 'bat position, team, ref
'Score Card
'CALL AddToScoreCrd (it, n, "A", "[Relief]")
x$ = "[Relief]" + FLASTNAME$(ip, tm)
CALL AddToScoreCrd (it, 0, "X", x$)
'Games-Played-By-Position (use normal pitcher ref no)
IF GpPos(n, tm, 1) = 0 THEN GpPos(n, tm, 1) = 1
'Fix: 02/23/05
'Find ex-pitcher's clone and mark as used
SearchName$ = DataName(otherguy, tm)
nc = SearchDAT (LastPiAd(tm)+1, MAXPLAYERS, tm, SearchName$, 0)
IF nc THEN iused(nc, tm) = TRUE
END IF
EXIT DO
END IF
LOOP
LOOP UNTIL DoneSw
IF Gfx THEN CALL EliminateHole(30)
LOCATE 1, 1
END SUB
SUB DefSwitchSetup (kc, Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
rowx = rowO
colx = colO
IF ConsRows > 28 THEN rowx = rowx + 2
CALL GetScreen(Scr1$, 20+rowx, 17+colx, 24+rowx, 66+colx)
CALL DrawFrm(20+rowx, 17+colx, 24+rowx, 66+colx, defattr, nulls$, "ESC:Continue F3:Cancel", 0, 0, 2)
FContents$(1) = "N"
Flds = 1
DATA 22,19,"Want to change defensive positioning? [y/N] ",22,63,01,"X "
c = 1
FOR i = 1 TO Flds
Flitrow(i) = VAL(READ$(c)) + rowx
Flitcol(i) = VAL(READ$(c+1)) + colx
Flit$(i) = READ$(c+2)
Frow(i) = VAL(READ$(c+3)) + rowx
Fcol(i) = VAL(READ$(c+4)) + colx
Flen(i) = VAL(READ$(c+5))
Fed$(i) = READ$(c+6)
c = c + 7
NEXT
CursorPtr = 1
DO
s = defattr
defattr = dimattr
CALL ScreenIO(Keyed, KeyF3, 0, KeyEsc, Flds, CursorPtr, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
defattr = s
ErrorSw$ = "N"
'Cancel
IF Keyed = KeyF3 THEN EXIT DO
IF FContents$(1) <> "Y" AND FContents$(1) <> "N" THEN ErrorSw$ = "Y"
LOOP WHILE ErrorSw$ = "Y"
kc = Keyed
CALL PutScreen(Scr1$, 20+rowx, 17+colx, 24+rowx, 66+colx)
END SUB
SUB DelFrMMList (xS$)
a$ = xS$
i = INSTR(a$, ".")
IF i THEN a$ = LEFT$(a$, i - 1)
a$ = RTRIM$(a$)
Found = FALSE
i = 0
DO
INCR i
IF i > MMx THEN EXIT DO
IF RTRIM$(MMList(i).MMFile) = a$ THEN
FOR j = i + 1 TO MMx
MMList(j - 1) = MMList(j)
NEXT
MMList(MMx).MMFile = nulls$
DECR MMx
EXIT DO
END IF
LOOP
END SUB
SUB Defens (StepThrough)
STATIC xS$, zS$
IF Gfx = FALSE AND (ConsRows = 25 AND ConsCols = 80) THEN
'Bases
xS$ = CHR$(4) 'little diamond
r = MidRow + 8: c = MidCol - 1: GOSUB PRINTIT
r = MidRow : c = MidCol - 1: GOSUB PRINTIT
r = MidRow + 4: c = MidCol + 11: GOSUB PRINTIT
r = MidRow + 4: c = MidCol - 13: GOSUB PRINTIT
'Lower Diamond
xS$ = CHR$(249) ' little dot was 250
r = MidRow + 2: c = MidCol - 19: GOSUB PRINTIT
r = MidRow + 2: c = MidCol + 17: GOSUB PRINTIT
r = MidRow + 1: c = MidCol + 20: GOSUB PRINTIT
'Upper diamond
r = MidRow + 2: c = MidCol - 7: GOSUB PRINTIT
r = MidRow + 2: c = MidCol + 5: GOSUB PRINTIT
'Inf-outf border
r = MidRow + 1: c = MidCol - 15: GOSUB PRINTIT
r = MidRow - 1: c = MidCol - 11: GOSUB PRINTIT
r = MidRow - 2: c = MidCol - 5: GOSUB PRINTIT
r = MidRow - 2: c = MidCol + 3: GOSUB PRINTIT
r = MidRow - 1: c = MidCol + 9: GOSUB PRINTIT
r = MidRow + 1: c = MidCol + 13: GOSUB PRINTIT
'Foul lines
r = MidRow - 3: c = MidCol + 32: GOSUB PRINTIT
r = MidRow - 3: c = MidCol - 34: GOSUB PRINTIT
END IF
'Get rid of old holes/or erase positions
IF Gfx THEN
FOR p = 1 TO 9
CALL EliminateHole(20+p)
NEXT
ELSE
zS$ = SPACE$(11)
FOR p = 2 TO 9
CALL DefCoordinates (p, r, c, ObsD, ObsY, ObsH, ObsTz, ObsTy)
IF r > 0 AND c > 0 THEN
QPRINTs r, c, zS$, fldattr
END IF
NEXT
END IF
'Refresh screen after eliminating the defense
IF DelFac > 0 AND StepThrough > 0 THEN
IF Gfx THEN GfxRefresh 0
CALL Delay(StepThrough/1000.0##)
END IF
IF DelFac = 0 THEN
IF Gfx THEN GfxWindow %GFX_FREEZE
END IF
'Batting order box borders
'Left
b1r1 = ConsRows - 12
b1c1 = 2
b1r2 = b1r1 + 10
b1c2 = 18
'Right
b2r1 = ConsRows - 12
b2c1 = ConsCols - 17
b2r2 = b2r1 + 10
b2c2 = ConsCols - 1
'Left team label:
l1r1 = ConsRows - 14
l1c1 = 4
l1r2 = l1r1
l1c2 = l1c1 + LEN(RTRIM$(Names(1))) - 1
'Right team label:
l2r1 = ConsRows - 14
l2c1 = ConsCols - 15
l2r2 = l2r1
l2c2 = l2c1 + LEN(RTRIM$(Names(2))) - 1
'Stick in the player names
FOR p = 1 TO 9
CALL DefCoordinates (p, r, c, ObsD, ObsY, ObsH, ObsTz, ObsTy)
IF r > 0 AND c > 0 THEN
k = WHOATGUY(p)
xS$ = LASTNAME$(DataName(k, id))
xS$ = LEFT$(xS$, 11)
IF p = 1 THEN GOSUB PitchLabel: b=14 ELSE b=11
w = LEN(xS$)
ce = c + w - 1
cf = ce
ca = 0
cb = 0
'Does any part of the name overlap the batting orders?
'Try left batting order
FOR i = c TO ce
IF Inbox(b1r1, b1c1, b1r2, b1c2, r, i, -1) THEN
IF cb = 0 THEN cb = i
ELSE
IF ca = 0 THEN ca = i
END IF
NEXT
IF cb = 0 THEN
'We didn't clip anything
'Try right batting order
ca = 0
FOR i = c TO ce
IF Inbox(b2r1, b2c1, b2r2, b2c2, r, i, -1) THEN
IF cb = 0 THEN cb = i
ELSE
IF ca = 0 THEN ca = i
END IF
NEXT
END IF
IF cb = 0 THEN
'We still didn't clip anything
'try left team label
ca = 0
FOR i = c TO ce
IF Inbox(l1r1, l1c1, l1r2, l1c2, r, i, -1) THEN
IF cb = 0 THEN cb = i
ELSE
IF ca = 0 THEN ca = i
END IF
NEXT
END IF
IF cb = 0 THEN
'We still didn't clip anything
'try right team label
ca = 0
FOR i = c TO ce
IF Inbox(l2r1, l2c1, l2r2, l2c2, r, i, -1) THEN
IF cb = 0 THEN cb = i
ELSE
IF ca = 0 THEN ca = i
END IF
NEXT
END IF
IF cb = 0 THEN 'we never did clip anything
ca = c
cf = ce
ELSE
IF ca > 0 THEN
IF cb > ca THEN 'clipped on right
xS$ = MID$(xS$, 1, cb-ca)
cf = cb - 1
ELSE 'clipped on left
xS$ = MID$(xS$, ca-c+1)
cf = ce
END IF
END IF
END IF
'Erase
IF Gfx THEN
IF ca THEN CALL GraphHole(20+p, r, ca, r, cf)
ELSE
QPRINTs r, c, SPACE$(b), fldattr
END IF
'Replace by:
IF ca THEN
IF TeamAttr(id) <> 0 THEN kk = TeamAttr(id) ELSE kk = fldattr
QPRINTs r, ca, xS$, kk
END IF
'Map where to put the baserunners on the screen
IF p = 3 THEN BasPatRow(1) = r + 1: BasPatCol(1) = c - 3
IF p = 6 THEN BasPatRow(2) = r + 1: BasPatCol(2) = c + 3
IF p = 5 THEN
IF Gfx = FALSE AND (ConsRows = 25 AND ConsCols = 80) THEN
BasPatRow(3) = r + 1
ELSE
BasPatRow(3) = r + 2
END IF
BasPatCol(3) = c - 2
END IF
IF p = 1 THEN BasPatRow(5) = r + 2: BasPatCol(5) = c
IF DelFac > 0 AND StepThrough > 0 THEN
IF Gfx THEN GfxRefresh 0
CALL Delay(StepThrough/1000.0##)
END IF
END IF
NEXT
IF DelFac = 0 THEN
IF Gfx THEN GfxWindow NOT %GFX_FREEZE
END IF
'Re-do what defense may have overwritten
IF Gfx = FALSE AND (ConsRows = 25 AND ConsCols = 80) THEN
QPRINTs 14+rowO, 33+colO, CHR$(249), fldattr
END IF
GOTO DefensEXIT
PRINTIT:
QPRINTs r, c, xS$, fldattr
RETURN
PitchLabel:
IF UCASE$(DataHand(ip, id)) = "R" THEN
xS$ = "[R]" + xS$
ELSE
xS$ = xS$ + "[L]"
END IF
RETURN
ErrorTrap:
LOCATE 10, 30
PRINT "ERROR: Defens "; ERRCLEAR
LOCATE 11, 30
x$ = WAITKEY$
DefensEXIT:
END SUB
SUB DEFFix(r, c)
IF SCREEN(r, c) = 32 THEN
QPRINTs r, c, CHR$(249), fldattr
END IF
END SUB
SUB DisplayKeysAndEdit (ParentFrame AS BoxType, ChildFrame AS BoxType, myfile$, RecLen, Flds, Fpos(), Flen(), Flitrow(), Flitcol(), Flit$(), Frow(), Fcol(), Fed$())
' Displays list of "keys" in random access file and waits for your pick to edit
'
' row1, etc = screen location of parent "key" window
' recrow1, etc = screen location of child "record" window
'
DIM FirstRecNum(100) '100 pages max
DIM PageRecNum(120) '120 keys on a page max
KeyEsc = 27
KeyRet = 13
KeyRtab = 9
KeyLtab = -15
KeyUp = -72
KeyDown = -80
KeyLeft = -75
KeyRight = -77
KeyBack = 8
KeyIns = -82
KeyDel = -83
KeyPgUp = -73
KeyPgDn = -81
COLOR dimfor, dimbac
pageno = 1
PageKeyPtr = 1
FirstRecNum(1) = 1
IF LEN(DIR$(myfile$)) = 0 THEN
BEEP
FileNum = FREEFILE
OPEN myfile$ FOR BINARY AS FileNum
RecBuff$ = SPACE$(RecLen)
MID$(RecBuff$, 1, 1) = "D"
MID$(RecBuff$, 3, 8) = STRING$(8, 0)
SEEK #FileNum, 1
PUT$ #FileNum, RecBuff$
CLOSE FileNum
END IF
FileNum = FREEFILE
OPEN myfile$ FOR BINARY AS FileNum
'Set KeyPos and KeyLen to first input field
KeyFldNdx = 0
GOSUB FindNextDataField
KeyPos = Fpos(KeyFldNdx)
KeyLen = Flen(KeyFldNdx)
Reentry:
LOCATE 1, 1
CURSOR OFF
NumberOfRecords = LOF(FileNum) \ RecLen
Columns = (ParentFrame.col2 - ParentFrame.col1 - 1) \ (KeyLen + 2)
IF Columns = 0 THEN Columns = 1
KeysInColumn = ParentFrame.row2 - ParentFrame.row1 - 1
PageMaxKeys = KeysInColumn * Columns
RecNumber = FirstRecNum(pageno)
PageKeyCtr = 1
PageFull = False
EofReached = False
DO UNTIL PageFull
'don't read past EoF
IF RecNumber > NumberOfRecords THEN
EofReached = True
PageFull = True
EXIT DO
END IF
SEEK #FileNum, (RecNumber - 1) * RecLen + 1
GET$ #FileNum, RecLen, RecBuff$
'logic to skip records marked delete
DO WHILE MID$(RecBuff$, 1, 1) = "D" AND RecNumber < NumberOfRecords
INCR RecNumber
SEEK #FileNum, (RecNumber - 1) * RecLen + 1
GET$ #FileNum, RecLen, RecBuff$
LOOP
IF RecNumber >= NumberOfRecords AND MID$(RecBuff$, 1, 1) = "D" THEN
EofReached = True
PageFull = True
EXIT DO
END IF
'given a PageKeyCtr, store the relative record number
PageRecNum(PageKeyCtr) = RecNumber - FirstRecNum(pageno) + 1
'figure where to locate
stak = (PageKeyCtr - 1) \ KeysInColumn + 1
c = ParentFrame.col1 + (stak - 1) * (KeyLen + 2) + 2
r = ParentFrame.row1 + PageKeyCtr - (stak - 1) * KeysInColumn
IF PageKeyCtr = PageKeyPtr THEN
attr = revattr
HighLiteR = r: HighLiteC = c
END IF
QPRINTs r, c, MID$(RecBuff$, KeyPos, KeyLen), attr
IF PageKeyCtr = PageKeyPtr THEN attr = dimattr
INCR PageKeyCtr
INCR RecNumber
IF PageKeyCtr > PageMaxKeys THEN PageFull = True
LOOP
'Wait for arrow keys / insert / esc / PageUp / PageDown / Enter
DO
mous = 0
msx = 0
msy = 0
KyS$ = WAITKEY$
s% = INSHIFT
IF LEN(KyS$) = 1 THEN
kc = ASC(KyS$)
KyS$ = UCASE$(KyS$)
ELSEIF LEN(KyS$) = 2 THEN
kc = -ASC(RIGHT$(KyS$, 1))
ELSEIF LEN(KyS$) = 4 THEN
IF ASC(KyS$, 3) = 2 THEN
DoubleClick = TRUE
ELSE
DoubleClick = FALSE
END IF
mous = TRUE
msx = MOUSEX
msy = MOUSEY
ms$ = CHR$(SCREEN(msy, msx))
IF ms$ = 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, FALSE)
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, FALSE)
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
ir2 = 0
j = 4
ELSEIF ir1 AND (xF! < .5 OR HitandRun = TRUE) THEN
'5-3
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
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, FALSE)
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, FALSE)
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$
Repl$ = "N"
END IF
CmdVP$ = nulls$
END IF
IF tm = 2 THEN
IF CmdHP$ <> nulls$ THEN
Method$ = CmdHP$
Repl$ = "Y"
ELSE
Method$ = CmdSP$
Repl$ = "N"
END IF
CmdHP$ = nulls$
END IF
CALL AutoPitcher (tm, Method$, Repl$, N) 'Returns N
OriginalSelection = N
IF (tm = 1 AND CmdVSpot$ = "Y") OR _
(tm = 2 AND CmdHSpot$ = "Y") OR _
CmdSpot$ = "Y" THEN
'Possible Spot Starter
ELSE
'No Spot Starter, we are done
GOTO AssignPitcher
END IF
'Possible Spot Starter
NumInRot = VAL(MID$(Method$, 2, 1))
'Calculate Total Starts by ALL Pitchers
TotStarts = 0
FOR i = 10 TO LastPiAd(tm)
TotStarts = TotStarts + DataGbyP(i, tm, 1)
NEXT
IF TotStarts = 0 THEN GOTO AssignPitcher
xF! = RND
IF xF! > ((DataGbyP(N, tm, 1) / TotStarts) * NumInRot) OR _
(DaysOffRule = TRUE AND GetDaysOff(N, tm) > 0) THEN 'Pitcher is tired
'Pick a Spot Starter
r = ROTATIONLIST (DataFil(tm)) 'Find Rot record for this team
IF r = 0 THEN
x$ = "AutoPit: Spot Starter Error: " + DataFil(tm)
CALL ErrorBox (x$)
END IF
'Calculate starts by pitchers NOT in current rotation
SpotStarts = 0
j = 0
FOR i = 10 TO LastPiAd(tm)
'Is "i" already in rotation?
SkipIt = FALSE
FOR k = 1 TO 5
IF RotRec(r).RotList(k) = i THEN SkipIt = TRUE
NEXT
IF NOT SkipIt THEN
SpotStarts = SpotStarts + DataGbyP(i, tm, 1)
INCR j
BrkTbl(j).PctOfTot = 0
BrkTbl(j).Slot = 0
END IF
NEXT
IF SpotStarts = 0 THEN GOTO AssignPitcher
'For these pitchers not in the current rotation:
'Calculate percentage of "spot starts" they had
j = 0
FOR i = 10 TO LastPiAd(tm)
'Is "i" already in rotation?
SkipIt = FALSE
FOR k = 1 TO 5
IF RotRec(r).RotList(k) = i THEN SkipIt = TRUE
NEXT
IF NOT SkipIt THEN
INCR j
BrkTbl(j).PctOfTot = DataGbyP(i, tm, 1) / SpotStarts
BrkTbl(j).Slot = i
END IF
NEXT
try = 1
TryAgain:
xF! = RND
N = 0
BaseP! = 0
FOR i = 1 TO j
IF xF! < BaseP! + BrkTbl(i).PctOfTot THEN
N = BrkTbl(i).Slot
EXIT FOR
END IF
BaseP! = BaseP! + BrkTbl(i).PctOfTot
NEXT
IF N = 0 THEN N = BrkTbl(j).Slot
'Try to avoid tired pitchers
IF CmdStat$ > "!" AND DaysOffRule = TRUE THEN
IF GetDaysOff(N, tm) THEN
'He's tired! Try again.
INCR try
IF try < 5 THEN GOTO TryAgain
N = OriginalSelection
END IF
END IF
END IF
AssignPitcher:
ipa(tm) = N
np(tm) = 1
iyp(1, tm) = N
CALL AssignFatigue (tm)
NEXT 'tm
ERASE BrkTbl
END SUB
SUB GetScreen (ScrSave$, row1, col1, row2, col2)
ScrSave$ = SPACE$((row2 - row1 + 1) * (col2 - col1 + 1) * 2)
i = 1
FOR r = row1 TO row2
FOR c = col1 TO col2
b = SCREEN(r, c)
a = SCREENATTR(r, c)
x$ = CHR$(b) + CHR$(a)
MID$(ScrSave$, i, 2) = x$
i = i + 2
NEXT
NEXT
END SUB
SUB GetScrollKey (kc, RowOff, ColOff)
Donex = FALSE
DO
KyS$ = WAITKEY$
KyS$ = UCASE$(KyS$)
IF LEN(KyS$) = 1 THEN
kc = ASC(KyS$)
ELSEIF LEN(KyS$) = 2 THEN
kc = -ASC(RIGHT$(KyS$, 1))
ELSEIF LEN(KyS$) = 4 THEN
msx = MOUSEX
msy = MOUSEY
CALL FlashField (msy, msx, 1, 2, 100, 0)
kc = SCREEN(msy, msx)
IF kc = 118 THEN ' "v"
KyS$ = CHR$(kc)
ELSE
KyS$ = UCASE$(CHR$(kc))
kc = ASC(KyS$)
END IF
SELECT CASE KyS$
CASE UpPtr$
kc = -72
CASE DnPtr$
kc = -80
CASE LPtr$
kc = -75
CASE RPtr$
kc = -77
CASE CloseButton$ 'normal escape
kc = 27
CASE ELSE
END SELECT
END IF
' ESC
IF kc = 27 THEN
Donex = TRUE
' S (swap)/ M (more lineups) special cases
ELSEIF kc = 83 OR kc = 77 THEN
Donex = TRUE
' Left-arrow
ELSEIF kc = -75 AND ColOff > 0 THEN
ColOff = ColOff - 10
Donex = TRUE
' Right-arrow
ELSEIF kc = -77 AND ColOff < 72 THEN
ColOff = ColOff + 10
Donex = TRUE
' Up arrow
ELSEIF kc = -72 AND RowOff > 0 THEN
DECR RowOff
Donex = TRUE
' Down arrow
ELSEIF kc = -80 AND RowOff < 30 THEN 'sets maximum number "downs" (was 10)
INCR RowOff
Donex = TRUE
'Emergency escape for testing
' ELSEIF kc = 32 THEN
' Donex = TRUE
ELSE
MyBeep
END IF
LOOP UNTIL Donex
LOCATE 1, 1
'EXIT SUB
'FlashMouse:
'CALL FlashField (msy, msx, 1, 2, 100, 0)
'RETURN
END SUB
SUB Gone
IF SoundOn THEN
ANx = 0
AddToAnnouncer id, "Home Run by " + FULLNAME$(DataName(ib, it))
CALL PostAnnouncer (TRUE, FALSE)
END IF
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
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
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)
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 12,07,"Audio Announcer [y/n] ", 12,32,01,"XR"
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 = 11
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
FContents$(9) = "Y" 'Audio Announcer
IF Year(1) <> Year(2) THEN 'Normalization
FContents$(10) = "H"
ELSE
FContents$(10) = ""
END IF
FContents$(11) = "N" 'Focusing
IF CmdStat$ < "!" THEN FLen(11) = -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$)
IF Selection$ = "" THEN 'Make no changes
Selection$ = FContents$(8)
END IF
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$(10))
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 = 10: 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 = 10: 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 = 10: GOTO GroundRuleLoop
END IF
IF FContents$(9) <> "Y" AND FContents$(9) <> "N" THEN
Error1$ = "Y": CursorPtr = 9: CALL MyBeep: GOTO GroundRuleLoop
END IF
IF FContents$(11) <> "Y" AND FContents$(11) <> "N" THEN
Error1$ = "Y": CursorPtr = 11: 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")
BackgroundPic$ = RTRIM$(FContents$(8))
AnnouncerOn = (FContents$(9) = "Y")
CmdEra$ = RTRIM$(FContents$(10))
CmdFocus$ = FContents$(11)
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$)
' TYPE BufType
' BufferItem AS STRING * 210
' END TYPE
MaxPasses = 1000
REDIM PassPosD(MaxPasses) AS LONG
'Check if File Exists
IF LEN(DIR$(FileN$)) = 0 THEN
PRINT FileN$; " not found in the current directory."
EXIT SUB
END IF
MaxLinesInPass = 815
REDIM Buffer(1 TO MaxLinesInPass) AS BufType
' Read through entire file, figure out positions in file when we
' need a "pass break". Go ahead and put first pass into memory.
D& = 1
LastPass = 0
ErrorSw = 0
File = 70
OPEN FileN$ FOR INPUT AS #File
DO UNTIL EOF(File)
IF D& MOD MaxLinesInPass THEN
CurrPass = INT(D& / MaxLinesInPass) + 1
ELSE
CurrPass = INT(D& / MaxLinesInPass)
END IF
IF CurrPass > MaxPasses THEN
CurrPass = CurrPass - 1
ErrorSw = -1
EXIT DO
END IF
IF CurrPass <> LastPass THEN
PassPosD(CurrPass) = SEEK(File)
LastPass = CurrPass
END IF
IF CurrPass = 1 THEN
LINE INPUT #File, xS$
Buffer(D&).BufferItem = xS$
ELSE
xS$ = ""
LINE INPUT #File, xS$
END IF
INCR D&
LOOP
LastLineInFileD& = D& - 1
TotalPasses = CurrPass
'find the last \
l = LEN(FileN$)
i = l
DO
IF MID$(FileN$, i, 1) = "\" THEN EXIT DO
i = i - 1
LOOP WHILE i > 0
IF i = 0 THEN short$ = FileN$ ELSE short$ = MID$(FileN$, i + 1)
COLOR dimfor, dimbac
attr = CalcAttr(0, 7)
CURSOR OFF
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, "<File Size Limit Exceeded>", defattr
ELSE
QPRINTs linenoD& - begD& + 1, 1, "<End of File>" + 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, "<New Page>", 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 IF
IF KyS$ = "B" OR KyS$ = "b" THEN
IF LastLineInFileD& - (ConsRows-2) > 0 THEN begD& = LastLineInFileD& - (ConsRows-2) ELSE begD& = 1
END IF
IF KyS$ = "P" OR KyS$ = "p" THEN
CALL PopMsg(13+rowO, 30+colO, "Launching WORDPAD.", errattr, 1, kc2)
'Launch WordPad
CLOSE #File
SLEEP 500
SHELL WordPadSpec$ + " " + FileN$
SLEEP 500
OPEN FileN$ FOR INPUT AS #File
MouseDown = FALSE
END IF
IF KyS$ = "S" OR KyS$ = "s" THEN 'Save As
CALL Drawfrm(12+rowO, 22+colO, 14+rowO, 58+colO, defattr, "Save As...", "ENTER:Save ESC:Cancel", 1, 0, 0)
OldFile$ = RTRIM$(FileN$)
NewFile$ = RTRIM$(MYINPUT$(FALSE, EscKey, CustomEscKey, 13, kc2, revfor, revbac, 13+rowO, 24+colO, 32, " E", 0, 0, OldFile$, msx, msy))
MouseDown = FALSE
'No mouse support
IF kc2 = KeyEsc THEN GOTO ListerTestLoop
IF UCASE$(RTRIM$(NewFile$)) = UCASE$(RTRIM$(FileN$)) THEN GOTO ListerTestLoop
IF NewFile$ < "!" THEN GOTO ListerTestLoop
CLOSE #File
SLEEP 500
FILECOPY RTRIM$(FileN$), NewFile$
SLEEP 500
OPEN FileN$ FOR INPUT AS #File
END IF
ListerTestLoop:
LOOP UNTIL kc = 27 'Escape
MOUSE 3, DOUBLE, DOWN
CLOSE #File
ERASE Buffer
ERASE PassPosD
EXIT SUB
FlashMouse:
CALL FlashField (msy, msx, 1, 2, 100, revattr)
RETURN
END SUB
SUB LoadFilesToList1 (FileMask$, List1() AS List1Type, Limit, n)
f$ = UCASE$(DIR$(FileMask$))
DO
IF f$ > "!" THEN
Reject = FALSE 'Win 2K/XP patch
IF FileMask$ = "*. " THEN
L = LEN(f$)
IF MID$(f$, L-3, 1) = "." THEN Reject = TRUE
END IF
IF NOT Reject THEN
INCR n
IF n <= Limit THEN
List1(n).ListItem = f$
ELSE
x$ = "Exceeded program limits on number of files"
CALL ErrorBox (x$)
EXIT SUB
END IF
END IF
END IF
f$ = UCASE$(DIR$)
LOOP WHILE f$ > "!"
END SUB
SUB LoadPbyP
ON ERROR GOTO LPP_ErrorTrap
DIM CurrClass$(10)
DIM CurrPos$(10)
DIM CurrSeq$(10)
DIM CurrTrk$(20)
ndx = 0
OPEN "baseball.msg" FOR INPUT AS #1
DO UNTIL EOF(1)
LINE INPUT #1, rec$
c1$ = MID$(rec$, 1, 1)
IF c1$ = ";" THEN
IF EOF(1) THEN
EXIT DO
ELSE
ITERATE DO
END IF
END IF
IF c1$ = "C" THEN
cc = 0
cp = 0
cs = 0
ct = 0
GOSUB ParseRec
FOR i = 1 TO n
CurrClass$(i) = PARSE$(x$, i)
NEXT
cc = n
ELSEIF c1$ = "P" THEN
cp = 0
cs = 0
ct = 0
GOSUB ParseRec
FOR i = 1 TO n
CurrPos$(i) = PARSE$(x$, i)
NEXT
cp = n
ELSEIF c1$ = "S" THEN
cs = 0
ct = 0
GOSUB ParseRec
FOR i = 1 TO n
CurrSeq$(i) = PARSE$(x$, i)
NEXT
cs = n
ELSEIF c1$ = "D" THEN
ct = 0
GOSUB ParseRec
FOR i = 1 TO n
CurrTrk$(i) = PARSE$(x$, i)
NEXT
ct = n
ELSEIF c1$ = " " THEN
ccc = 1
DO
cpc = 1
DO
csc = 1
DO
ctc = 1
DO
INCR ndx
IF ndx > 1500 THEN
PRINT "Too many Play-by-Play lines!"
SLEEP 1000
EXIT SUB
END IF
IF cc > 0 THEN
PbyP(ndx).class = PADZEROS$(CurrClass$(ccc), 2)
ELSE
PbyP(ndx).class = "00"
END IF
IF cp > 0 THEN
PbyP(ndx).pos = CurrPos$(cpc)
ELSE
PbyP(ndx).pos = "0"
END IF
IF cs > 0 THEN
PbyP(ndx).seq = CurrSeq$(csc)
ELSE
PbyP(ndx).seq = "0"
END IF
IF ct > 0 THEN
PbyP(ndx).trk = PADZEROS$(CurrTrk$(ctc), 2)
ELSE
PbyP(ndx).trk = "00"
END IF
PbyP(ndx).pndx = " "
PbyP(ndx).text = MID$(rec$, 7)
INCR ctc
LOOP UNTIL ctc > ct
INCR csc
LOOP UNTIL csc > cs
INCR cpc
LOOP UNTIL cpc > cp
INCR ccc
LOOP UNTIL ccc > cc
END IF
LOOP
CLOSE #1
REDIM PRESERVE PbyP(ndx) AS GLOBAL PbyPType
PbyP_Cnt = ndx
ARRAY SORT PbyP(1) FOR PbyP_Cnt, FROM 1 TO 6, ASCEND
'PRINT "PbyP_Cnt: "; PbyP_Cnt
'Stick in the "tie-breaker index"
i = 1
key$ = PbyP(1).class + PbyP(1).pos + PbyP(1).seq + PbyP(1).trk
DO UNTIL i > PbyP_Cnt
savekey$ = key$
IDX = 0
DO UNTIL key$ <> savekey$ OR i > PbyP_Cnt
INCR IDX
x$ = LTRIM$(STR$(IDX))
x$ = PADZEROS$(x$, 3)
PbyP(i).pndx = x$
INCR i
IF i <= PbyP_Cnt THEN
key$ = PbyP(i).class + PbyP(i).pos + PbyP(i).seq + PbyP(i).trk
END IF
LOOP
LOOP
EXIT SUB
ParseRec:
s = INSTR(rec$, " ")
IF s THEN
x$ = MID$(rec$, 3, s - 3)
ELSE
x$ = MID$(rec$, 3)
END IF
n = PARSECOUNT(x$)
RETURN
LPP_ErrorTrap:
LOCATE 10, 30
PRINT "LPP_Error"; ERRCLEAR
x$ = WAITKEY$
END SUB
SUB LoadScoreCardToList1 (List1() AS List1Type, j) 'j will return actual # of entries
i = 1
j = 0
LastTeam = 2
DO WHILE i <= SCx
IF SCRec(i).SCTeam <> LastTeam _
AND SCRec(i).SCCode <> "X" _
AND SCRec(i).SCCode <> "0" THEN
LastTeam = SCRec(i).SCTeam
IF j < 300 THEN
INCR j
zS$ = ": " + Names(LastTeam)
List1(j).ListItem = "~ Inn." + STR$(SCRec(i).SCInn) + zS$
END IF
END IF
IF SCRec(i).SCRef > 0 THEN
player = SCRec(i).SCRef
team = SCRec(i).SCTeam
GOSUB SCGetName 'in yS$
ELSE
yS$ = ""
END IF
IF SCRec(i).SCCode = " " THEN 'normal'
xS$ = PADRIGHT$(yS$, 18)
ELSEIF SCRec(i).SCCode = "X" THEN 'free format
xS$ = SCRec(i).SCResult
GOTO SCINC
ELSEIF SCRec(i).SCCode = "9" THEN 'PH/PR replacement
xS$ = "*EX:" + yS$ + " " + _
LEFT$(SCRec(i).SCResult, 10)
GOTO SCINC
ELSEIF SCRec(i).SCCode = "8" THEN 'PH
xS$ = "*PH:" + PADRIGHT$(yS$, 14)
ELSEIF SCRec(i).SCCode = "7" THEN
xS$ = "*PR:" + yS$ 'PR
GOTO SCINC
ELSEIF SCRec(i).SCCode = "6" THEN 'SB
xS$ = "*SB:" + PADRIGHT$(yS$, 14)
ELSEIF SCRec(i).SCCode = "5" THEN
xS$ = PADRIGHT$(yS$, 18) 'WP/PB
ELSEIF SCRec(i).SCCode = "4" THEN
xS$ = "X@4:" + PADRIGHT$(yS$, 14) 'X4
ELSEIF SCRec(i).SCCode = "3" THEN
xS$ = "X@3:" + PADRIGHT$(yS$, 14) 'X3
ELSEIF SCRec(i).SCCode = "2" THEN
xS$ = "X@2:" + PADRIGHT$(yS$, 14) 'X2
ELSEIF SCRec(i).SCCode = "1" THEN
xS$ = "X@1:" + PADRIGHT$(yS$, 14) 'X1 PK-OFF
ELSEIF SCRec(i).SCCode = "0" THEN
xS$ = PADRIGHT$(yS$, 17) + " " 'Starting Lineup
xS$ = xS$ + LEFT$(SCRec(i).SCResult, 10)
GOTO SCINC
ELSEIF SCRec(i).SCCode = "A" THEN
'Flip teams for special case.
'Completely special case for listing pitchers on other side
'and defensive people swaped in in a double-switch.
player = SCRec(i).SCRef
team = 3 - SCRec(i).SCTeam
GOSUB SCGetName
xS$ = RTRIM$(SCRec(i).SCResult) + " " + yS$
GOTO SCINC
ELSE
xS$ = "- " + PADRIGHT$(yS$, 16)
END IF
xS$ = xS$ + LEFT$(SCRec(i).SCResult, 10) + _
SCRec(i).SCBase3 + _
SCRec(i).SCBase2 + _
SCRec(i).SCBase1 + _
SCRec(i).SCBase4
SCINC:
IF j < 300 THEN
INCR j
List1(j).ListItem = xS$
END IF
INCR i
LOOP
EXIT SUB
SCGetName: 'input: team, ref
yS$ = FLASTNAMER$(player, team)
RETURN
END SUB
SUB LoadSIMData (tm)
i = 1
DO WHILE i <= MAXPLAYERS
xS$ = DataName(i, tm)
ref = DataRef(i, tm)
IF i > LastPiAd(tm) THEN
IF xS$ < "!" THEN EXIT DO
END IF
IF ref < 1 OR ref > MAXPLAYERS THEN
x$ = "Reference ptr out of bounds in LoadSIMData.|Ref:"
x$ = x$ + STR$(ref) + " Max:" + STR$(MAXPLAYERS)
x$ = x$ + "|" + xS$ + " " + RTRIM$(Names(tm))
MyBEEP
CALL ErrorBox (x$)
END IF
'Look up everybody's hitting record, including pitchers
FoundAt = 0
Find$ = League(tm)
Find$ = Find$ + PADRIGHT$(Names(tm), 12)
Find$ = Find$ + PADRIGHT$(xS$, 16)
TotalRecs = BSum(0).BGameCtr
CALL BinarySearchB (BSum(), 1, 29, 1, TotalRecs, Find$, FoundAt, mini)
IF FoundAt = 0 THEN
BSum(FoundAt).BGames = 0
BSum(FoundAt).BABs = 0
BSum(FoundAt).BHits = 0
BSum(FoundAt).BBBs = 0
BSum(FoundAt).BKs = 0
BSum(FoundAt).BHRs = 0
BSum(FoundAt).BRBIs = 0
BSum(FoundAt).BStreak = 0
END IF
SimGames(ref, tm) = BSum(FoundAt).BGames
SimAB(ref, tm) = BSum(FoundAt).BABs
SimHits(ref, tm) = BSum(FoundAt).BHits
SimBB(ref, tm) = BSum(FoundAt).BBBs
SimSO(ref, tm) = BSum(FoundAt).BKs
SimHR(ref, tm) = BSum(FoundAt).BHRs
SimRBI(ref, tm) = BSum(FoundAt).BRBIs
SimBStreak(ref, tm) = BSum(FoundAt).BStreak
IF ref > 9 AND ref <= LastPiAd(tm) THEN
IF ref < 10 OR ref > TopPitLim THEN
x$ = "Reference ptr not in pitcher range.|Ref:" + STR$(ref)
BEEP
CALL ErrorBox (x$)
END IF
'A Pitcher's Reference Number, so look up pitching history
FoundAt = 0
Find$ = League(tm)
Find$ = Find$ + PADRIGHT$(Names(tm), 12) + PADRIGHT$(xS$, 16)
TotalRecs = PSum(0).PGameCtr
CALL BinarySearchP (PSum(), 1, 29, 1, TotalRecs, Find$, FoundAt, mini)
IF FoundAt = 0 THEN
PSum(FoundAt).PInns = 0
PSum(FoundAt).P3rds = 0
PSum(FoundAt).PWin = 0
PSum(FoundAt).PLoss = 0
PSum(FoundAt).PERuns = 0
PSum(FoundAt).PHits = 0
PSum(FoundAt).PBBs = 0
PSum(FoundAt).PSOs = 0
PSum(FoundAt).PSave = 0
PSum(FoundAt).PDaysOff = 0
END IF
SimInn(ref, tm) = PSum(FoundAt).PInns + PSum(FoundAt).P3rds / 3
SimWins(ref, tm) = PSum(FoundAt).PWin
SimLosses(ref, tm) = PSum(FoundAt).PLoss
SimHitsAlw(ref, tm) = PSum(FoundAt).PHits
SimERuns(ref, tm) = PSum(FoundAt).PERuns
SimBBAlw(ref, tm) = PSum(FoundAt).PBBs
SimSO_P(ref, tm) = PSum(FoundAt).PSOs
SimSaves(ref, tm) = PSum(FoundAt).PSave
DaysOff = PSum(FoundAt).PDaysOff
IF CmdSch$ > "!" THEN
Now = JDATE(SchDate$)
Last = PSum(FoundAt).PJDate
DaysOff = DaysOff - (Now - Last) + 1
IF DaysOff < 0 THEN DaysOff = 0
IF DaysOff > 4 THEN DaysOff = 4
END IF
SimDaysOff(ref, tm) = DaysOff
END IF
INCR i
LOOP
END SUB
SUB LoadStadiumToList (List1() AS List1Type, choices)
'FileLimit = 200
'REDIM List1(1 TO FileLimit) AS List1Type
OPEN "STADIUM.TXT" FOR INPUT AS #1 LEN = 128
n = 1
List1(n).ListItem = "--NONE--"
DO WHILE NOT EOF(1)
LINE INPUT #1, rec$
rec$ = UCASE$(rec$)
IF MID$(rec$, 1, 1) <> "*" THEN
INCR n
fn$ = MID$(rec$, 1, 20)
st$ = RTRIM$(MID$(rec$, 53, 26))
cy$ = RTRIM$(MID$(rec$, 80, 20))
cr$ = RTRIM$(MID$(rec$, 100, 16))
x$ = fn$ + PADRIGHT$(st$ + ", " + cy$, 35) + cr$
List1(n).ListItem = x$
END IF
LOOP
CLOSE #1
choices = n
END SUB
SUB Logo (zS$)
c1 = (ConsCols - 57) \ 2 '75 65
c2 = ConsCols - c1
r1 = (ConsRows - 21) \ 2
r2 = ConsRows - r1
IF Gfx THEN
CALL GraphHole(32, r1, c1, r2, c2)
END IF
attr = dimattr
CALL Drawfrm(r1, c1, r2, c2, defattr, "Copyright 1988-2012 ----------------", "", 0, 0, 0)
xS$ = "David B. Schmidt"
IF CODESUM(xS$) <> 1380 THEN
QPRINTs r1+13, c1+19, "TAMPERING DETECTED!!!", defattr
SLEEP 4000
zS$ = "Q"
END IF
QPRINTs r1, c1+31, xS$, defattr
c = c1 + 2
r = r1 + 2
IF ConsRows = 25 THEN BeginBuffer
QPRINTs r+ 5, c, " * *", attr
QPRINTs r+ 6, c, " * *", attr
QPRINTs r+ 7, c, " * *", attr
QPRINTs r+ 8, c, " ", attr
QPRINTs r+ 9, c, " * *", attr
QPRINTs r+10, c, " * *", attr
QPRINTs r+11, c, " * * *", attr
QPRINTs r+12, c, " * * * *", attr
QPRINTs r+13, c, " * * * *", attr
QPRINTs r+14, c, " * SBS *", attr
QPRINTs r+15, c, " * *", attr
QPRINTs r+16, c, " * *", attr
QPRINTs r+17, c, " *", attr
'QPRINTs r+18, c+9, " ", attr
QPRINTs r+19, c+14, "Version 4.9.3 2012.06.04", attr
'STRATEGIC
cS$ = ""
i = 1
DO
xS$ = READ$(i)
IF xS$ <> "Z" THEN
cS$ = cS$ + CHR$(VAL(xS$))
INCR i
ELSE
EXIT DO
END IF
LOOP
DATA 32,201,205,205,32,205,203,205,32,201,205,205,187,32,201,205,205,187,32
DATA 205,203,205,32,201,205,205,32,201,205,205,187,32,32,203,32,32,201,205,187
DATA Z
QPRINTs r, c+7, cS$, attr
cS$ = ""
INCR i
DO
xS$ = READ$(i)
IF xS$ <> "Z" THEN
cS$ = cS$ + CHR$(VAL(xS$))
INCR i
ELSE
EXIT DO
END IF
LOOP
DATA 32,200,205,187,32,32,186,32,32,204,205,203,188,32,204,205,205,185,32,32
DATA 186,32,32,204,205,205,32,186,32,205,187,32,32,186,32,32,186
DATA Z
QPRINTs r+1, c+7, cS$, attr
cS$ = ""
INCR i
DO
xS$ = READ$(i)
IF xS$ <> "Z" THEN
cS$ = cS$ + CHR$(VAL(xS$))
INCR i
ELSE
EXIT DO
END IF
LOOP
DATA 32,205,205,188,32,32,202,32,32,202,32,202,32,32,202,32,32,202,32,32
DATA 202,32,32,200,205,205,32,200,205,205,188,32,32,202,32,32,200,205,188
DATA Z
QPRINTs r+2, c+7, cS$, attr
'BASEBALL
cS$ = ""
INCR i
DO
xS$ = READ$(i)
IF xS$ <> "Z" THEN
cS$ = cS$ + CHR$(VAL(xS$))
INCR i
ELSE
EXIT DO
END IF
LOOP
DATA 32,219,223,223,223,220,32,32
DATA 219,223,223,223,219,32,32
DATA 219,223,223,219,32,32
DATA 219,223,223,223,219,32,32
DATA 219,223,223,223,220,32,32
DATA 219,223,223,223,219,32,32
DATA 219,32,32,32,32,32
DATA 219
DATA Z
QPRINTs r+4, c+1, cS$, attr
cS$ = ""
INCR i
DO
xS$ = READ$(i)
IF xS$ <> "Z" THEN
cS$ = cS$ + CHR$(VAL(xS$))
INCR i
ELSE
EXIT DO
END IF
LOOP
DATA 32, 219,220,220,220,219,32,32
DATA 219,220,220,220,219,32,32
DATA 219,220,220,220,32,32
DATA 219,220,220,220,32,32,32
DATA 219,220,220,220,219,32,32
DATA 219,220,220,220,219,32,32
DATA 219,32,32,32,32,32
DATA 219
DATA Z
QPRINTs r+5, c+1, cS$, attr
cS$ = ""
INCR i
DO
xS$ = READ$(i)
IF xS$ <> "Z" THEN
cS$ = cS$ + CHR$(VAL(xS$))
INCR i
ELSE
EXIT DO
END IF
LOOP
DATA 32,219,32,32,32,219,32,32
DATA 219,32,32,32,219,32,32,32,32,32
DATA 219,32,32
DATA 219,32,32,32,32,32,32
DATA 219,32,32,32,219,32,32
DATA 219,32,32,32,219,32,32
DATA 219,32,32,32,32,32
DATA 219
DATA Z
QPRINTs r+6, c+1, cS$, attr
cS$ = ""
INCR i
DO
xS$ = READ$(i)
IF xS$ <> "Z" THEN
cS$ = cS$ + CHR$(VAL(xS$))
INCR i
ELSE
EXIT DO
END IF
LOOP
DATA 32,219,220,220,220,223,32,32
DATA 219,32,32,32,219,32,32
DATA 219,220,220,219,32,32
DATA 219,220,220,220,219,32,32
DATA 219,220,220,220,223,32,32
DATA 219,32,32,32,219,32,32
DATA 219,220,220,219,32,32
DATA 219,220,220,219
DATA Z
QPRINTs r+7, c+1, cS$, attr
QPRINTs r+9, c+20, "S I M U L A T O R", attr
IF ConsRows = 25 THEN EndBuffer
LOCATE 1, 1
CURSOR OFF
IF Gfx THEN
CALL ShowGfx
GfxRefresh 0
END IF
CALL ClearInpBuffer
IF zS$ <> "Q" THEN zS$ = UCASE$(WAITKEY$)
END SUB
SUB Manage (mo, md, runner) STATIC 'May return an offensive or defensive player
ON ERROR GOTO ERRORTRAP
REDIM PHList(1 TO 9) AS PHType
mo = 0
md = 0
runner = 0
RunnersOn = NUMBERON
IF amgr(id) = FALSE THEN GOTO SU200
' --------------------------------------------------------------
' Defensive Maneuvers
' --------------------------------------------------------------
' ** Shall I pull in the Infield? **
RunsAhead = itruns(id) - itruns(it)
IF iout < 2 AND ir3 <> 0 THEN 'guy on 3rd
IF inn <= RegInns - 3 THEN 'early in game
IF ir1 = 0 OR (ir1 > 0 AND iout = 0) THEN
IF (inn - RunsAhead) >= (RegInns - 3) THEN Tight = TRUE
'RunsAhead Inning
' tied 6
' -1 5
' -2 4
' -3 3
' -4 2
END IF
ELSE
'7th inning on:
IF RunsAhead < 2 THEN Tight = TRUE
END IF
END IF
'SP Normal Late Inn
' ** Shall I Pitch-Out? ** ' (@+30) (@+40)
IF RunsAhead <= 2 AND RunsAhead >= -4 THEN
'Not in the 9th inning if defense has a lead > 1 run
IF inn > (RegInns - 1) AND ABS(RunsAhead) > 1 THEN GOTO SU100
'Find Lead Runner (if any)
LR = 0
IF ir3 = 0 THEN
IF ir2 = 0 THEN
IF ir1 <> 0 THEN LR = ir1
ELSE
LR = ir2
END IF
ELSE
LR = ir3
END IF
'Bail out if no appropriate lead runner
IF LR = 0 OR LR = ir3 THEN GOTO SU100
'Check team and player attempt totals
runref = DataRef(LR, it)
POBoost = 0
IF StealAttemptsTeam(it) > 4 THEN
POBoost = POBoost + 10
END IF
IF StealAttemptsPlayer(runref, it) > 2 THEN
POBoost = POBoost + 20
END IF
IF LR = ir1 THEN
IF DataSpeed(ir1, it) < 5 THEN '4 0%
i = 140
ELSEIF DataSpeed(ir1, it) = 5 THEN '5 15%
i = 135
ELSEIF DataSpeed(ir1, it) = 6 THEN '6 25%
i = 135
ELSEIF DataSpeed(ir1, it) = 7 THEN '7 25%
i = 145
ELSEIF DataSpeed(ir1, it) = 8 THEN '8 30%
i = 150
ELSE '9 25%
i = 165
END IF
'Limit POuts during same At-Bat
i = i + BatPOut * 20
'Increase Pitchouts if limits are exceeded
i = i - POBoost
IF BatPOut < 2 THEN 'Will not pitch-out more than twice
IF (DataSpeed(ir1, it) * 10) + FRND(100) > i THEN POut = TRUE
END IF
'Late innings, close game situation:
IF inn > (RegInns - 2) AND ABS(RunsAhead) < 2 THEN
IF DataSpeed(ir1, it) > 5 THEN
IF BatPOut < 2 AND FRND(10) > 5 THEN POut = TRUE
END IF
END IF
END IF
IF LR = ir2 THEN
'Pitchout when trying to steal third?
'Not gonna steal/PO 3rd with potential winning run
IF RunsAhead = 0 AND inn > (RegInns - 2) THEN GOTO SU100
IF iout = 0 THEN i = 160
IF iout = 1 THEN i = 140
IF iout = 2 THEN i = 180
IF UCASE$(DataHand(ip, id)) = "R" THEN i = i + 20
'Limit POuts during same At-Bat
i = i + BatPOut * 20
'Increase Pitchouts if limits are exceeded
i = i - POBoost
IF BatPOut < 2 THEN 'Will not pitch-out more than twice
IF (DataSpeed(ir2, it) * 10) + FRND(100) > i THEN POut = TRUE
END IF
END IF
END IF
SU100:
' ** Shall I Pass this guy? **
' [Check for Desperate Situation - Message and Walk Switch]
' Home team batting in the ninth or later with score tied and
' winning run on third with less than two out
IF inn >= RegInns AND it = 2 THEN
IF RunsAhead = 0 THEN
IF iout < 2 THEN
IF ir3 > 0 AND (ir1 = 0 OR ir2 = 0) THEN
IWalk = TRUE
IF DelFac THEN
AddToAnnouncer id, "A tense situation now!"
AddToAnnouncer id, "They're gonna load 'em up!"
END IF
INCR zzziwalk1
GOTO CheckPitcher
END IF
END IF
END IF
END IF
' Other Intentional Walk Situations
IF inn >= (RegInns - 3) THEN
IF ir1 = 0 AND (ir2 > 0 OR ir3 > 0) THEN
IF RunsAhead < 6 THEN
IF RunsAhead > RunnersOn + 1 THEN 'Won't put tying run on base
i = ib + 1
IF i > 9 THEN i = 1
IF DataPos(i, it) = 1 THEN
'If we're thinking about getting to the pitcher
xF! = .06 'No. 8 guy has to be pretty good
ELSE
xF! = .04 'Not so strict about getting to other players
END IF
IF RND < .8 THEN
IF HITRATING!(ib, it) - HITRATING!(i, it) > xF! THEN
IWalk = TRUE
'gonna pitch around *
'to get to @
IF DelFac THEN
CALL Msg ("29", "0", "0", "18", ib, it, man2, team2)
CALL Msg ("29", "0", "0", "19", i, it, man2, team2)
END IF
IF xF! > .059 THEN INCR zzziwalk2 ELSE INCR zzziwalk3
END IF
END IF
END IF
END IF
END IF
END IF
'** Check Bullpen status **
CheckPitcher:
CALL CountAvPitchers (id, Av, LastGuy) '(The current pitcher is not counted)
IF Av < 1 THEN GOTO SU200
'A Bullpen pitcher is available...check on your current pitcher
IF PitchersPerGame(id) < 2.5 THEN
i = 11 - (2 * PitchersPerGame(id))
IF PitchersPerGame(id) < 1.2 THEN i = 10
j = i - 2
k = i - 3
ELSE
i = 5
j = 3
k = 2
END IF
'If given up 5+ runs in less than his first 2 innings of work get the hook:
IF mpr(ip, id) > i - 1 AND mpo(ip, id) < 6 THEN
BullD = TRUE
IF np(id)=1 THEN INCR RemoveReason(1)
GOTO SU999
END IF
'Get hook if given up 7-8+ runs
IF mpr(ip, id) + INT(RunnersOn / 2) > (i + 2) THEN
BullD = TRUE
IF np(id)=1 THEN INCR RemoveReason(2)
GOTO SU999
END IF
IF RunnersOn + 6 > ABS(RunsAhead) THEN 'was +4
IF np(id) = 1 THEN 'Starter is still in the game
'Starter is gone if gives up:
'Normal: Old-Time:
'Runs On-Base Runs On-Base
' 6+ nobody on 7+ nobody on
' 5 2+on 6 2+on
IF mpr(ip, id) + INT(RunnersOn / 2) > i THEN
BullD = TRUE
INCR RemoveReason(3)
GOTO SU999
END IF
ELSE
'Reliever in 1st 5 innings gone if gives up:
'Runs On-Base
' 3+ 2-on or loaded
IF inn < 6 THEN
IF mpr(ip, id) + INT(RunnersOn / 2) > j THEN BullD = TRUE: GOTO SU999
ELSE
'Reliever in 6th inning or later gone if gives up:
'Runs On-Base
' 2+ 2-on or loaded
IF mpr(ip, id) + INT(RunnersOn / 2) > k THEN BullD = TRUE: GOTO SU999
END IF
END IF
END IF
'Have we over-extended the current pitcher?
'Only check at start of an inning (sort of)
'The bigger FatRnd is, the more durable the pitcher
IF iout = 0 AND RunnersOn = 0 THEN
IF ithits(it) > 1 THEN
IF itruns(it) > 0 THEN
IF DataGames(ip, id) THEN
IF nPitch(id) > ExpectedPitchCount(ip, id) * FatRnd(id) THEN
BullD = TRUE
IF np(id)=1 THEN INCR RemoveReason(4)
GOTO SU999
END IF
END IF
END IF
END IF
END IF
'Cut down on complete games
IF Av > 2 THEN 'Reliver Available
IF PitcherBatted(id) = FALSE THEN 'Pitcher didn't bat last inning
IF inn = 8 AND iout = 0 AND RunnersOn = 0 THEN 'Beginning of 8th inning
IF np(id) = 1 THEN 'Starter still in game
IF DataGames(ip, id) THEN
IF nPitch(id) > .90 * ExpectedPitchCount(ip, id) THEN
IF ithits(it) > 2 THEN
x! = PitchersPerGame(id)
CG_Per_162GSeason! = 330.17 - 206.33*x! + 42.39*x!*x! - 2.84*x!*x!*x!
y! = CG_Per_162GSeason! / 162
y! = 1.0 - y! 'Chance of NOT pitching a complete game
IF y! < .01 THEN y! = .01
IF y! > .99 THEN y! = .99
IF RND < (y! / 2.2) THEN 'Remove pitcher % of the time!
BullD = TRUE
INCR RemoveReason(5)
GOTO SU999
END IF
END IF
END IF
END IF
END IF
END IF
END IF
END IF
'Bring in the closer in the late innings?
'Closer must not already be pitching
'Closer must be available
IF inn > 7 THEN
'Old-Style managers are not concerned with "closers", so we make up
'some criteria to decide if we want to look for a closer
IF PitchersPerGame(id) > 2.1 AND HiSaves(id) > 9 AND LastPiAd(id) > 16 THEN
IF CloserIn(id) = FALSE THEN
'Is this a Closer-Situation?
'Do not pull a pitcher with no-hitter or 1-hitter
'Defense must be between tied and 3 runs ahead
'8th inning: 2-3 run lead and tying run on base
'9+ inning: tied; runner on; at least one out: 20 chance for closer
' 1-3 run lead; tying run at plate or at start of inning
ClsSit = FALSE
IF ithits(it) > 1 THEN
IF RunsAhead > -1 AND RunsAhead < 4 THEN
x! = RND
IF StrictCloserRule THEN
IF inn > 8 AND RunsAhead > 1 AND ( (RunnersOn + 2 > RunsAhead) OR (iout = 0 AND RunnersOn = 0 AND x! < (1.0 - .10 * RunsAhead) ) ) THEN ClsSit = TRUE
IF inn > 8 AND RunsAhead = 1 AND ( (RunnersOn + 1 > RunsAhead) OR (iout = 0 AND RunnersOn = 0 AND x! < (1.0 - .10 * RunsAhead) ) ) THEN ClsSit = TRUE
ELSE
IF inn = 8 AND RunsAhead > 1 AND ( (RunnersOn + 2 > RunsAhead) AND iout > 0 AND mpo(ip, id) > 1 AND x! < .8) THEN ClsSit = TRUE
IF inn = 8 AND RunsAhead = 1 AND ( (RunnersOn + 1 > RunsAhead) AND iout > 0 AND mpo(ip, id) > 1 AND x! < .8) THEN ClsSit = TRUE
IF inn > 8 AND RunsAhead > 1 AND ( (RunnersOn + 2 > RunsAhead) OR (iout = 0 AND RunnersOn = 0 AND x! < (1.0 - .10 * RunsAhead) ) ) THEN ClsSit = TRUE
IF inn > 8 AND RunsAhead = 1 AND ( (RunnersOn + 1 > RunsAhead) OR (iout = 0 AND RunnersOn = 0 AND x! < (1.0 - .10 * RunsAhead) ) ) THEN ClsSit = TRUE
IF inn > 8 AND RunsAhead = 0 AND RunnersOn > 0 AND x! < .3 THEN ClsSit = TRUE
END IF
'Turn indicator off for shutouts unless opponent is knocking at the door
IF itruns(it) = 0 AND np(id) = 1 AND RunnersOn - 1 < RunsAhead THEN ClsSit = FALSE
'Turn indicator off if pitcher batted last inning.
'Manager would look dumb if he brought in a closer now.
IF PitcherBatted(id) = TRUE AND (iout + RunnersOn) < 2 THEN ClsSit = FALSE
IF ClsSit = TRUE THEN
'This code doesn't check for the possibility of a duplicate-
'name problem, but CountAvPitchers guarantees that SOMEONE is
'available.
IF NewStyleWithSaves(id) THEN
'Somebody with "Saves" available?
AvCls = 0
FOR i = 10 TO LastPiAd(id)
IF i <> ip AND iused(i, id) = 0 AND DataCS(i, id) > 0 THEN
IF SimDaysOff(i, id) = 0 OR DaysOffRule = FALSE THEN
INCR AvCls
END IF
END IF
NEXT
IF AvCls THEN
BullD = TRUE
GOTO SU999
END IF
ELSE
j = MIN&(15, LastPiAd(id)) 'usually 15 unless not that many pitchers
IF iused(j, id) = 0 AND ip <> j THEN
IF SimDaysOff(j, id) = 0 OR DaysOffRule = FALSE THEN
BullD = TRUE
GOTO SU999
END IF
END IF
END IF
END IF
END IF
END IF
END IF
END IF
END IF
'10 inning limit
IF mpo(ip, id) > 29 THEN BullD = TRUE: GOTO SU999
' ------------------------------------------------------------
' Offensive Maneuvers
' ------------------------------------------------------------
SU200:
IF amgr(it) = FALSE THEN GOTO SU999
RunsBehind = itruns(id) - itruns(it)
RunsAhead = itruns(it) - itruns(id)
RealPitcherUp = FALSE
IF DataPos(ib, it) = 1 THEN
LastRealPitcher$ = DataName(iyp(np(it), it), it)
IF DataName(ib, it) = LastRealPitcher$ THEN
RealPitcherUp = TRUE
END IF
END IF
' ** Consider a Pinch Hitter **
' Conditions to consider a pinch hitter:
' RunsBehind + Inning + RunnersOn - Outs > 7
' Weak hitter
' Available hitters on bench
' Another pitcher available if pinch-hitting for pitcher
'Is your pitcher up now? Make sure its a real pitcher and not a pinch-hitter already...
PullPitcher = FALSE
'IF DataPos(ib, it) = 1 AND DataRef(ib, it) <= LastPiAd(it) THEN
IF RealPitcherUp THEN
'Are there any more pitchers?
CALL CountAvPitchers (it, Av, LastGuy)
IF Av < 1 THEN GOTO SU250 'No more pitchers -- cannot Pinch hit!
IF ithits(id) = 0 THEN GOTO SU250 'No-hitter going! -- don't do it!
'Are you going to pull him at the start of the next inning anyway?
'Compare outs recorded by the pitcher this game with his average
'outs recorded per game. If he has exceeded them by 40 (starter)
'or 25 (reliever) he will be pulled the next inning unless he's
'a starter working on a no-hitter
j = ipa(it)
'PH for him because he'll be over-extended next inning:
IF DataGames(j, it) THEN
IF nPitch(it) + 7 > ExpectedPitchCount(j, it) * FatRnd(it) THEN
PullPitcher = TRUE
END IF
END IF
'PH for him if likelyhood of C.G is low and starter is still in
IF inn = (RegInns - 2) THEN '7th inn
IF np(it) = 1 THEN
x! = PitchersPerGame(it)
CG_Per_162GSeason! = 330.17 - 206.33*x! + 42.39*x!*x! - 2.84*x!*x!*x!
y! = CG_Per_162GSeason! / 162
y! = 1.0 - y! 'Chance of NOT pitching a complete game
IF y! > .99 THEN y! = .99
IF RND < (y! / 2.2) THEN
PullPitcher = TRUE
INCR RemoveReason(6)
END IF
END IF
END IF
'PH for him if he'll probably be lifted for the closer next inning anyway:
IF PitchersPerGame(it) > 2.1 AND LastPiAd(it) > 16 AND HiSaves(it) > 9 THEN
IF CloserIn(it) = FALSE THEN 'He's not the closer
IF inn > (RegInns - 2) THEN '8th inn or more
IF RunsAhead > -1 AND RunsAhead < 4 THEN '0 - 3 ahead
IF mpo(j, it) > 0 THEN 'Retired at least 1 batter
PullPitcher = TRUE
IF np(it) = 1 THEN INCR RemoveReason(7)
END IF
END IF
END IF
END IF
END IF
'Change my mind sometimes:
'If starter is still in, go ahead and try for a shutout
IF np(it) = 1 THEN
IF mpo(j, it) < 27 THEN
IF itruns(id) = 0 AND RunsAhead > 0 THEN PullPitcher = FALSE
END IF
END IF
END IF
IF inn > RegInns THEN Inning = RegInns ELSE Inning = inn
'Give more "weight" for runners in scoring position
iOn = RunnersOn
IF iOn = 1 THEN
IF ir2 OR ir3 THEN iOn = 2
END IF
'We rarely pinch-hit for the pitcher in old-time scenarios
IF RealPitcherUp AND PitchersPerGame(it) < 2.5 THEN
i = 11 - (3 * PitchersPerGame(it))
j = 2 * PitchersPerGame(it) - 2.3 ' - 3
ELSE
i = 2
j = 2
END IF
IF (Inning > i AND (RunsBehind + Inning + iOn - iout > (RegInns - j))) OR PullPitcher THEN
'Are there any pinch hitters available on the bench?
'Build list of eligible hitters with their rating - pay attention to defense
Av = 0
Def1 = DataPos(ib, it) 'Batter's defensive position
FOR i = LastPiAd(it) + 1 TO MAXPLAYERS 'Scan each player on bench
IF DataName(i, it) > "!" THEN 'If bench-player's name is non-blank
IF iused(i, it) = FALSE THEN 'If bench-player hasn't been in the game
IF DataRef(i, it) > LastPiAd(it) OR DataRef(i, it) < 10 THEN 'Bench player's a non-pitcher
'Is potential PH's name identical to the current or previously used pitcher?
ie = 0
FOR ii = 1 TO np(it)
IF DataName(i, it) = DataName(iyp(ii, it), it) THEN ie = -1
NEXT
'If NOT PH'ing for the pitcher, is the candidate also the last
'available pitcher (if cloned pitchers are involved)?
IF DupNameTeam(it) THEN
IF Def1 <> 1 THEN
CALL CountAvPitchers(it, AvP, LastGuy)
IF AvP = 1 AND DataName(LastGuy, it) = DataName(i, it) THEN
ie = -1
END IF
END IF
END IF
IF ie = 0 THEN
IF DataGbyP(i, it, 1) > 0 AND DataPosi(i, it, 1) > 0 THEN 'strict
SELECT CASE Def1
CASE 1, 10
GOSUB AddToPHList 'If current batter is pitcher, anyone will do
CASE ELSE 'Otherwise only add similar defensive players
IF FoundPosition(Def1, i, it) THEN GOSUB AddToPHList
END SELECT
ELSE 'old style - we're not so strict
SELECT CASE Def1
CASE 1
GOSUB AddToPHList 'If current batter is pitcher, anyone will do
CASE 2
IF DataPos(i, it) = 2 THEN GOSUB AddToPHList
CASE 3
IF DataPos(i, it) = 3 OR DataPos(i, it) = 5 THEN GOSUB AddToPHList
CASE 4
IF DataPos(i, it) = 4 OR DataPos(i, it) = 6 THEN GOSUB AddToPHList
CASE 5
IF DataPos(i, it) = 5 OR DataPos(i, it) = 6 THEN GOSUB AddToPHList
CASE 6
IF DataPos(i, it) = 6 THEN GOSUB AddToPHList
CASE 7 TO 9
IF DataPos(i, it) > 6 AND DataPos(i, it) < 10 THEN GOSUB AddToPHList
CASE 10
GOSUB AddToPHList
CASE ELSE
END SELECT
END IF
END IF
END IF
END IF
END IF
NEXT
IF Av > 0 THEN 'If the list is not empty
'Sort the PH List by the hitting rating
ARRAY SORT PHList(1) FOR Av, FROM 1 TO 4, DESCEND
'Convert top PH candidate's rating back to float
highF! = VAL(PHList(1).Criteria1) / 1000
'Compute Rating for our current hitter in the lineup
xF! = HITRATING!(ib, it)
'Set a threshhold value for our next equation based on
'the current inning. If its early in the game make the value
'higher so not many pinch hitters will occur
SELECT CASE inn
CASE 1 TO 3
yF! = .205 '.155
CASE 4
yF! = .165 '.135
CASE 5
yF! = .155
CASE 6
yF! = .145
CASE 7
yF! = .135
CASE ELSE
IF RealPitcherUp THEN
yF! = .040
ELSE
yF! = .070
END IF
END SELECT
'If our potential PH's hit-rating is greater than the current hitter's
'hit-rating by the threshhold value, or we're going to pull the pitcher
'anyway, go ahead and pinch hit
IF (highF! - xF! > yF!) OR PullPitcher THEN
'We know there are good hitters on the bench but now
're-sort giving boost to low AB/Game Ratio, R/L, and place in .DAT
ARRAY SORT PHList(1) FOR Av, FROM 5 TO 8, DESCEND
'Usually pick the top candidate but sometimes the 2nd or 3rd guy
zF! = RND
IF Av = 1 THEN
i = 1
ELSEIF Av = 2 THEN
IF zF! < .75 THEN i = 1 ELSE i = 2
ELSE
IF zF! < .70 THEN
i = 1
ELSEIF zF! < .85 THEN
i = 2
ELSE
i = 3
END IF
END IF
PH = TRUE
mo = PHList(i).Slot
IF RealPitcherUp AND np(it) = 1 THEN INCR RemoveReason(8)
INCR zzzPH
GOTO SU999
END IF
END IF
END IF
SU250:
'If we did *not* PH for pitcher, mark it.
IF RealPitcherUp THEN PitcherBatted(it) = TRUE
' ** Shall I Bunt? **
IF DataPos(ib, it) = 1 THEN 'Pitcher Bunts almost all the time
'Make sure its an actual pitcher, not a PH
IF RealPitcherUp THEN
IF ir3 = 0 AND ir1 <> 0 AND iout < 2 AND RND < .80 THEN
IF inn < (RegInns - 1) OR RunsBehind < 2 THEN
Bunt = TRUE: GOTO SU999
END IF
END IF
ELSE
GOTO SU260 'Pinch-hitters for pitcher don't bunt
END IF
ELSE
'Non-Pitcher
IF ir3 = 0 AND ir1 <> 0 THEN ' 3 ' .4
IF iout = 0 AND ABS(RunsBehind) < 2 AND DataHR(ib, it) < 20 AND inn > (RegInns - 3) AND RND < .7 THEN
Bunt = TRUE: GOTO SU999 'Normal Bunt Situation
END IF
END IF
END IF
'Anyone can try a squeeze
IF ir3 <> 0 AND ir2 = 0 THEN
IF iout = 1 AND ABS(RunsBehind) < 2 AND DataHR(ib, it) < 20 AND RND < .25 THEN
Bunt = TRUE: GOTO SU999 'Try Squeeze Play
END IF
END IF
SU260:
' ** Shall I ATTEMPT a Steal? **
IF ir3 = 0 AND ir2 = 0 AND ir1 = 0 THEN GOTO SU270 'Nobody on
IF ir3 <> 0 AND ir2 <> 0 THEN GOTO SU270 '2nd & 3rd or loaded
IF ir3 <> 0 AND ir2 = 0 AND ir1 = 0 THEN GOTO SU270 '3rd only
' That leaves only four possible steal situations:
' 1st base only
' 2nd base only
' 1st & 2nd
' 1st & 3rd
IF ir2 THEN IL = ir2 ELSE IL = ir1 'Lead runner (for steal)
'Reject:
IF IL = ir2 AND iout <> 1 THEN GOTO SU265 'Only try to steal 3rd with 1 out
IF IL = ir2 AND RunsBehind = 0 AND inn > (RegInns - 2) THEN GOTO SU270 'don't risk stealing 3rd with potential winning run
IF RunsBehind > 2 THEN GOTO SU270 'Behind by 3 or more (10/2/99)
IF RunsAhead > 4 THEN GOTO SU270 'Ahead by more than 4
IF RunsBehind > 1 AND inn > (RegInns - 2) THEN GOTO SU270 'Don't steal in late innings if behind by 2 or more
'Don't steal if pitcher is up and 0 or 2 out
IF RealPitcherUp AND iout <> 1 THEN GOTO SU270
IF ib < 9 THEN nxt = ib + 1 ELSE nxt = 1
'Don't steal if pitcher is next unless it's very late in game
IF DataPos(nxt, it) = 1 AND inn < (RegInns - 1) THEN GOTO SU270
'Determine SB Attempts
'a. No CS data
IF DataCS(IL, it) = 0 THEN
i = DataSpeed(IL, it)
IF i = 1 THEN yF! = .01
IF i = 2 THEN yF! = .03
IF i = 3 THEN yF! = .06
IF i = 4 THEN yF! = .09
IF i = 5 THEN yF! = .12
IF i = 6 THEN yF! = .16
IF i = 7 THEN yF! = .22
IF i = 8 THEN yF! = .30
IF i = 9 THEN yF! = .42
ELSE
'b. Have SB/CS data
singles = DataHits(IL, it) - DataHR(IL, it) - Data2B(IL, it) - Data3B(IL, it)
IF singles = 0 THEN singles = 1
yF! = (DataSB(IL, it) + DataCS(IL, it)) / (singles + DataBB(IL, it))
'Be more aggressive with 8 and 9's
i = DataSpeed(IL, it)
IF i = 7 THEN yF! = yF! * 1.05
IF i = 8 THEN yF! = yF! * 1.10
IF i = 9 THEN yF! = yF! * 1.15
END IF
'If runner is a pitcher, cut attempts
IF DataPos(IL, it) = 1 THEN yF! = yF! * .33
'Cut down prob. of attempting to steal 3rd, etc.
IF ir2 <> 0 THEN
IF UCASE$(DataHand(ip, id)) = "R" THEN
yF! = yF! * .20
ELSE
yF! = yF! * .80
END IF
ELSEIF UCASE$(DataHand(ip, id)) = "L" THEN
yF! = yF! * .40
ELSE
yF! = yF! * 1.1 '1.03 1.01 1.04 1.25 1.15 1.35 1.30 .90 .80 .85
END IF
'Raise probability of steal attempt in late innings of close games with a good runner
IF inn > (RegInns - 2) AND ABS(RunsBehind) < 2 AND yF! > .25 THEN yF! = yF! * 1.5
IF RND < yF! THEN
Steal = TRUE
IF DataPos(IL, it) = 1 THEN INCR zzsabp
GOTO SU999
END IF
SU265:
' ** Hit and Run
' The "reject" rules on stolen bases apply here too. (Branched to SU270)
IF ir1 <> 0 THEN
IF ir3 = 0 THEN
IF iout < 2 THEN
IF ir2 THEN IL = ir2 ELSE IL = ir1 'Lead runner (for steal)
IF DataSpeed(IL, it) > 3 THEN
yF! = (DataAB(ib, it) - DataHR(ib, it) - DataSO(ib, it)) / DataAB(ib, it)
xF! = RND
IF Year(it) < "1920" THEN zF! = .15 ELSE zF! = 0
IF yF! > .90 THEN
IF xF! > .65 + zF! THEN HitAndRun = TRUE '.60
ELSEIF yF! > .80 THEN
IF xF! > .80 + zF! THEN HitAndRun = TRUE '.75
ELSEIF yF! > .70 THEN
IF xF! > .90 + zF! THEN HitAndRun = TRUE '.90
END IF
END IF
END IF
END IF
END IF
SU270:
' ** Consider a Pinch Runner (for some combination of baserunners) **
IF inn > RegInns - 3 THEN
IF ABS(RunsBehind) < 3 THEN 'was < 4
LL = 100
runner = 0
IF ir1 <> 0 AND ir2 = 0 THEN runner = ir1
IF ir1 <> 0 AND ir2 <> 0 THEN runner = ir2
IF ir1 = 0 AND ir2 <> 0 THEN runner = ir2
IF runner THEN
'Are there any pinch runners available on the bench?
'Find eligible players - pay attention to defense - save fastest
SaveFastest = 0
SaveI = 0
Def1 = DataPos(runner, it) 'runner's current defensive position
IF Def1 <> 1 THEN 'No running for pitchers
'Scan each player on bench
FOR i = LastPiAd(it) + 1 TO MAXPLAYERS 'Scan each player on bench
IF DataName(i, it) > "A" THEN 'If bench-player's name is non-blank
IF iused(i, it) = FALSE THEN 'If bench-player hasn't been in the game
IF DataRef(i, it) > LastPiAd(it) OR DataRef(i, it) < 10 THEN 'Bench-player is a non-pitcher
'Fix 2/23/05
'Is potential PH's name identical to the current or previously used pitcher?
OK1 = TRUE
FOR ii = 1 TO np(it)
IF DataName(i, it) = DataName(iyp(ii, it), it) THEN OK1 = FALSE
NEXT
'Is the candidate also the last available pitcher
'(if cloned pitchers are involved)?
IF OK1 THEN
OK2 = TRUE
IF DupNameTeam(it) THEN
CALL CountAvPitchers(it, AvP, LastGuy)
'LastGuy is a pitcher's number
'Does his name match the candidate's name?
IF AvP = 1 AND DataName(LastGuy, it) = DataName(i, it) THEN
OK2 = FALSE
END IF
END IF
END IF
IF OK1 AND OK2 THEN
IF DataSpeed(i, it) - DataSpeed(runner, it) >= 3 THEN
'Found a faster guy
'Does he play the correct position?
OK = FALSE
FOR ii = 1 TO 4
IF DataPosi(i, it, ii) = Def1 THEN OK = TRUE: EXIT FOR
NEXT
IF OK THEN
IF DataSpeed(i, it) > SaveFastest THEN
SaveFastest = DataSpeed(i, it)
SaveI = i
END IF
END IF
END IF
END IF
END IF
END IF
END IF
NEXT
END IF
IF SaveI > 0 THEN 'The fastest elegible player
IF RND < .80 THEN '2007 - reduce pinching-running by manager slightly
PRun = TRUE
mo = SaveI
GOTO SU999
END IF
END IF
END IF
END IF
END IF
GOTO SU999
AddToPHList: 'in:[i]
'Uses n, xF!, h$, zF!
IF Av < 9 THEN
'1. Hit-rating
xF! = HITRATING!(i, it)
INCR Av
PHList(Av).Criteria1 = FLOAT2STR$(xF!)
'2. Boost hitters with lots of "unaccounted" games
IF DataGames(i, it) > 0 AND DataAB(i, it) > 40 THEN
GamesAllPos = 0
FOR n = 1 TO 4 '4 possible games by position
IF DataPosi(i, it, n) > 1 THEN
GamesAllPos = GamesAllPos + DataGbyP(i, it, n)
END IF
NEXT
IF GamesAllPos > 0 THEN
zF! = ((DataGames(i, it) - GamesAllPos) / DataGames(i, it)) / 5
IF zF! > .040 THEN zF! = .040 'bracket added 2008
xF! = xF! + zF!
END IF
END IF
'3. Boost hitters who are either switch hitters or opposite hand from pitcher
h$ = DataHand(i, it)
IF h$ = "S" OR h$ = "B" OR h$ <> UCASE$(DataHand(ip, id)) THEN
xF! = xF! + .060 ' + .030
END IF
'4. Give preference to first three listed on the bench in .DAT
IF DataRef(i, it) > LastPiAd(it) AND DataRef(i, it) < LastPiAd(it) + 4 THEN
xF! = xF! + .030 ' + .040
END IF
PHList(Av).Criteria2 = FLOAT2STR$(xF!)
PHList(Av).Slot = i
END IF
RETURN
ErrorTrap:
LOCATE 10, 30
PRINT "ERROR: Manage "; ERRCLEAR
LOCATE 11, 30
PRINT "Av:";Av;"i:";i;"it:";it;"id:";id;"ip:";ip;
x$ = WAITKEY$
SU999:
END SUB
SUB MoreOptionsIO (row, Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
IF MenuOpt$ = "T" THEN r = row + 12 ELSE r = row + 16
CALL Drawfrm(row+rowO, 21+colO, r+rowO, 63+colO, defattr, "More Simulation Options", "ESC (or close window) to Continue", 1, 0, 1)
DATA 02,23,"Cross-Era Normalization [YYYYL] ",02,57,05,"X "
DATA 04,23,"Performance Focusing? [y/N] ",04,57,01,"XR"
DATA 06,23,"Pause after every game? [y/N] ",06,57,01,"XR"
DATA 08,23,"Pause after date change? [y/N] ",08,57,01,"XR"
DATA 10,23,"Delay Factor [0-7] ",10,57,01,"N "
DATA 12,23,"Auto-Lineup? [Y/n] ",12,57,01,"XR"
DATA 14,23,"Optimize Batting Order?[Y/n/c/f] ",14,57,01,"XR"
IF MenuOpt$ = "T" THEN Flds = 5 ELSE Flds = 7
c = 1
FOR i = 1 TO Flds
Flitrow(i) = VAL(READ$(c)) + row + rowO
Flitcol(i) = VAL(READ$(c+1)) + colO
Flit$(i) = READ$(c+2)
Frow(i) = VAL(READ$(c+3)) + row + rowO
Fcol(i) = VAL(READ$(c+4)) + colO
Flen(i) = VAL(READ$(c+5))
Fed$(i) = READ$(c+6)
c = c + 7
NEXT
'Set Defaults
REDIM FContents$(13)
FContents$(1) = ""
IF MenuOpt$ = "T" THEN
IF Year(1) <> Year(2) THEN 'Batter Normalization
FContents$(1) = "H"
END IF
END IF
FContents$(2) = "N"
FContents$(3) = "N"
FContents$(4) = "N"
FContents$(5) = "0"
FContents$(6) = "Y"
FContents$(7) = "Y"
IF MenuOpt$ <> "S" THEN Flen(4) = -1
IF LEN(CmdFavTeam$) THEN Flen(4) = -1
IF LEN(CmdFavLeague$) THEN Flen(4) = -1
IF CmdStat$ < "!" THEN Flen(2) = -1
CursorPtr = 1
DO
MoreOptLoop:
CALL ScreenIO(Keyed, KeyF3, 0, KeyEsc, Flds, CursorPtr, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
IF Keyed = KeyF3 THEN
EXIT SUB
END IF
'Edit Field Contents
Error1$ = "N"
x$ = RTRIM$(FContents$(1))
y$ = "Response must be [H, V, B] or [####L] where ####=Year L=League"
LL = LEN(x$)
IF LL = 1 THEN
IF x$ <> "H" AND x$ <> "V" AND x$ <> "B" THEN
CALL PopMsg (row+3+rowO, 7+colO, y$, errattr, 5, kc)
Error1$ = "Y": CursorPtr = 1: GOTO MoreOptLoop
END IF
END IF
IF LL = 5 THEN
x1$ = MID$(x$, 1, 4)
x2$ = MID$(x$, 5, 1)
IF NUMERIC(x1$, 0, 0) AND (x2$ >= "A" AND x2$ <= "Z") THEN
ELSE
CALL PopMsg (row+3+rowO, 7+colO, y$, errattr, 5, kc)
Error1$ = "Y": CursorPtr = 1: GOTO MoreOptLoop
END IF
END IF
IF LL > 1 AND LL < 5 THEN
CALL PopMsg (row+3+rowO, 7+colO, y$, errattr, 5, kc)
Error1$ = "Y": CursorPtr = 1: GOTO MoreOptLoop
END IF
IF INSTR("YN", FContents$(2)) = 0 THEN
Error1$ = "Y"
CursorPtr = 2
GOTO MoreOptLoop
END IF
IF INSTR("YN", FContents$(3)) = 0 THEN
Error1$ = "Y"
CursorPtr = 3
GOTO MoreOptLoop
END IF
IF INSTR("YN", FContents$(4)) = 0 THEN
Error1$ = "Y"
CursorPtr = 4
GOTO MoreOptLoop
END IF
IF INSTR("0123456789", FContents$(5)) = 0 THEN
Error1$ = "Y"
CursorPtr = 5
GOTO MoreOptLoop
END IF
IF INSTR("YN", FContents$(6)) = 0 THEN
Error1$ = "Y"
CursorPtr = 6
END IF
IF INSTR("YNCF", FContents$(7)) = 0 THEN
Error1$ = "Y"
CursorPtr = 7
END IF
LOOP WHILE Error1$ = "Y"
CmdEra$ = RTRIM$(FContents$(1))
CmdFocus$ = FContents$(2)
CmdPauseAftGame$ = FContents$(3)
CmdPauseAftDate$ = FContents$(4)
DelFac = VAL(FContents$(5))
OrgSimDelFac = DelFac
IF MenuOpt$ <> "T" THEN
AutoLineupSw(1) = (FContents$(6) = "Y")
AutoLineupSw(2) = AutoLineupSw(1)
AdjustBO(1) = FContents$(7)
AdjustBO(2) = AdjustBO(1)
END IF
END SUB
SUB MovePitHitStats (pl, tm)
IF pl < 1 OR pl > MAXPLAYERS OR tm < 1 OR tm > 2 THEN
BEEP
EXIT SUB
END IF
r = ipa(tm)
DataRef(pl, tm) = r 'Pitcher's address takes over reference number
DataPos(pl, tm) = 1
DataName(pl, tm) = DataName(r, tm)
'Does pitcher's name exist on bench?
SearchName$ = DataName(pl, tm)
n = SearchDAT (LastPiAd(tm)+1, MAXPLAYERS, tm, SearchName$, 0)
IF n THEN
CALL CopyStats(n, pl, tm)
EXIT SUB
END IF
DataAB(pl, tm) = 100
xS$ = UCASE$(DataCode(r, tm))
code = ASC(xS$) - 64
IF code < 1 OR code > 5 THEN
IF RND < .5 THEN
DataHits(pl, tm) = 16
ELSE
DataHits(pl, tm) = 17
END IF
ELSE
DataHits(pl, tm) = 30 - (5 * code)
END IF
'1 A = .250
'2 B = .200
'3 C = .150 or .165
'4 D = .100
'5 E = .050
DataHR(pl, tm) = DataHits(pl, tm) * .025
DataSO(pl, tm) = 49.1 - DataHits(pl, tm) * 0.9
DataBB(pl, tm) = 5
IF DataPBatAB(r, tm) > 0 THEN
DataAB(pl, tm) = DataPBatAB(r, tm)
DataHits(pl, tm) = DataPBatHi(r, tm)
DataHR(pl, tm) = DataPBatHR(r, tm)
DataBB(pl, tm) = DataPBatBB(r, tm)
DataSO(pl, tm) = DataPBatSO(r, tm)
END IF
Data2B(pl, tm) = DataHits(pl, tm) * .14
Data3B(pl, tm) = DataHits(pl, tm) * .02
DataRBI(pl, tm) = DataHits(pl, tm) / 2.4
IF DataHand(ipa(tm), tm) = "r" THEN
DataHand(pl, tm) = "L"
ELSEIF DataHand(ipa(tm), tm) = "l" THEN
DataHand(pl, tm) = "R"
ELSE
DataHand(pl, tm) = DataHand(ipa(tm), tm)
END IF
DataDef(pl, tm) = 0
DataSB(pl, tm) = 1 'was 3
DataCS(pl, tm) = 1 'was 2
DataSpeed(pl, tm) = 3
FOR i = 1 TO 4
DataPosi(pl, tm, i) = 0
DataGByP(pl, tm, i) = 0
NEXT
END SUB
SUB MovePtrVisi (param$, row, col)
QPRINTs row + VisiPtr, col, " ", defattr
IF param$ = "U" THEN
IF VisiPtr > 1 THEN DECR VisiPtr
IF it = 1 THEN
IF VisiPtr = 7 THEN DECR VisiPtr
IF WarmUpRule = FALSE THEN
IF VisiPtr = 6 THEN DECR VisiPtr
END IF
ELSE
IF VisiPtr = 7 THEN DECR VisiPtr
END IF
ELSEIF param$ = "D" THEN
IF it = 1 THEN
IF VisiPtr < 10 THEN INCR VisiPtr
IF WarmUpRule = FALSE THEN
IF VisiPtr = 6 THEN INCR VisiPtr
END IF
IF VisiPtr = 7 THEN INCR VisiPtr
ELSE
IF VisiPtr < 11 THEN INCR VisiPtr
IF VisiPtr = 7 THEN INCR VisiPtr
END IF
END IF
QPRINTs row + VisiPtr, col, CHR$(175), defattr
END SUB
SUB MovePtrHome (param$, row, col)
QPRINTs row + HomePtr, col, " ", defattr
IF param$ = "U" THEN
IF HomePtr > 1 THEN DECR HomePtr
IF it = 2 THEN
IF HomePtr = 7 THEN DECR HomePtr
IF WarmUpRule = FALSE THEN
IF HomePtr = 6 THEN DECR HomePtr
END IF
ELSE
IF HomePtr = 7 THEN DECR HomePtr
END IF
ELSEIF param$ = "D" THEN
IF it = 2 THEN
IF HomePtr < 10 THEN INCR HomePtr
IF WarmUpRule = FALSE THEN
IF HomePtr = 6 THEN INCR HomePtr
END IF
IF HomePtr = 7 THEN INCR HomePtr
ELSE
IF HomePtr < 11 THEN INCR HomePtr
IF HomePtr = 7 THEN INCR HomePtr
END IF
END IF
QPRINTs row + HomePtr, col, CHR$(175), defattr
END SUB
SUB Msg (c$, p$, s$, t$, man, team, man2, team2) STATIC
'Retrieve specified message, enhance with name, add to Announcer
'STATIC work$, xS$, fS$
DIM MsgList$(15)
Find$ = c$ + p$ + s$ + t$ + "001"
CALL SearchPbyP (PbyP(), 1, 9, 1, PbyP_Cnt, Find$, FoundAt, mini)
IF FoundAt = 0 THEN
work$ = "PbyP not found:" + Find$
GOTO MessagAdd
END IF
'We have found the first message, now get the rest of them
i = FoundAt
j = 0
DO
INCR j
IF j < 16 THEN MsgList$(j) = PbyP(i).text
OldStuff$ = PbyP(i).class + PbyP(i).pos + PbyP(i).seq + PbyP(i).trk
INCR i
IF i <= PbyP_Cnt THEN
NewStuff$ = PbyP(i).class + PbyP(i).pos + PbyP(i).seq + PbyP(i).trk
ELSE
EXIT DO
END IF
LOOP WHILE NewStuff$ = OldStuff$
n = RND(1, j)
work$ = MsgList$(n)
IF DelFac = 0 AND amgr(1) AND amgr(2) THEN GOTO MessagAdd
hh = INSTR(work$, "@") 'full name
ii = INSTR(work$, "*") 'last name
jj = INSTR(work$, "#") 'position
kk = 0
IF (ii > 0 OR hh > 0) AND man > 0 THEN
xS$ = LASTNAME$(DataName(man, team))
'Last name now in xS$
'Stick first name in front of it for special cases @
j = INSTR(DataName(man, team), ",")
IF hh > 0 AND j > 0 THEN
xS$ = FULLNAME$(DataName(man, team))
END IF
IF hh THEN kk = hh
IF ii THEN kk = ii
END IF
IF jj > 0 THEN
xS$ = PosDesc(WhoAtPos)
kk = jj
END IF
IF kk > 0 THEN
'Replace "*/#/@/%" with name xS$ or position
nn = kk
GOSUB InsertString
END IF
'Check for 2nd name %
mm = INSTR(work$, "%")
IF mm > 0 AND man2 > 0 THEN
xS$ = LASTNAME$(DataName(man2, team2))
nn = mm
GOSUB InsertString
END IF
MessagAdd:
IF LEFT$(work$, 1) <> "~" THEN
work$ = LEFT$(work$, 38 + colO)
CALL AddToAnnouncer(team, work$)
END IF
EXIT SUB
InsertString:
L = LEN(work$)
IF nn = L THEN
work$ = MID$(work$, 1, nn - 1) + xS$
ELSEIF nn > 1 AND nn < L THEN
work$ = MID$(work$, 1, nn - 1) + xS$ + MID$(work$, nn + 1)
ELSEIF nn = 1 THEN
work$ = xS$ + MID$(work$, 2)
END IF
RETURN
END SUB
SUB MyBeep
BEEP
END SUB
SUB OptionSetup (row, Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), _
Flitcol(), FContents$())
DATA 08,24,"Quick-Play game: [Y/N] ",08,52,01,"X " '1
DATA 09,24,"Auto Manager: ",00,00,00," " '2
DATA 10,24," Visitor [Y/N] ",10,52,01,"XR" '3
DATA 11,24," Home [Y/N] ",11,52,01,"XR" '4
DATA 12,24,"Delay (Play-by-Play) [0-7] ",12,52,01,"NR" '5
DATA 13,24,"Color Scheme [1-6] ",13,52,01,"NR" '6
DATA 14,24,"Change Background [Y/N] ",14,52,01,"XR" '7
DATA 15,24,"Sound [Y/N] ",15,52,01,"XR" '8
DATA 16,24,"Announcer Audio [Y/N] ",16,52,01,"XR" '9
DATA 17,24,"Focusing [Y/N] ",17,52,01,"XR" '10
DATA 18,24,"Pause After Each Game [Y/N] ",18,52,01,"XR" '11
DATA 19,24,"Pause After Each Date [Y/N] ",19,52,01,"XR" '12
Flds = 12
row = 0
c = 1
FOR i = 1 TO Flds
Flitrow(i) = VAL(READ$(c)) + rowO
Flitcol(i) = VAL(READ$(c+1)) + colO
Flit$(i) = READ$(c+2)
Frow(i) = VAL(READ$(c+3))
IF Frow(i) > 0 THEN Frow(i) = Frow(i) + rowO
Fcol(i) = VAL(READ$(c+4))
IF Fcol(i) > 0 THEN Fcol(i) = Fcol(i) + colO
Flen(i) = VAL(READ$(c+5))
Fed$(i) = READ$(c+6)
c = c + 7
NEXT
IF CmdStat$ > "!" THEN Flen(10) = 1 ELSE Flen(10) = -1
IF MenuOpt$ <> "M" THEN Flen(11) = 1 ELSE Flen(11) = -1
IF MenuOpt$ = "S" THEN Flen(12) = 1 ELSE Flen(12) = -1
IF LEN(CmdFavTeam$) THEN Flen(12) = -1
IF LEN(CmdFavLeague$) THEN Flen(12) = -1
IF (ConsRows = 25 AND ConsCols = 80) THEN Flen(7) = -1
IF amgr(1) AND amgr(2) THEN
IF DelFac = 0 THEN
Flen(1) = -1
END IF
END IF
REDIM FContents$(13)
END SUB
SUB OptionWindow (Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
IF Flen(1) = -1 THEN CursorPtr = 3 ELSE CursorPtr = 1
'Set Defaults
FContents$(1) = "N"
IF amgr(1) THEN FContents$(3) = "Y" ELSE FContents$(3) = "N"
IF amgr(2) THEN FContents$(4) = "Y" ELSE FContents$(4) = "N"
FContents$(5) = RIGHT$(STR$(DelFac), 1)
FContents$(6) = LTRIM$(STR$(ColorScheme))
FContents$(7) = "N"
IF SoundOn THEN FContents$(8) = "Y" ELSE FContents$(8) = "N"
IF AnnouncerOn THEN FContents$(9) = "Y" ELSE FContents$(9) = "N"
FContents$(10) = CmdFocus$
FContents$(11) = CmdPauseAftGame$
FContents$(12) = CmdPauseAftDate$
DO
TopOfCWLoop:
CALL ScreenIO(Keyed, KeyEsc, 0, KeyEsc, Flds, CursorPtr, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
'Edit Field Contents
Error1$ = "N"
IF FContents$(1) <> "Y" AND FContents$(1) <> "N" THEN
Error1$ = "Y": CursorPtr = 1: CALL MyBeep: GOTO TopOfCWLoop
END IF
FOR i = 3 TO 12 'Edit the Y/N responses
IF i <> 5 AND i <> 6 THEN
IF FContents$(i) <> "Y" AND FContents$(i) <> "N" THEN
Error1$ = "Y": CursorPtr = i: CALL MyBeep: GOTO TopOfCWLoop
END IF
END IF
NEXT
IF FContents$(5) = "0" THEN FContents$(8) = "N"
IF FContents$(6) < "1" OR FContents$(6) > "6" THEN
Error1$ = "Y": CursorPtr = 6
CALL PopMsg(18+rowO, 22+colO, " Color Scheme out of range [1-6]", errattr, 2, kc)
GOTO TopOfCWLoop
END IF
IF FContents$(3) = "N" OR FContents$(4) = "N" THEN
IF FContents$(5) = "0" THEN
Error1$ = "Y": CursorPtr = 5
CALL PopMsg(18+rowO, 17+colO, " Delay cannot be 0 if either AutoManager = N ", errattr, 2, kc)
GOTO TopOfCWLoop
END IF
END IF
LOOP WHILE Error1$ = "Y"
CURSOR OFF 'turn off cursor
amgr(1) = (FContents$(3) = "Y")
amgr(2) = (FContents$(4) = "Y")
DelFac = VAL(FContents$(5))
ColorScheme = VAL(FContents$(6))
CmdChangePhoto$ = FContents$(7)
SoundOn = (FContents$(8) = "Y")
AnnouncerOn = (FContents$(9) = "Y")
CmdFocus$ = FContents$(10)
CmdPauseAftGame$ = FContents$(11)
CmdPauseAftDate$ = FContents$(12)
IF FContents$(1) = "Y" THEN
amgr(1) = TRUE
amgr(2) = TRUE
DelFac = 0
SoundOn = FALSE
END IF
END SUB
SUB Outfield (AtPos) STATIC
OutfErr = 0
wag = WHOATGUY (AtPos)
defperF! = DEFPCT!(wag)
'Increase factor to improve defense
zF! = defperF! + (1 - defperF!) * .5
IF RND < zF! THEN EXIT SUB
OutfErr = -1
'Outfielder Error: botched it!
INCR inne
INCR innadverr
i = DataRef(wag, id)
INCR GpPos(i, id, AtPos)
INCR merr(i, id)
INCR SumErrors(AtPos)
INCR iterrs(id)
'Some (1/2) of these errors will be throwing errors!
IF DelFac THEN
IF RND < .5 THEN
'bad throw by *
CALL Msg ("30", "0", "0", "03", wag, id, man2, team2)
ELSE
'ball gets away from *
CALL Msg ("30", "0", "0", "04", wag, id, man2, team2)
END IF
IF NUMBERON > 1 THEN t$ = "05" ELSE t$ = "04"
CALL Msg ("31", "0", "0", t$, 0, it, man2, team2)
'runner(s) advance(s)
END IF
i = Errorx
Errorx = TRUE
CALL Advanc(1, 1, 1)
Errorx = i
Result$ = Result$ + "/E-" + LTRIM$(STR$(AtPos))
END SUB
SUB OutOrError STATIC
ON ERROR GOTO ERRORTRAP
'Forced outcome for debugging through variable fr7
IF fr7=300 THEN
CALL StrikeOutRoutine
fr7=0
EXIT SUB
END IF
IF fr7=100 OR fr7=200 OR fr7=201 THEN
GOTO OutDIRECTION
END IF
'Find the percentage of outs which are strike-outs
i = DataAB(ib, it) - DataHits(ib, it)
IF i <> 0 THEN
hsoF! = DataSO(ib, it) / i '% of Outs that are StrikeOuts
ELSE
hsoF! = .250
END IF
psoF! = DataSO(ip, id) / (DataAB(ip, id) * 3)
' 0 to bpkF! is a K
' bpkF! to bpgF! is a ground out
' bpgF! to 1 is a fly out
IF pkbaseF(id) > 0 THEN y! = pkbaseF(id) ELSE y! = .239
x! = hsoF! * (psoF! / y!)
bpkF! = x! / (x! + ( (1-hsoF!)*(1-psoF!)/(1-y!) ) )
'Use Pitcher Fatigue to influence ground/fly ratio
adjF! = 1.85 'See below **
'Pitcher Fatigue
IF NewStyle(id) AND DataGames(ip, id) AND DataAB(ip, id) THEN
'New Style has "Games" and "Starts"
FatFac! = nPitch(id) / ExpectedPitchCount(ip, id)
adjF! = adjF! + (0.25 * FatFac! - 0.15) '**
IF adjF! > 2.2 THEN adjF! = 2.2 '2.20-> 45.5% grounders
END IF '1.95-> 51.3%
'1.70-> 58.8%
bpgF! = bpkF! + ((1 - bpkF!) / adjF!) '1.9 produces 52.6% grounders
'1.85 produces 54.1% grounders
'1.75 produces 57.1% grounders
IF HitAndRun = FALSE THEN
xrF! = RND
IF xrF! < bpkF! THEN
CALL StrikeOutRoutine
EXIT SUB
END IF
ELSE
'On Hit-and-run's we don't process strike outs here
'Find a new random number between bpkF! and 1.0
n = (1.0 - bpkF!) * 1000
j = 1000 - FRND(n)
xrF! = j / 1000
CALL Msg ("25", "0", "0", "02", 0, it, 0, 0) 'Hit-and-run
END IF
OutDIRECTION:
REM ** PULLED ? ** ' Hit Somewhere
ppF! = FindPP!
IF fr7=100 THEN GOTO OutGROUND 'ground
IF fr7=200 OR fr7 = 201 THEN GOTO OutFLY 'fly
IF xrF! > bpgF! THEN GOTO OutFLY ' GOTO Fly
'** GROUNDER ** ' Ground Ball
OutGROUND:
WhoAtPos = GROUNDBALLWHOAT (ppF!)
IF WhoAtPos = 1 THEN
wag = ip
defperF! = NormDEF(1)
ELSE
wag = WHOATGUY(WhoAtPos)
defperF! = DEFPCT!(wag)
END IF
p$ = LTRIM$(STR$(WhoAtPos))
'Since most errors occur on grounders, fudge defperF! down to produce more errors
zF! = defperF! * .98
IF RND > zF! THEN 'FIELDING or THROWING ERROR!
Errorx = TRUE
INCR iterrs(id)
INCR inne
i = DataRef(wag, id)
INCR GpPos(i, id, WhoAtPos)
INCR merr(i, id)
INCR SumErrors(WhoAtPos)
IF DelFac THEN CALL Msg ("02", p$, "1", "00", wag, id, man2, team2)
IF fr4 = 1 THEN '25% of infield errors are throwing errors
IF DelFac THEN
IF p$ = "3" THEN
AddToAnnouncer id, "He flips to the pitcher covering..."
ELSE
CALL Msg ("02", p$, "2", "00", wag, id, man2, team2) 'fields & throws
END IF
'No indication of where he's throwing it
CALL Msg ("30", "0","0", "02", wag, id, man2, team2) 'bad throw
END IF
ThrowError = TRUE
ELSEIF p$ < "3" THEN
IF DelFac THEN CALL Msg ("21", p$, "0", "00", wag, id, man2, team2) 'boots it
OneBaseError = TRUE
ELSE
'The ball is at an infielder (3-4-5-6) and it's a fielding error
IF fr4 > 2 THEN 'one base adv
IF DelFac THEN CALL Msg ("21", p$, "0", "01", wag, id, man2, team2) 'boots it
OneBaseError = TRUE
ELSE 'two base adv
IF DelFac THEN CALL Msg ("21", p$, "0", "02", wag, id, man2, team2) 'right by him
END IF
END IF
IF DelFac THEN CALL Msg ("30", "0","0", "09", wag, id, man2, team2) 'error
Result$ = "E-" + LTRIM$(STR$(WhoAtPos))
CALL SingleRoutine 'Sound handled in SingleRoutine
EXIT SUB
END IF
'No error (yet)
Result$ = LTRIM$(STR$(WhoAtPos))
CALL Ground 'handles sound
INCR mpo(ip, id)
EXIT SUB
'** FLY **
OutFLY: 'where did the fly go?
FoulBall = FALSE
xF! = RND 'about 70% go to outfield
i = OUTFIELDWHOAT(ppF!) 'returns 7, 8 or 9 only
IF i = 7 THEN
IF xF! > .24 THEN WhoAtPos = 7 ELSE WhoAtPos = 7 - FRND(2)
' 7 .76
' 6 .12
' 5 .12
ELSEIF i = 8 THEN
IF xF! > .47 AND xF! < .52 THEN '.05
WhoAtPos = 2
ELSEIF xF! > .20 THEN '.75
WhoAtPos = 8
ELSEIF xF! > .10 THEN '.10
WhoAtPos = 6
ELSE '.10
WhoAtPos = 4
END IF
ELSE
IF xF! > .24 THEN WhoAtPos = 9 ELSE WhoAtPos = 5 - FRND(2)
' 9 .76
' 4 .12
' 3 .12
END IF
wag = WHOATGUY(WhoAtPos)
'Infield flys:
DPsw = FALSE
xF! = RND
IF WhoAtPos < 7 THEN
IF xF! < .10 AND WhoAtPos <> 2 THEN
IF DelFac THEN
CALL Msg ("04", "0", "0", "00", wag, id, man2, team2) 'Line Shot
IF SoundOn THEN CALL WavLineDrive
END IF
IF xF! < .05 OR HitAndRun THEN '1/2 of linedrives
DPsw = TRUE 'Double play! (possibility)
END IF
ELSE
IF DelFac THEN
IF SoundOn THEN CALL WavPopUp
CALL Msg ("05", "0", "1", "00", 0, it, man2, team2) 'pop up
CALL Msg ("05", "0", "2", "00", wag, id, man2, team2) '* under it
END IF
xFF! = RND
IF (WhoAtPos = 5 OR WhoAtPos = 3) AND xFF! < .3 THEN FoulBall = TRUE
IF WhoAtPos = 2 AND xFF! < .7 THEN FoulBall = TRUE
IF FoulBall THEN
'Drifts into Foul Territory...
IF DelFac THEN CALL Msg ("29", "0", "0", "20", wag, id, man2, team2)
END IF
END IF
END IF
defperF! = DEFPCT!(wag)
Dramatic = (RND < .11)
deep = FALSE
'Outfield flys
IF WhoAtPos > 6 THEN
IF RND < .06 THEN
'Teaser for Home Run
IF DelFac THEN
IF SoundOn THEN CALL WavBigFly
CALL Msg ("09", "0", "1", "01", wag, id, man2, team2) 'There's a drive
IF RND < .1 THEN t$ = "02" ELSE t$ = "01"
CALL Msg ("09", "0", "2", t$, wag, id, man2, team2) '* going back
t$ = "01"
END IF
Dramatic = TRUE
deep = TRUE
GOTO 10060
END IF
'Outfield fly messages
t$ = LTRIM$(STR$(RND(1, 2)))
t$ = PADZEROS$(t$, 2)
IF DelFac THEN
IF Dramatic THEN
IF SoundOn THEN
IF t$ = "01" THEN
CALL WavBigFly
ELSE
CALL WavShortFly
END IF
END IF
CALL Msg ("07", "0", "1", t$, wag, id, man2, team2)
CALL Msg ("07", "0", "2", t$, wag, id, man2, team2)
CALL Msg ("07", "0", "3", t$, wag, id, man2, team2)
ELSE
IF SoundOn THEN CALL WavRegularFly
CALL Msg ("06", "0", "1", "00", wag, id, man2, team2)
CALL Msg ("06", "0", "2", "00", wag, id, man2, team2)
END IF
ELSE
deep = (RND < .38)
END IF
END IF
'Not many errors occur on fly balls (both outfield and infield here)
IF WhoAtPos < 7 THEN 'Infield Fly
zF! = defperF! * 1.03
IF zF! > .99999 THEN zF! = .99999
ELSE 'Outfield Fly
zF! = defperF! + (1 - defperF!) * .4 'was .5
END IF
IF RND > zF! THEN
'Dropped, but Infield fly rule in effect
IF ir1 > 0 AND ir2 > 0 AND iout < 2 AND WhoAtPos < 7 AND FoulBall = FALSE THEN
IF DelFac THEN
CALL Msg ("30", "0", "0", "01", wag, id, man2, team2) 'Dropped!
AddToAnnouncer id, "Infield fly rule is in effect! (No error)"
AddToAnnouncer id, "Batter is declared out! No advance..."
END IF
Result$ = "I-FLY-" + LTRIM$(STR$(WhoAtPos))
INCR iout
INCR mpo(ip, id)
EXIT SUB
END IF
Errorx = TRUE 'Error on the fly
INCR iterrs(id)
INCR inne
i = DataRef(wag, id)
INCR GpPos(i, id, WhoAtPos)
INCR merr(i, id)
INCR SumErrors(WhoAtPos)
IF DelFac THEN
CALL Msg ("30", "0", "0", "01", wag, id, man2, team2) 'Dropped!
CALL Msg ("30", "0", "0", "09", wag, id, man2, team2) 'Error
END IF
Result$ = "E-" + LTRIM$(STR$(WhoAtPos))
IF FoulBall THEN
CALL AddToScoreCrd(it, DataRef(ib, it), " ", Result$ + " (Foul)")
CALL ResetBatter
EXIT SUB
END IF
SaveSound = SoundOn
SoundOn = FALSE
IF WhoAtPos < 7 THEN 'pop-up - 1 base error
OneBaseError = TRUE
CALL SingleRoutine 'handles sound (already done)
SoundOn = SaveSound
EXIT SUB
END IF
CALL DoubleRoutine '2 base error on outfielder - handles sound
SoundOn = SaveSound
EXIT SUB
END IF
10060:
Result$ = LTRIM$(STR$(WhoAtPos))
IF FoulBall THEN Result$ = Result$ + " (Foul)"
INCR PutOuts(DataRef(wag, id), id, WhoAtPos)
CALL Fly(DPsw, Dramatic, deep, t$)
INCR mpo(ip, id)
EXIT SUB
ErrorTrap:
LOCATE 10, 30
PRINT "OUTorERR_Error"; ERRCLEAR
x$ = WAITKEY$
END SUB
SUB ParseCommand (xS$, nargs)
'Parses xS$ into ArgList(). Counts nargs.
REGISTER i AS INTEGER
nargs = 0
DIM Args$(20)
REDIM ArgList(20) AS GLOBAL ArgType
IF LEN(xS$) = 0 THEN EXIT SUB
i = 1
inword = FALSE
DO WHILE i <= LEN(xS$)
cS$ = MID$(xS$, i, 1)
IF cS$ = "/" THEN
inword = TRUE
INCR nargs
Args$(nargs) = Args$(nargs) + cS$
ELSEIF cS$ <> " " AND inword THEN
Args$(nargs) = Args$(nargs) + cS$
ELSEIF cS$ = " " THEN
inword = FALSE
END IF
INCR i
LOOP
'Special Case to pull off a /CMD file:
IF nargs = 1 THEN
y$ = UCASE$(Args$(1))
z$ = LEFT$(y$, 5)
IF z$ = "/CMD:" THEN
CmdCmdFile$ = MID$(y$, 6)
END IF
END IF
'Copy results into the global dynamic array
FOR i = 1 TO nargs
ArgList(i).Arg = Args$(i)
NEXT
END SUB
SUB PauseIt
' routine to clear keyboard CALL Clrkbd
CALL ClearInpBuffer
x$ = WAITKEY$
END SUB
SUB PickAFile (Fil$, FileLimit, List1() AS List1Type, RetKey, Pick, mous, FrameStyle)
'Return Pick and RetKey
DIM F$(9)
d = INSTR(Fil$, "|")
IF d THEN
F$(1) = MID$(Fil$, 1, d-1)
F$(2) = MID$(Fil$, d+1)
c = 2
ELSE
F$(1) = Fil$
c = 1
END IF
n = 0
FOR i = 1 TO c
CALL LoadFilesToList1 (F$(i), List1(), FileLimit, n) 'returns "n" = total files found
NEXT
IF n = 1 THEN
IF RTRIM$(List1(1).ListItem) = ".." OR _
RTRIM$(List1(1).ListItem) = "C:\" THEN
n = 0
END IF
END IF
IF n > FileLimit THEN
CALL MyBeep
x$ = "Error: Too Many Files. Limit is " + STR$(FileLimit)
CALL ErrorBox (x$)
n = FileLimit
END IF
IF n THEN ARRAY SORT List1(1) FOR n, DESCEND
SELECT CASE MenuOpt$
CASE "S"
zS$ = "Schedule Files"
yS$ = "[E]dit [N]ew ESC:Menu"
CALL PrintSCHHelp
CASE "E"
zS$ = "Series Files"
yS$ = "[V]iew [E]dit [N]ew ESC:Menu"
CALL PrintSERHelp
CASE "A"
zS$ = "Statistics Files"
yS$ = "DEL:Delete ESC:Menu"
CALL PrintSTAHelp
CASE ELSE
zS$ = ""
yS$ = ""
END SELECT
IF MenuOpt$ <> "1" THEN
row1 = 2 + rowO
col1 = 2 + colO
row2 = 10 + rowO
col2 = 46 + colO
Shadow = 0
ESCPoint = 2
r = 4 + rowO
columns = 3
itemsincol = 7
ELSE
row1 = 3 + rowO
col1 = 62 + colO
row2 = 21 + rowO
col2 = 76 + colO
Shadow = 0
ESCPoint = 2
r = 10 + rowO
columns = 1
itemsincol = 17
END IF
CALL Drawfrm (row1, col1, row2, col2, defattr, zS$, yS$, Shadow, FrameStyle, ESCPoint)
IF FrameStyle = 0 THEN x1$ = CHR$(193): x2$ = CHR$(194) ELSE x1$ = CHR$(208): x2$ = CHR$(209)
QPRINTs r, col2, x1$, defattr
QPRINTs r + 1, col2, UpPtr$, defattr
QPRINTs r + 2, col2, DnPtr$, defattr
QPRINTs r + 3, col2, x2$, defattr
DO
CALL PickFromList(List1(), n, itemsincol, columns, 12, row1,col1,row2,col2, dimattr, revattr, Pick, RetKey, nulls$, mous, ms$)
IF ms$ = CHR$(249) THEN RetKey = -61
' LOCATE 1, 1 : print "pick:";Pick;" RetKey:"; RetKey
IF RetKey THEN 'was just > 0 but need to catch negative ones too sometimes
SELECT CASE MenuOpt$
CASE "S"
CALL ExitPickForSCH(List1(), Pick, RetKey)
CASE "E"
CALL ExitPickForDAT(List1(), Pick, RetKey)
CASE "A"
CALL ExitPickForSTS(List1(), Pick, RetKey)
CASE ELSE
END SELECT
END IF
LOOP WHILE RetKey = -99
END SUB
SUB PickFromList (List1() AS List1Type, ItemsInList, ItemsInColumn, Columns, ItemLen, row, col, row2, col2, colattr, revattr, Pick, RetKey, OutDevice$, mous, ms$) STATIC
'Row and Col are coordinates of the upper-left corner of the FRAME
'Requires SUB ChangeAttribute
'Lots of the internal variables need to be STATIC because sometimes
'we jump back into the middle of this routine
IF RetKey = -99 THEN GOTO Pick1WaitForKey
IF RetKey = -97 OR RetKey = -98 THEN DisplayOnly = -1
MaxPages = 99
REDIM FirstItemOnPage(MaxPages)
Pick1BeginPage:
pageno = 1
PageItemPtr = 1
FirstItemOnPage(1) = 1
Pick1Reentry:
PageMaxItems = ItemsInColumn * Columns
ItemNum = FirstItemOnPage(pageno)
PageItemCtr = 1
PageFull = FALSE
EndOfList = FALSE
HiLiteA = colattr
IF ConsRows = 25 AND ConsCols = 80 THEN BeginBuffer
DO UNTIL PageFull
'Don't read past End of List
IF ItemNum > ItemsInList THEN
'Blank Rest of Screen
tmpPageItemCtr = PageItemCtr
DO WHILE tmpPageItemCtr <= PageMaxItems
stak = (tmpPageItemCtr - 1) \ ItemsInColumn + 1
c = col + (stak - 1) * (ItemLen + 2) + 2
r = row + tmpPageItemCtr - (stak - 1) * ItemsInColumn
QPRINTs r, c, SPACE$(ItemLen), colattr
INCR tmpPageItemCtr
LOOP
EndOfList = TRUE
PageFull = TRUE
EXIT DO
END IF
'Figure where to locate
stak = (PageItemCtr - 1) \ ItemsInColumn + 1
c = col + (stak - 1) * (ItemLen + 2) + 2
r = row + PageItemCtr - (stak - 1) * ItemsInColumn
attr = colattr
IF DisplayOnly = FALSE THEN 'Hilite item
IF PageItemCtr = PageItemPtr THEN
attr = revattr
HiLiteR = r
HiLiteC = c
END IF
END IF
IF DisplayOnly AND LEFT$(List1(ItemNum).ListItem, 1) = "~" THEN
attr = defattr
xS$ = MID$(List1(ItemNum).ListItem, 2)
ELSEIF LEFT$(List1(ItemNum).ListItem, 1) = "%" THEN
attr = skipattr
xS$ = MID$(List1(ItemNum).ListItem, 2)
IF PageItemCtr = PageItemPtr THEN
INCR PageItemPtr
END IF
ELSE
xS$ = List1(ItemNum).ListItem
END IF
QPRINTs r, c, PADRIGHT$(xS$, ItemLen), attr
INCR PageItemCtr
INCR ItemNum
IF PageItemCtr > PageMaxItems THEN PageFull = TRUE
LOOP
IF ConsRows = 25 AND ConsCols = 80 THEN EndBuffer
IF RetKey = -97 THEN Pick = 0: GOTO Pick1Exit
Pick1WaitForKey:
'Wait for arrow Items / PageUp / PageDown / Enter
DO
mous = 0
msx = 0
msy = 0
INPUT FLUSH
KyS$ = WAITKEY$
s% = INSHIFT
IF LEN(KyS$) = 1 THEN 'regular key pressed
kc = ASC(KyS$)
KyS$ = UCASE$(KyS$)
ELSEIF LEN(KyS$) = 2 THEN 'F-key pressed
kc = -ASC(RIGHT$(KyS$, 1))
ELSEIF LEN(KyS$) = 4 THEN 'mouse event
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
GOSUB FlashMouse
ELSEIF ms$ = CloseButton$ THEN
kc = 13
GOSUB FlashMouse
ELSEIF msx > col AND msx < col2 AND msy > row AND msy < row2 THEN
'INSIDE frame
IF ItemsInList THEN
'Determine PageItemPtr
PageItemPtr = msy - row + INT((msx - col - 2) / (ItemLen + 2)) * ItemsInColumn
IF PageItemPtr < 1 THEN PageItemPtr = 1
IF PageItemPtr > PageItemCtr - 1 THEN PageItemPtr = PageItemCtr - 1
DO
GOSUB PMHiLite1
'Is this a skipped field?
CALL ReadFromScreen (r, c, ItemLen, field$, "", Valid$)
IF HiLiteA <> skipattr AND _
field$ <> STRING$(ItemLen, CHR$(196)) THEN EXIT DO
'yes, skip this field
INCR PageItemPtr
IF PageItemPtr > PageItemCtr - 1 THEN
PageItemPtr = 1
END IF
LOOP
IF DoubleClick THEN
kc = 13
ELSE
GOTO PContinueLoop
END IF
ELSE
GOTO PContinueLoop
END IF
ELSEIF msx < col OR msx > col2 OR msy < row OR msy > row2 THEN
'OUTSIDE the frame - ESC
kc = 27
ELSE
'ON the frame
SELECT CASE ms$
CASE "V", "E", "A", "N", "F", "P", "Q"
KyS$ = ms$
kc = ASC(KyS$)
GOSUB FlashMouse
CASE DnPtr$
kc = -81
GOSUB FlashMouse
CASE UpPtr$
kc = -73
GOSUB FlashMouse
CASE ELSE
kc = 27
END SELECT
END IF
END IF
IF kc = -72 THEN 'Up
IF PageItemPtr > 1 THEN
DECR PageItemPtr
DO
GOSUB PMHiLite1
'Is this a skipped field?
CALL ReadFromScreen (r, c, ItemLen, field$, "", Valid$)
IF HiLiteA <> skipattr AND _
field$ <> STRING$(ItemLen, CHR$(196)) THEN EXIT DO
'Yes
DECR PageItemPtr
IF PageItemPtr < 1 THEN
PageItemPtr = PageItemCtr - 1
END IF
LOOP
GOTO PContinueLoop
END IF
END IF
IF kc = -80 THEN 'Down
IF PageItemPtr < PageItemCtr - 1 THEN
INCR PageItemPtr
DO
GOSUB PMHiLite1
'Is this a skipped field?
CALL ReadFromScreen (r, c, ItemLen, field$, "", Valid$)
IF HiLiteA <> skipattr AND _
field$ <> STRING$(ItemLen, CHR$(196)) THEN EXIT DO 'No
'Yes - experiment
INCR PageItemPtr
IF PageItemPtr > PageItemCtr - 1 THEN
PageItemPtr = 1
END IF
LOOP
GOTO PContinueLoop
END IF
END IF
IF kc = -75 THEN 'Left
IF PageItemPtr > ItemsInColumn THEN
PageItemPtr = PageItemPtr - ItemsInColumn
GOSUB PMHiLite1
GOTO PContinueLoop
END IF
END IF
IF kc = -77 THEN 'Right
IF PageItemPtr + ItemsInColumn < PageItemCtr THEN
PageItemPtr = PageItemPtr + ItemsInColumn
GOSUB PMHiLite1
GOTO PContinueLoop
END IF
END IF
IF kc = -73 THEN 'PageUp
IF pageno > 1 THEN DECR pageno
PageItemPtr = 1
GOTO Pick1Reentry
END IF
IF kc = -81 AND EndOfList = FALSE THEN 'PageDown
IF pageno < MaxPages THEN INCR pageno
FirstItemOnPage(pageno) = ItemNum
PageItemPtr = 1
GOTO Pick1Reentry
END IF
IF kc = 13 OR kc = -83 OR KyS$ = "V" OR KyS$ = "E" OR KyS$ = "A" THEN
'ENTER or DEL or V or E or A to set Pick and escape
Pick = FirstItemOnPage(pageno) + PageItemPtr - 1
IF Pick > ItemsInList THEN Pick = ItemsInList
EXIT DO
END IF
IF KyS$ = "N" THEN
'N for "new"
Pick = 0
EXIT DO
END IF
IF kc = 113 OR kc = 81 OR kc = -61 OR kc = 27 OR kc = -68 THEN
'q/Q,F3,ESC, F10 to Abort
Pick = 0
EXIT DO
END IF
IF kc = KeyF4 THEN
Pick = 0
EXIT DO
END IF
IF kc = 112 OR kc = 80 THEN '[P]rint
' xS$ = "LPT" + LTRIM$(STR$(LPTNum))
xS$ = "LPT1"
CALL DumpList(List1(), ItemsInList, xS$, FALSE)
END IF
IF kc = 102 OR kc = 70 THEN '[F]ile
IF OutDevice$ > "!" THEN
xS$ = CmdWritePath$ + OutDevice$
CALL DumpList(List1(), ItemsInList, xS$, TRUE)
CALL PopMsg(18+rowO, 26+colO, " Screen dumped to: " + xS$, errattr, 2, kc)
END IF
END IF
PContinueLoop:
LOOP
RetKey = kc
GOTO Pick1Exit
PMHiLite1:
'Feed this routine "PageItemPtr" and it hi-lites the right item
IF DisplayOnly THEN RETURN
'Reset old hilite item
CALL ChangeAttribute(HiLiteR, HiLiteC, ItemLen, HiLiteA)
'Set new hilite item
stak = (PageItemPtr - 1) \ ItemsInColumn + 1
c = col + (stak - 1) * (ItemLen + 2) + 2
r = row + PageItemPtr - (stak - 1) * ItemsInColumn
HiLiteA = SCREENATTR(r, c) 'save original color attr
'IF HiLiteA <> skipattr THEN
CALL ChangeAttribute(r, c, ItemLen, revattr) 'change to reverse
'END IF
HiLiteR = r
HiLiteC = c
RETURN
FlashMouse:
CALL FlashField (msy, msx, 1, 2, 100, 0)
RETURN
Pick1Exit:
DisplayOnly = 0
LOCATE 1, 1
END SUB
SUB PickFromPlyList (PlyList() AS PlyListType, ItemsInList, ItemsInColumn, Columns, ItemLen, row, col, row2, col2, colattr, revattr, Pick, RetKey, OutDevice$, FreezePtr) STATIC
ON ERROR GOTO ERRORTRAP
'Row and Col are coordinates of the upper-left corner of the FRAME
'Requires SUB ChangeAttribute
'Lots of the internal variables need to be STATIC because sometimes
'we jump back into the middle of this routine
IF RetKey = -99 THEN GOTO Pick2WaitForKey
DisplayOnly = (RetKey = -98)
MaxPages = 99
REDIM FirstItemOnPage(MaxPages)
Pick2BeginPage:
pageno = 1
IF FreezePtr THEN
IF PageItemPtr < 1 THEN PageItemPtr = 1
ELSE
PageItemPtr = 1
END IF
FirstItemOnPage(1) = 1
Pick2Reentry:
PageMaxItems = ItemsInColumn * Columns
ItemNum = FirstItemOnPage(pageno)
PageItemCtr = 1
PageFull = FALSE
EndOfList = FALSE
IF ConsRows = 25 AND ConsCols = 80 THEN BeginBuffer
DO UNTIL PageFull
'Don't read past End of List
IF ItemNum > ItemsInList THEN
'Blank Rest of Screen
tmpPageItemCtr = PageItemCtr
DO WHILE tmpPageItemCtr <= PageMaxItems
stak = (tmpPageItemCtr - 1) \ ItemsInColumn + 1
c = col + (stak - 1) * (ItemLen + 2) + 2
r = row + tmpPageItemCtr - (stak - 1) * ItemsInColumn
QPRINTs r, c, SPACE$(ItemLen), colattr
INCR tmpPageItemCtr
LOOP
EndOfList = TRUE
PageFull = TRUE
EXIT DO
END IF
'Figure where to locate
stak = (PageItemCtr - 1) \ ItemsInColumn + 1
c = col + (stak - 1) * (ItemLen + 2) + 2
r = row + PageItemCtr - (stak - 1) * ItemsInColumn
attr = colattr
IF DisplayOnly = FALSE THEN 'Hilite item
IF PageItemCtr = PageItemPtr THEN
attr = revattr
HiLiteR = r
HiLiteC = c
END IF
END IF
a$ = PlyList(ItemNum).Item
a$ = PADRIGHT$(a$, ItemLen)
QPRINTs r, c, a$, attr
INCR PageItemCtr
INCR ItemNum
IF PageItemCtr > PageMaxItems THEN PageFull = TRUE
LOOP
IF ConsRows = 25 AND ConsCols = 80 THEN EndBuffer
Pick2WaitForKey:
'Wait for arrow Items / PageUp / PageDown / Enter
DO
msx = 0
msy = 0
KyS$ = WAITKEY$
s% = INSHIFT
IF LEN(KyS$) = 1 THEN
kc = ASC(KyS$)
KyS$ = UCASE$(KyS$)
ELSEIF LEN(KyS$) = 2 THEN
kc = -ASC(RIGHT$(KyS$, 1))
ELSEIF LEN(KyS$) = 4 THEN
IF ASC(KyS$, 3) = 2 THEN
DoubleClick = TRUE
ELSE
DoubleClick = FALSE
END IF
msx = MOUSEX
msy = MOUSEY
ms$ = CHR$(SCREEN(msy, msx))
IF ms$ = CHR$(249) THEN
kc = 27
ELSEIF ms$ = CloseButton$ THEN
kc = 13
ELSEIF msx > col AND msx < col2 AND msy > row AND msy < row2 THEN
'INSIDE frame
'Determine PageItemPtr
PageItemPtr = msy - row + INT((msx - col - 2) / (ItemLen + 2)) * ItemsInColumn
IF PageItemPtr < 1 THEN PageItemPtr = 1
IF PageItemPtr > PageItemCtr - 1 THEN PageItemPtr = PageItemCtr - 1
GOSUB PMHiLite2
IF DoubleClick THEN
kc = 13
ELSE
GOTO PContinueLoop2
END IF
ELSEIF msx < col OR msx > col2 OR msy < row OR msy > row2 THEN
'OUTSIDE the frame - ESC
kc = 27
ELSE
'ON the frame
SELECT CASE ms$
CASE "V", "E", "A", "N", "Q", "F", "P"
KyS$ = ms$
kc = ASC(KyS$)
GOSUB FlashMouse
CASE DnPtr$
kc = -81
GOSUB FlashMouse
CASE UpPtr$
kc = -73
GOSUB FlashMouse
CASE ELSE
kc = 27
END SELECT
END IF
END IF
IF kc = -72 THEN 'Up
IF PageItemPtr > 1 THEN
DECR PageItemPtr
GOSUB PMHiLite2
GOTO PContinueLoop2
END IF
END IF
IF kc = -80 THEN 'Down
IF PageItemPtr < PageItemCtr - 1 THEN
INCR PageItemPtr
GOSUB PMHiLite2
GOTO PContinueLoop2
END IF
END IF
IF kc = -75 THEN 'Left
IF PageItemPtr > ItemsInColumn THEN
PageItemPtr = PageItemPtr - ItemsInColumn
GOSUB PMHiLite2
GOTO PContinueLoop2
END IF
END IF
IF kc = -77 THEN 'Right
IF PageItemPtr + ItemsInColumn < PageItemCtr THEN
PageItemPtr = PageItemPtr + ItemsInColumn
GOSUB PMHiLite2
GOTO PContinueLoop2
END IF
END IF
IF kc = -73 THEN 'PageUp
IF pageno > 1 THEN DECR pageno
PageItemPtr = 1
GOTO Pick2Reentry
END IF
IF kc = -81 AND EndOfList = FALSE THEN 'PageDown
IF pageno < MaxPages THEN INCR pageno
FirstItemOnPage(pageno) = ItemNum
PageItemPtr = 1
GOTO Pick2Reentry
END IF
IF kc = 13 THEN 'Enter : set Pick and escape
Pick = FirstItemOnPage(pageno) + PageItemPtr - 1
EXIT DO
END IF
IF kc = 113 OR kc = 81 OR kc = -61 OR kc = 27 THEN
'q,Q,F3,ESC to Abort
Pick = 0
EXIT DO
END IF
PContinueLoop2:
LOOP
RetKey = kc
GOTO Pick2Exit
PMHiLite2:
'Reset old hilite item
CALL ChangeAttribute(HiLiteR, HiLiteC, ItemLen, colattr)
'set new hilite item
stak = (PageItemPtr - 1) \ ItemsInColumn + 1
c = col + (stak - 1) * (ItemLen + 2) + 2
r = row + PageItemPtr - (stak - 1) * ItemsInColumn
CALL ChangeAttribute(r, c, ItemLen, revattr)
HiLiteR = r
HiLiteC = c
RETURN
FlashMouse:
CALL FlashField (msy, msx, 1, 2, 100, 0)
RETURN
Pick2Exit:
LOCATE 1, 1
EXIT SUB
ErrorTrap:
LOCATE 10, 30
PRINT "ERROR: PickFrPL"; ERRCLEAR
x$ = WAITKEY$
END SUB
SUB PickTheStarter(tm, r, N)
' [in: tm, r(ow)] [out: Pick] r = 8
REDIM PlyList(1 TO 21) AS PlyListType
REDIM StartsList(1 TO 21) AS RankType
'Decide if we're going to sort by number of starts or just pick first 5
'Count how many pitchers have "starts" : Av
Av = 0
FOR j = 10 TO LastPiAd(tm)
IF DataPos(j, tm) = 1 AND DataGbyP(j, tm, 1) > 0 THEN
IF Av < 20 THEN
INCR Av
xS$ = LTRIM$(STR$(DataGbyP(j, tm, 1))) 'Starts
StartsList(Av).Criteria = PADZEROS$(xS$, 4)
StartsList(Av).Slot = j
END IF
END IF
NEXT
'fS$ = "\ \ \\ ## ## ### ## #### #### ### ### #.##"
IF Av < 5 THEN 'Punt -- just list first five
i = 0
IF LastPiAd(tm) < 14 THEN k = LastPiAd(tm) ELSE k = 14
IF k = 0 THEN k = 11
FOR j = 10 TO k
a$ = SPACE$(60)
IF CmdStat$ > "!" AND DaysOffRule = TRUE THEN
m = GetDaysOff (j, tm)
IF m THEN
MID$(a$, 1, 1) = LFORMAT$(m, "#")
END IF
END IF
MID$(a$, 3, 17) = DataName(j, tm)
MID$(a$, 22, 1) = DataHand(j, tm)
MID$(a$, 26, 2) = LFORMAT$(DataDef(j, tm), "##")
MID$(a$, 29, 2) = LFORMAT$(DataSB(j, tm), "##")
MID$(a$, 32, 3) = LFORMAT$(DataGames(j, tm), "##")
MID$(a$, 36, 2) = LFORMAT$(DataGbyP(j, tm, 1), "##")
MID$(a$, 39, 4) = LFORMAT$(DataAB(j, tm), "####")
MID$(a$, 44, 4) = LFORMAT$(DataHits(j, tm), "####")
MID$(a$, 49, 3) = LFORMAT$(DataBB(j, tm), "###")
MID$(a$, 53, 3) = LFORMAT$(DataSO(j, tm), "###")
MID$(a$, 57, 4) = FFORMAT$(DataRBI(j, tm) / 100, "#.##")
INCR i
PlyList(i).Item = a$
PlyList(i).Ref = j
NEXT
Av = k - 10 + 1
ELSE 'list the starters
ARRAY SORT StartsList(1) FOR Av, FROM 1 TO 4, DESCEND
i = 0
FOR k = 1 TO Av
j = StartsList(k).Slot
a$ = SPACE$(60)
IF CmdStat$ > "!" AND DaysOffRule = TRUE THEN
m = GetDaysOff (j, tm)
IF m THEN
MID$(a$, 1, 1) = LFORMAT$(m, "#")
END IF
END IF
MID$(a$, 3, 17) = DataName(j, tm)
MID$(a$, 22, 1) = DataHand(j, tm)
MID$(a$, 26, 2) = LFORMAT$(DataDef(j, tm), "##")
MID$(a$, 29, 2) = LFORMAT$(DataSB(j, tm), "##")
MID$(a$, 32, 3) = LFORMAT$(DataGames(j, tm), "##")
MID$(a$, 36, 2) = LFORMAT$(DataGbyP(j, tm, 1), "##")
MID$(a$, 39, 4) = LFORMAT$(DataAB(j, tm), "####")
MID$(a$, 44, 4) = LFORMAT$(DataHits(j, tm), "####")
MID$(a$, 49, 3) = LFORMAT$(DataBB(j, tm), "###")
MID$(a$, 53, 3) = LFORMAT$(DataSO(j, tm), "###")
MID$(a$, 57, 4) = FFORMAT$(DataRBI(j, tm) / 100, "#.##")
INCR i
PlyList(i).Item = a$
PlyList(i).Ref = j
NEXT
END IF
' r2 = r + 12 'Allows display of 10 starters
' r2 = r + 15 'Allows display of 13 starters
r2 = r + Av + 2
IF r2 > 23 THEN r2 = 23
FreezePtr = FALSE
IF MenuOpt$ = "M" THEN 'Manual Mode
CALL Drawfrm(r+rowO, 7+colO, r2+rowO, 71+colO, defattr, "Select Starting Pitcher for '" + Names(tm), "Dbl-click (or Enter) selection or ESC to Abort", 1, 0, 2)
ELSEIF MMx THEN 'Manual Manage within a Schedule
CALL Drawfrm(r+rowO, 7+colO, r2+rowO, 71+colO, defattr, "Select Starting Pitcher for '" + Names(tm), "Dbl-click (or Enter) selection", 1, 0, 1)
ELSE 'Two-Team Mode
CALL Drawfrm(r+rowO, 7+colO, r2+rowO, 71+colO, defattr, "Select Pitching Rotation for '" + Names(tm), "Dbl-click (or Enter) selection -- ESC When Done", 1, 0, 2)
IF SelX > 0 THEN FreezePtr = TRUE
END IF
QPRINTs r+1+rowO, 10+colO, " Name L/R W L G St Inn Hits BB SO ERA", dimattr
PTSTryAgain:
CALL PickFromPlyList (PlyList(), Av, r2-r-2, 1, 60, r+1+rowO, 8+colO, r2+rowO, 71+colO, dimattr, revattr, Pick, RetKey, nulls$, FreezePtr)
IF Pick > 0 THEN
N = PlyList(Pick).Ref
ELSE
N = 0
END IF
IF MMx AND CmdStat$ > "!" AND DaysOffRule = TRUE THEN
'What if all pitchers are tired?
AllAreTired = TRUE
FOR i = 1 TO Av
ii = PlyList(i).Ref
IF GetDaysOff (ii, tm) = 0 THEN AllAreTired = FALSE
NEXT
IF AllAreTired = FALSE THEN
IF GetDaysOff (N, tm) > 0 THEN
x$ = " That pitcher seems to have the day off. | "
x$ = x$ + "Start this pitcher anyway? [Y/n] "
CALL PopMsg(MidRow+8, MidCol-20, x$, errattr, 0, kc)
IF UCASE$(CHR$(kc)) = "N" THEN
GOTO PTSTryAgain
END IF
END IF
END IF
END IF
ERASE PlyList
END SUB
SUB PinchHit (m)
ON ERROR GOTO ERRORTRAP
IF amgr(it) THEN
IF m > LastPiAd(it) THEN 'AutoManager has already selected PHitter
GOTO P50
ELSE
GOTO P999
END IF
END IF
'Select Bench List
REDIM PlyList(1 TO 30) AS PlyListType 'was 15
Av = 0
FOR j = LastPiAd(it) + 1 TO MAXPLAYERS
IF Av < 30 THEN
IF DataName(j, it) < "." THEN pend = j - 1: EXIT FOR
IF DataAB(j, it) = 0 THEN
BAF! = 0
ELSE
BAF! = DataHits(j, it) / DataAB(j, it)
END IF
flag$ = " "
IF iused(j, it) THEN flag$ = "x"
'Is the bench player's name identical to a current or used pitcher?
FOR i = 1 TO np(it)
IF DataName(j, it) = DataName(iyp(i,it), it) THEN flag$ = "x"
NEXT
'f$ = "\\\ \ \\ ### ### ### ## ### ### ### ### \\## ### ## ### .###"
a$ = SPACE$(73)
MID$(a$, 1, 1) = flag$
MID$(a$, 3, 16) = DataName(j, it)
MID$(a$, 20, 2) = Pos(DataPos(j, it))
MID$(a$, 23, 3) = LFORMAT$(DataAB(j, it), "###")
MID$(a$, 27, 3) = LFORMAT$(DataHits(j, it), "###")
MID$(a$, 31, 3) = LFORMAT$(Data2B(j, it), "###")
MID$(a$, 35, 2) = LFORMAT$(Data3B(j, it), "##")
MID$(a$, 38, 3) = LFORMAT$(DataHR(j, it), "###")
MID$(a$, 42, 3) = LFORMAT$(DataRBI(j, it), "###")
MID$(a$, 46, 3) = LFORMAT$(DataBB(j, it), "###")
MID$(a$, 50, 3) = LFORMAT$(DataSO(j, it), "###")
MID$(a$, 54, 1) = DataHand(j, it)
MID$(a$, 56, 2) = LFORMAT$(DataSpeed(j, it), "##")
MID$(a$, 59, 3) = LFORMAT$(DataSB(j, it), "###")
MID$(a$, 63, 2) = LFORMAT$(DataCS(j, it), "##")
MID$(a$, 66, 3) = LFORMAT$(DataDef(j, it), "###")
MID$(a$, 70, 4) = FFORMAT$(BAF!, ".###")
INCR Av
PlyList(Av).Item = a$
PlyList(Av).Ref = j
END IF
NEXT
'Display Bench
QPush
P5:
r = Av + 7 + rowO
IF r > (ConsRows - 2) THEN r = ConsRows - 2
IF Gfx THEN CALL GraphHole(30, 5+rowO, 2+colO, r+1, 80+colO)
CALL Drawfrm(5+rowO, 2+colO, r, 78+colO, defattr, "'" + RTRIM$(Names(it)) + " Bench", "Dbl-click (or Enter) selection or ESC", 1, 0, 2)
IF Av > (r-7-rowO) THEN
x1$ = CHR$(193): x2$ = CHR$(194)
col2 = 78+colO
row2 = (5 + rowO + r ) \ 2 - 1
QPRINTs row2, col2, x1$, defattr
QPRINTs row2 + 1, col2, UpPtr$, defattr
QPRINTs row2 + 2, col2, DnPtr$, defattr
QPRINTs row2 + 3, col2, x2$, defattr
END IF
xS$ = " Name P AB HIT 2B 3B HR RBI BB SO B S SB CS Def Avg"
IF ERRSw(it) THEN MID$(xS$, 67, 3) = "ERR"
QPRINTs 6+rowO, 3+colO, xS$, defattr
'Row and Col are coordinates of the upper-left corner of the FRAME
' (PlyList() AS PlyListType, ItemsInList, ItemsInColumn, Columns, ItemLen, row, col, row2, col2, colattr, revattr, Pick, RetKey, OutDevice$, FreezePtr)
CALL PickFromPlyList (PlyList(), Av, r-7-rowO, 1, 74, 6+rowO, 2+colO, r, 78+colO, dimattr, revattr, Pick, RetKey, nulls$, 0)
IF Pick > 0 THEN
m = PlyList(Pick).Ref
ELSE
m = 0
ERASE PlyList
GOTO P999
END IF
IF iused(m, it) THEN
CALL PopMsg(r, 16+colO, " Player has already hit the showers! Try again. ", errattr, 2, kc)
GOTO P5
END IF
'Is the selected player's name identical to a current or used pitcher?
ie = 0
FOR i = 1 TO np(it)
IF DataName(m, it) = DataName(iyp(i,it), it) THEN ie = -1
NEXT
IF ie THEN
CALL PopMsg(r, 16+colO, " Already used as a pitcher! Try again. ", errattr, 2, kc)
GOTO P5
END IF
'Pinch-hitter selected "m"
P50:
CALL AddToScoreCrd(it, DataRef(ib, it), "9", "(for PH)") 'EX:
IF DataPos(ib, it) = 1 THEN 'Pinch hitting for pitcher
IF NOT amgr(it) THEN 'Patch 03-21-08
SaveDaysOffRule = DaysOffRule
DaysOffRule = FALSE
END IF
CALL CountAvPitchers (it, AvP, LastGuy)
IF NOT amgr(it) THEN 'Patch 03-21-08
DaysOffRule = SaveDaysOffRule
END IF
IF AvP < 1 THEN
IF NOT amgr(it) THEN
CALL PopMsg(r, 23+colO, " You don't have any pitchers left! ", errattr, 2, kc)
END IF
m = 0
GOTO P999
END IF
CALL Switch(m, ib, it) 'Pinch hitter takes pitchers spot
DataPos(ib, it) = 1 'Call pinch hitter a pitcher temporarily
iused(m, it) = TRUE 'Mark replaced hitter (the old pitcher) as used
'I question whether the above statement should use a reference number
'instead of "m"
iused(ipa(it), it) = TRUE 'Mark old pitcher as used in his pitcher slot
ELSE 'Pinch hitting for a non-pitcher
OldPos = DataPos(ib, it) 'Save defensive position of player being pulled
CALL Switch(m, ib, it) 'Call switch routine to swap players M and IB on team IT
DataPos(ib, it) = OldPos 'Pinch hitter goes into play the old defensive position
iused(m, it) = TRUE 'Mark replaced hitter as used
' see comment above
END IF
CALL AddToRefByBO (ib, it, DataRef(ib, it)) 'bat position, team, ref
P999:
IF NOT amgr(it) THEN
QPop
IF Gfx THEN
CALL EliminateHole(30)
CALL UnfreezeAndRefresh
END IF
END IF
EXIT SUB
ErrorTrap:
LOCATE 10, 30
PRINT "ERROR: PinchH "; ERRCLEAR
x$ = WAITKEY$
END SUB
SUB PinchRun (m, runner)
ON ERROR GOTO ERRORTRAP
IF amgr(it) THEN
IF m > LastPiAd(it) THEN 'AutoManager has already selected PRunner
GOTO PR50
ELSE
GOTO PR999
END IF
END IF
QPush
'Display baserunners
IF ir1 = 0 AND ir2 = 0 AND ir3 = 0 THEN
CALL PopMsg(18+rowO, 27+colO, " There are no baserunners! ", errattr, 2, kc)
GOTO PR999
END IF
'What if there's only 1 baserunner?
IF (ir1 > 0 AND ir2 = 0 AND ir3 = 0) THEN runner = ir1: GOTO PR12
IF (ir2 > 0 AND ir1 = 0 AND ir3 = 0) THEN runner = ir2: GOTO PR12
IF (ir3 > 0 AND ir1 = 0 AND ir2 = 0) THEN runner = ir3: GOTO PR12
'Display Baserunners
IF Gfx THEN CALL GraphHole(30, 2+rowO, 8+colO, 9+rowO, 74+colO)
CALL Drawfrm(2+rowO, 8+colO, 8+rowO, 72+colO, defattr, nulls$, nulls$, 1, 0, 1)
QPRINTs 3+rowO, 27+colO, "The Baserunners are:", defattr
k = 4 + rowO 'Line counter
IF ir1 THEN
xS$ = LASTNAME$(DataName(ir1, it))
z$ = "1) First Base - " + xS$
QPRINTs k, 27+colO, z$, defattr
END IF
IF ir2 THEN
INCR k
xS$ = LASTNAME$(DataName(ir2, it))
z$ = "2) Second Base - " + xS$
QPRINTs k, 27+colO, z$, defattr
END IF
IF ir3 THEN
INCR k
xS$ = LASTNAME$(DataName(ir3, it))
z$ = "3) Third Base - " + xS$
QPRINTs k, 27+colO, z$, defattr
END IF
'Find out who we are pinch running for:
PR10:
QPRINTs 7+rowO, 10+colO, "Indicate by base number who you are running for [1 2 3]: ", defattr
n = VAL(MYINPUT$(FALSE, KeyEscape, CustomEscKey, KeyAccept, kc, revfor, revbac, 7+rowO, 67+colO, 1, "NE", 1, 3, nulls$, msx, msy))
'Handle all mouse stuff here since the edit code is "NE" which doesn't
'return anything through MYINPUT$
'Any "bad" mouse click should close this and return
IF msx > 0 AND msy > 0 THEN
a$ = CHR$(SCREEN(msy, msx))
IF a$ > "0" AND a$ < "4" THEN
QPRINTs 7+rowO, 67+colO, a$, defattr
n = VAL(a$)
ELSE
n = 0
END IF
END IF
IF n = 0 THEN
m = 0
GOTO PR999
END IF
IF (n = 1 AND ir1 = 0) OR (n = 2 AND ir2 = 0) OR (n = 3 AND ir3 = 0) THEN
CALL MyBeep
GOTO PR10
END IF
IF n = 1 THEN runner = ir1
IF n = 2 THEN runner = ir2
IF n = 3 THEN runner = ir3
PR12:
'Build Bench List
REDIM PlyList(1 TO 30) AS PlyListType
Av = 0
FOR j = LastPiAd(it) + 1 TO MAXPLAYERS
IF Av < 30 THEN
IF DataName(j, it) < "." THEN pend = j - 1: EXIT FOR
IF DataAB(j, it) = 0 THEN
BAF! = 0
ELSE
BAF! = DataHits(j, it) / DataAB(j, it)
END IF
IF iused(j, it) THEN flag$ = "x" ELSE flag$ = " "
'Is the bench player's name identical to a current or used pitcher?
FOR i = 1 TO np(it)
IF DataName(j, it) = DataName(iyp(i,it), it) THEN flag$ = "x"
NEXT
'f$ = "\\\ \ \\ ### ### ### ## ### ### ### ### \\## ### ## ### .###"
a$ = SPACE$(73)
MID$(a$, 1, 1) = flag$
MID$(a$, 3, 16) = DataName(j, it)
MID$(a$, 20, 2) = Pos(DataPos(j, it))
MID$(a$, 23, 3) = LFORMAT$(DataAB(j, it), "###")
MID$(a$, 27, 3) = LFORMAT$(DataHits(j, it), "###")
MID$(a$, 31, 3) = LFORMAT$(Data2B(j, it), "###")
MID$(a$, 35, 2) = LFORMAT$(Data3B(j, it), "##")
MID$(a$, 38, 3) = LFORMAT$(DataHR(j, it), "###")
MID$(a$, 42, 3) = LFORMAT$(DataRBI(j, it), "###")
MID$(a$, 46, 3) = LFORMAT$(DataBB(j, it), "###")
MID$(a$, 50, 3) = LFORMAT$(DataSO(j, it), "###")
MID$(a$, 54, 1) = DataHand(j, it)
MID$(a$, 56, 2) = LFORMAT$(DataSpeed(j, it), "##")
MID$(a$, 59, 3) = LFORMAT$(DataSB(j, it), "###")
MID$(a$, 63, 2) = LFORMAT$(DataCS(j, it), "##")
MID$(a$, 66, 3) = LFORMAT$(DataDef(j, it), "###")
MID$(a$, 70, 4) = FFORMAT$(BAF!, ".###")
INCR Av
PlyList(Av).Item = a$
PlyList(Av).Ref = j
END IF
NEXT
'Display/Pick Player
PR15:
r = Av + 12 + rowO
IF r > (ConsRows-2) THEN r = ConsRows-2
IF Gfx THEN CALL GraphHole(32, 10+rowO, 2+colO, r+1, 80+colO)
CALL Drawfrm(10+rowO, 2+colO, r, 78+colO, defattr, "'" + RTRIM$(Names(it)) + " Bench", "Dbl-click (or Enter) selection or ESC", 1, 0, 2)
IF Av > (r-12-rowO) THEN
x1$ = CHR$(193): x2$ = CHR$(194)
col2 = 78+colO
row2 = (10 + rowO + r ) \ 2 - 1
QPRINTs row2, col2, x1$, defattr
QPRINTs row2 + 1, col2, UpPtr$, defattr
QPRINTs row2 + 2, col2, DnPtr$, defattr
QPRINTs row2 + 3, col2, x2$, defattr
END IF
xS$ = " Name P AB HIT 2B 3B HR RBI BB SO B S SB CS Def Avg"
IF ERRSw(it) THEN MID$(xS$, 67, 3) = "ERR"
QPRINTs 11+rowO, 3+colO, xS$, defattr
'Row and Col are coordinates of the upper-left corner of the FRAME
CALL PickFromPlyList (PlyList(), Av, r-12-rowO, 1, 74, 11+rowO, 2+colO, r, 78+colO, dimattr, revattr, Pick, RetKey, nulls$, 0)
IF Pick > 0 THEN
m = PlyList(Pick).Ref
ELSE
m = 0
ERASE PlyList
GOTO PR999
END IF
IF iused(m, it) THEN
CALL PopMsg(r, 17+colO, " You've already used that guy! Try again. ", errattr, 2, kc)
GOTO PR15
END IF
'Fix: 2/23/05
'Is the selected player's name identical to a current or used pitcher?
ie = 0
FOR i = 1 TO np(it)
IF DataName(m, it) = DataName(iyp(i,it), it) THEN ie = -1
NEXT
IF ie THEN
CALL PopMsg(r, 17+colO, " Already used as a pitcher! Try again. ", errattr, 2, kc)
GOTO PR15
END IF
PR50:
'Pinch-runner has been seleted (m)
'Pinch running for the pitcher
CALL AddToScoreCrd(it, DataRef(runner, it), "9", "(for PR)") 'EX:
IF DataPos(runner, it) = 1 THEN
IF NOT amgr(it) THEN 'Patch 03-21-08
SaveDaysOffRule = DaysOffRule
DaysOffRule = FALSE
END IF
CALL CountAvPitchers (it, AvP, LastGuy)
IF NOT amgr(it) THEN 'Patch 03-21-08
DaysOffRule = SaveDaysOffRule
END IF
IF AvP < 1 THEN
IF NOT amgr(it) THEN CALL PopMsg(18+rowO, 20+colO, " You don't have any pitchers left! ", errattr, 2, kc)
m = 0
GOTO PR999
END IF
'Mark old pitcher as used
iused(ipa(it), it) = TRUE
'info 09/03/05
' x$ = "Runner=" + STR$(runner) + "|"
' x$ = x$ + "ipa(it)=" + STR$(ipa(it)) + "|"
' x$ = x$ + "DataRef(runner,it)=" + STR$(DataRef(runner,it))
' CALL ErrorBox (x$)
END IF
'Swap players m (from the bench) and runner on team "it"
OldPos = DataPos(runner, it)
CALL Switch(m, runner, it)
DataPos(runner, it) = OldPos
iused(m, it) = TRUE 'I wonder if this should be the ref#(m) instead
CALL AddToRefByBO (runner, it, DataRef(runner, it)) 'bat pos, team, ref
CALL AddToScoreCrd(it, DataRef(runner, it), "7", "")
PR999:
IF NOT amgr(it) THEN
QPop
IF Gfx THEN
CALL EliminateHole(30)
CALL EliminateHole(32)
CALL UnfreezeAndRefresh
END IF
END IF
EXIT SUB
ErrorTrap:
LOCATE 10, 30
PRINT "ERROR: PinchR "; ERRCLEAR
x$ = WAITKEY$
END SUB
SUB PitchersWLS (team, player, w, l, s, era!)
w = 0
l = 0
s = 0
era! = 0.
IF CmdStat$ > "!" THEN
Find$ = League(team) + PADRIGHT$(Names(team), 12) + PADRIGHT$(NameRef(player, team), 16)
TotalRecs = PSum(0).PGameCtr
CALL BinarySearchP (PSum(), 1, 29, 1, TotalRecs, Find$, FoundAt, mini)
IF FoundAt THEN
w = PSum(FoundAt).PWin
l = PSum(FoundAt).PLoss
s = PSum(FoundAt).PSave
IF PSum(FoundAt).PInns > 0 THEN
era! = PSum(FoundAt).PERuns * 9.0 / _
(PSum(FoundAt).PInns + PSum(FoundAt).P3rds / 3)
IF era! > 99.9 THEN era! = 99.9
ELSE
era! = 0.
END IF
END IF
END IF
END SUB
SUB PopMsg (row, col, xS$, attr, waittime, kc)
' row, col are Upper Left Corner
' Support string argument parsed by "|"
n = PARSECOUNT(xS$, "|")
' Find length of the longest segment
LMax = 0
FOR i = 1 TO n
x$ = PARSE$(xS$, "|", i)
L = LEN(x$)
IF L > LMax THEN LMax = L
NEXT
'Save screen
IF Gfx AND RegDsply THEN
CALL GraphHole(31, row, col, row+n-1, col+LMax-1)
END IF
CALL GetScreen(ScrString$, row, col, row+n-1, col+LMax-1)
'Print
r = row
FOR i = 1 TO n
x$ = PARSE$(xS$, "|", i)
L = LEN(x$)
IF L < LMax THEN x$ = x$ + SPACE$(LMax - L)
QPRINTs r, col, x$, attr
INCR r
NEXT
'Pause for reply
IF waittime THEN
SLEEP waittime * 1000
kc = 0
ELSE
a$ = WAITKEY$
IF LEN(a$) = 4 THEN
kc = SCREEN(MOUSEY, MOUSEX)
ELSE
kc = ASC(a$)
END IF
END IF
'Restore screen
CALL PutScreen(ScrString$, row, col, row+n-1, col+LMax-1)
IF Gfx AND RegDsply THEN
CALL EliminateHole(31)
CALL UnfreezeAndRefresh
END IF
END SUB
SUB PopWindow (row1, col1, row2, col2, win)
' win = 1 is offense window, = 2 is defense window
COLOR deffor, defbac
col = col1 + 1
IF win = 1 THEN
QPRINTs row1 + 1, col, " On Off", defattr
QPRINTs row1 + 2, col, " EXIT ", defattr
QPRINTs row1 + 3, col, " Pinch Hit ", defattr
QPRINTs row1 + 4, col, " Pinch Run ", defattr
QPRINTs row1 + 5, col, " View Line-up ", defattr
QPRINTs row1 + 6, col, " View Opponent ", defattr
IF WarmUpRule THEN attr = defattr ELSE attr = CALCATTR(0, 1) 'black on blue
QPRINTs row1 + 7, col, " Call Bullpen ", attr
QPRINTs row1 + 8, col, STRING$(20, CHR$(196)), defattr
QPRINTs row1 + 9, col, " Steal ", defattr
QPRINTs row1 + 10, col, " Bunt/Squeeze ", defattr
QPRINTs row1 + 11, col, " Hit & Run ", defattr
END IF
IF win = 2 THEN
QPRINTs row1 + 1, col, " On Off", defattr
QPRINTs row1 + 2, col, " EXIT ", defattr
QPRINTs row1 + 3, col, " Visit Mound ", defattr
QPRINTs row1 + 4, col, " Substitute ", defattr
QPRINTs row1 + 5, col, " Swap Positions ", defattr
QPRINTs row1 + 6, col, " View Line-up ", defattr
QPRINTs row1 + 7, col, " View Opponent ", defattr
QPRINTs row1 + 8, col, STRING$(20, CHR$(196)), defattr
QPRINTs row1 + 9, col, " Intent. Walk ", defattr
QPRINTs row1 + 10, col, " Infield In ", defattr
QPRINTs row1 + 11, col, " Pitch-Out ", defattr
QPRINTs row1 + 12, col, " Pitch-Around ", defattr
END IF
END SUB
SUB PostAnnouncer (PauseAfterEachLine, FlashWhoAt)
REGISTER i AS INTEGER, c AS INTEGER
L = 38 + colO
xS$ = SPACE$(L)
IF DelFac = 0 AND amgr(1) AND amgr(2) THEN
QPRINTs 2, 42, xS$, scdattr
QPRINTs 3, 42, " Quick Play Mode ", scdattr
QPRINTs 4, 42, xS$, scdattr
ELSE
'Is it an "instant win" situation?
IF inn >= RegInns AND it = 2 THEN
IF itruns(2) > itruns(1) THEN
IF IGone THEN AddToAnnouncer it, "Gone!"
AddToAnnouncer it, "Game's over!"
END IF
END IF
c = 0
FOR i = 1 TO ANx
'Clear Box Method
IF i = 1 OR i = 4 OR i = 7 OR i = 10 THEN
QPRINTs 2, 42, xS$, scdattr
QPRINTs 3, 42, xS$, scdattr
QPRINTs 4, 42, xS$, scdattr
c = 0
END IF
dS$ = LEFT$(Announcer(i).mgs, L)
INCR c
IF SoundOn AND AnnouncerOn THEN
QPRINTs c + 1, 42, dS$, scdattr
REPLACE "..." WITH ": " IN dS$
REPLACE "--" WITH ": " IN dS$
REPLACE "0 for " WITH "oh for " IN dS$
REPLACE "retired!" WITH "retired" IN dS$
REPLACE "there!" WITH "there" IN dS$
'Look for announcer.exe first
IF LEN(DIR$("announcer.exe")) THEN
zS$ = "announcer.exe " + dS$
ELSEIF LEN(DIR$("blabber.exe")) THEN
zS$ = "blabber.exe " + dS$
ELSE
zS$ = null$
END IF
IF zS$ > "!" THEN
ShowWindState& = 0
ConsoleShell zS$, ShowWindState&
'More time for announcer to speak
L = LEN(dS$)
SLEEP (L * 35)
END IF
ELSE
QPRINTs c + 1, 42, dS$, scdattr
END IF
IF i < ANx THEN
IF PauseAfterEachLine THEN
IF i = 1 AND FlashWhoAt THEN
IF OrgWhoAtPos THEN WhoAtPos = OrgWhoAtPos
IF WhoAtPos THEN CALL Flash(WhoAtPos, FALSE)
END IF
IF i = 3 OR i = 6 THEN
SLEEP (DelFac * 175) 'A little extra time before the screen is erased on next line
END IF
SLEEP (DelFac * 250) 'was 300
END IF
END IF
NEXT
END IF
END SUB
SUB PrintSCHHelp
CALL Drawfrm(12+rowO, 8+colO, 24+rowO, 71+colO, defattr, nulls$, nulls$, 1, 0, 0)
r = 13 + rowO
c = 10 + colO
QPRINTs r, c, " SCH files are a database of games played by date. You can ", dimattr
QPRINTs r+1, c, "interrupt a SCH and the stats and re-start data are saved ", dimattr
QPRINTs r+2, c, "so you can continue later (but be sure to specify the same ", dimattr
QPRINTs r+3, c, "stat file). ", dimattr
QPRINTs r+4, c, " To manage one or more teams yourself, press E to edit the ", dimattr
QPRINTs r+5, c, "schedule. Then select the starting date when YOU want to ", dimattr
QPRINTs r+6, c, "manage your team(s). In the Options column, type in /vm:+ (to", dimattr
QPRINTs r+7, c, "indicate you wish to manage the visiting team) or /hm:+ (to ", dimattr
QPRINTs r+8, c, "indicate the home team). To remove your team(s) from manual ", dimattr
QPRINTs r+9, c, "control type in /vm:- or /hm:- on the date when you want the ", dimattr
QPRINTs r+10,c, "computer to take over. See documentation for details. ", dimattr
END SUB
SUB PrintSERHelp
CALL Drawfrm(12+rowO, 8+colO, 23+rowO, 71+colO, defattr, nulls$, nulls$, 1, 0, 0)
r = 13 + rowO
c = 10 + colO
QPRINTs r, c, " SER files are just a simple text listing of games to be ", dimattr
QPRINTs r+1, c, "played. A simulation based on a SER file CANNOT be restarted ", dimattr
QPRINTs r+2, c, "at the point it was interrupted, so you usually want to let ", dimattr
QPRINTs r+3, c, "them finish once you start one. Generally you want SBS to ", dimattr
QPRINTs r+4, c, "manage all the teams and crank through the simulation as ", dimattr
QPRINTs r+5, c, "quickly as possible. ", dimattr
QPRINTs r+6, c, " Hit [V] or [E] to view or edit. Notice that /H: and /V: ", dimattr
QPRINTs r+7, c, "specify home and visitor and /n: specifies the number of ", dimattr
QPRINTs r+8, c, "games to run. Those are usually the only options that a SER ", dimattr
QPRINTs r+9, c, "file uses. See documentation for details. ", dimattr
END SUB
SUB PrintSTAHelp
CALL Drawfrm(14+rowO, 8+colO, 22+rowO, 71+colO, defattr, nulls$, nulls$, 1, 0, 0)
r = 15 + rowO
c = 10 + colO
QPRINTs r, c, " These are the statistics files that have been specified by", dimattr
QPRINTs r+1, c, "the user in the [Statistics Recording Options] window. No ", dimattr
QPRINTs r+2, c, "matter which simulation type you choose (manual, two-team, ", dimattr
QPRINTs r+3, c, "SCH or SER) you have the option of saving the statistics that", dimattr
QPRINTs r+4, c, "are generated. You can then build a report at any time by ", dimattr
QPRINTs r+5, c, "selecting the file. Or hit the [Delete] key to permanently ", dimattr
QPRINTs r+6, c, "discard the file. ", dimattr
END SUB
SUB Prompt (special) STATIC
QPRINTs ConsRows, 1, SPACE$(ConsCols - 9), scdattr
QPRINTs ConsRows, ConsCols - 10, " SBS v4.9.3", scoattr
IF MenuOpt$ = "M" THEN QPRINTs ConsRows, 59, "Manual ", scdattr
IF MenuOpt$ = "S" THEN QPRINTs ConsRows, 59, "Schedule", scdattr
IF MenuOpt$ = "E" THEN QPRINTs ConsRows, 59, "Series ", scdattr
IF MenuOpt$ = "T" THEN QPRINTs ConsRows, 59, "Two-Team", scdattr
IF special > 0 THEN 'closing
xS$ = " New Box Card Results Stats Doc Quit "
QPRINTs ConsRows, 1, xS$, scdattr
a = ConsRows: b = 2: c = 1: d = prmfor: e = prmbac
GOSUB PromptSub1
b = 7
GOSUB PromptSub1
b = 12
GOSUB PromptSub1
b = 18
GOSUB PromptSub1
b = 27
GOSUB PromptSub1
b = 34
GOSUB PromptSub1
b = 39
GOSUB PromptSub1
ELSEIF amgr(1) AND amgr(2) THEN
QPRINTs ConsRows, 1, " ptions ox ard esults ", scdattr
QPRINTs ConsRows, 2, "O", prmattr
QPRINTs ConsRows, 11, "B", prmattr
QPRINTs ConsRows, 16, "C", prmattr
QPRINTs ConsRows, 22, "R", prmattr
IF DelFac = 0 THEN
QPRINTs ConsRows, 31, " oggle Display uit ", scdattr
QPRINTs ConsRows, 31, "T", prmattr
QPRINTs ConsRows, 47, "Q", prmattr
ELSE
QPRINTs ConsRows, 31, " uit ", scdattr
QPRINTs ConsRows, 31, "Q", prmattr
END IF
ELSE
'min len = 37 max len = 54
xS$ = EnterPtr$ + " Options Box Card Doc "
IF NewUI = TRUE THEN
IF NOT amgr(1) THEN xS$ = xS$ + "Visitor "
IF NOT amgr(2) THEN xS$ = xS$ + "Home "
ELSE
IF NOT amgr(1) THEN xS$ = xS$ + "S=Visi "
IF NOT amgr(2) THEN xS$ = xS$ + "5=Home "
END IF
xS$ = xS$ + "Quit "
LLeng = LEN(xS$)
QPRINTs ConsRows, 1, xS$, scdattr
a = ConsRows: b = 2: c = 3: d = prmfor: e = prmbac
GOSUB PromptSub1
b = 7: c = 1
GOSUB PromptSub1 'Options
b = 16
GOSUB PromptSub1 'Box
b = 21
GOSUB PromptSub1 'Card
b = 27
GOSUB PromptSub1 'Doc
b = 32
GOSUB PromptSub1
'catch the Quit
IF LLeng > 36 THEN
b = LLeng - 4
GOSUB PromptSub1
END IF
'catch Home if both Visi and Home
IF LEN(xS$) = 51 THEN 'Visitor Home Quit '
b = 41
GOSUB PromptSub1
END IF
IF LEN(xS$) = 52 THEN 'S=Visi 5=Home Quit '
b = 40
GOSUB PromptSub1
END IF
END IF
LOCATE 1, 1
CURSOR OFF
EXIT SUB
PromptSub1:
attr = (e * 16) + d
CALL ChangeAttribute(a, b, c, attr)
RETURN
END SUB
SUB PutPitHitStatsInBO
FOR tm = 1 TO 2
j = 0
DO
IF j > 8 THEN j = 9: EXIT DO
INCR j
LOOP UNTIL DataPos(j, tm) = 1
CALL MovePitHitStats (j, tm) 'puts hitting stats in slot j
NEXT
END SUB
SUB PutScreen (ScrSave$, row1, col1, row2, col2)
IF ConsRows = 25 THEN BeginBuffer
i = 1
FOR r = row1 TO row2
FOR c = col1 TO col2
b$ = MID$(ScrSave$, i, 1)
attr = ASC(MID$(ScrSave$, i+1, 1))
QPRINTs r, c, b$, attr
i = i + 2
NEXT
NEXT
IF ConsRows = 25 THEN EndBuffer
END SUB
SUB QPRINTs (row AS LONG, col AS LONG, xS$, attr AS LONG) STATIC
IF ConsRows = 25 AND ConsCols = 80 AND Gfx = FALSE THEN
QPRINT row, col, xS$, attr
ELSE
L = LEN(xS$)
LOCATE row, col
forg = attr MOD 16
bacg = attr \ 16
COLOR forg, bacg
IF (col + L) < (ConsCols + 2) THEN
PRINT xS$;
' IF row < ConsRows THEN STDOUT xS$;
' IF row = ConsRows THEN PRINT xS$;
END IF
END IF
END SUB
SUB QSortRand (myfile$, fp, Reclen, start, leng, ASCorDES$)
OPEN myfile$ FOR BINARY AS fp
RecCount = LOF(fp) \ Reclen
CALL QSRand(1, RecCount, fp, Reclen, start, leng)
CLOSE fp
END SUB
SUB QSRand (L, R, fp, Reclen, start, leng)
' Does not support "Descending" order!
i = L: j = R
s = (L + R) \ 2
IF s < 1 THEN BEEP: PRINT " Sort Error "; : GOTO QSRandEscape
xsortfield$ = FindRA$(s, fp, Reclen, start, leng)
DO
DO WHILE FindRA$(i, fp, Reclen, start, leng) < xsortfield$
INCR i
LOOP
DO WHILE xsortfield$ < FindRA$(j, fp, Reclen, start, leng)
DECR j
LOOP
IF i <= j THEN
SEEK fp, (i - 1) * Reclen + 1
GET$ fp, Reclen, y$
SEEK fp, (j - 1) * Reclen + 1
GET$ fp, Reclen, z$
SEEK fp, (j - 1) * Reclen + 1
PUT$ fp, y$
SEEK fp, (i - 1) * Reclen + 1
PUT$ fp, z$
INCR i
DECR j
END IF
LOOP UNTIL i > j
IF L < j THEN CALL QSRand(L, j, fp, Reclen, start, leng)
IF L < R THEN CALL QSRand(i, R, fp, Reclen, start, leng)
QSRandEscape:
END SUB
SUB ReadFromScreen (row, col, leng, field$, edit$, Valid$) STATIC
field$ = ""
L = col + leng - 1
FOR c = col TO L
field$ = field$ + CHR$(SCREEN(row, c))
NEXT c
Valid$ = "Y"
x1$ = MID$(edit$, 1, 1)
x2$ = MID$(edit$, 2, 1)
IF x2$ = "R" THEN 'Required
IF field$ = SPACE$(leng) THEN Valid$ = "N"
END IF
IF x1$ = "N" THEN
IF x2$ = "E" OR x2$ = " " THEN
IF NOT NUMERIC(field$, TRUE, FALSE) THEN Valid$ = "N"
ELSE
IF NOT NUMERIC(field$, FALSE, FALSE) THEN Valid$ = "N"
END IF
END IF
END SUB
SUB ReadSCHSlot
SubRecOff = 10 + (SchSlotPtr - 1) * SubRecLen
CmdVFil$ = UCASE$(RTRIM$(MID$(SchBuffer$, SubRecOff + VisiOffset, 8)))
CmdHFil$ = UCASE$(RTRIM$(MID$(SchBuffer$, SubRecOff + HomeOffset, 8)))
CmdSlotGames = 1
xS$ = MID$(SchBuffer$, SubRecOff + OptiOffset, 12)
IF xS$ <> SPACE$(12) THEN 'just parses the option list
CALL ParseCommand (xS$, nargs)
CALL SetSwitches (nargs)
END IF
'Scan Rest Of SCHRec
IF SchSlotPtr = SchGamesPerRecord THEN 'formerly 7
LastGameThisDate = TRUE
ELSE
LastGameThisDate = TRUE
FOR i = SchSlotPtr + 1 TO SchGamesPerRecord 'formerly 7
SubRecOff = 10 + (i - 1) * SubRecLen
xS$ = MID$(SchBuffer$, SubRecOff + VisiOffset, 8)
yS$ = MID$(SchBuffer$, SubRecOff + HomeOffset, 8)
IF xS$ > "!" AND yS$ > "!" THEN
LastGameThisDate = FALSE
EXIT FOR
END IF
NEXT
END IF
'If looking for Specific League/Team/Date, is it here?
FilterOK = TRUE
'One League only? 'File name must be YYLTTTTT.DAT or YYYYLTTT.DAT
IF LEN(CmdFavLeague$) THEN
IF LEN(CmdVFil$) AND LEN(CmdHFil$) THEN
IF NUMERIC(MID$(CmdVFil$, 1, 4), FALSE, FALSE) THEN
xS$ = MID$(CmdVFil$, 5, 1)
ELSE
xS$ = MID$(CmdVFil$, 3, 1)
END IF
IF NUMERIC(MID$(CmdHFil$, 1, 4), FALSE, FALSE) THEN
yS$ = MID$(CmdHFil$, 5, 1)
ELSE
yS$ = MID$(CmdHFil$, 3, 1)
END IF
xS$ = UCASE$(xS$)
yS$ = UCASE$(yS$)
IF CmdFavLeague$ <> xS$ AND CmdFavLeague$ <> yS$ THEN FilterOK = FALSE
END IF
END IF
'One Team only?
IF LEN(CmdFavTeam$) THEN
IF LEN(CmdVFil$) AND LEN(CmdHFil$) THEN
IF CmdFavTeam$ <> CmdVFil$ AND CmdFavTeam$ <> CmdHFil$ THEN FilterOK = FALSE
END IF
END IF
'If Date Range is active, is this date OK?
IF LEN(CmdDateL$) AND LEN(CmdDateH$) THEN
IF SCHDate$ < CmdDateL$ OR SCHDate$ > CmdDateH$ THEN FilterOK = FALSE
END IF
END SUB
SUB ResetBatter
ResetHitter = TRUE
DECR ibp(it)
DECR mab(ref, it)
IF UCASE$(DataHand(ip, id)) = "L" THEN
DECR mabLHP(ref, it)
ELSE
DECR mabRHP(ref, it)
END IF
END SUB
SUB RestFrSnapShot
FOR it = 1 TO 2
REDIM Positions (10)
FOR i = 1 TO 9
Positions(DataPos(i,it)) = 1
NEXT
FOR i = 2 TO 9
IF Positions(i) = 0 THEN
x$ = "RESTFRSNAP1 error: Defense position " + STR$(i) + " is empty "
CALL ErrorBox (x$)
END IF
NEXT
NEXT
FOR it = 1 TO 2
L = 1
DO UNTIL L > MAXPLAYERS
j = RefOrgSave(L, it).RefNo
'Search For Reference #j
FoundSw = FALSE
k = 1
DO UNTIL k > MAXPLAYERS
IF DataRef(k, it) = j THEN FoundSw = TRUE: EXIT DO
INCR k
IF k = 10 THEN k = LastPiAd(it) + 1
LOOP
IF FoundSw THEN
IF k <> L THEN
CALL Switch(L, k, it)
END IF
END IF
DataPos(L, it) = RefOrgSave(L, it).RefPos
INCR L
IF L = 10 THEN L = LastPiAd(it) + 1
LOOP
NEXT
FOR it = 1 TO 2
REDIM Positions (10)
FOR i = 1 TO 9
Positions(DataPos(i,it)) = 1
NEXT
FOR i = 2 TO 9
IF Positions(i) = 0 THEN
x$ = "RESTFRSNAP2 error: Defense position " + STR$(i) + " is empty "
CALL ErrorBox (x$)
END IF
NEXT
NEXT
END SUB
SUB RotationMethIO (Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
CALL Drawfrm(6+rowO, 16+colO, 15+rowO, 64+colO, defattr, "Default Pitching Rotation Method", "ESC:Continue F3:Abort", 1, 0, 2)
DATA 8,25,"Number In Rotation [2-5]: ",08,58, 1,"X "
DATA 10,25,"[S]equential or [R]andom Order?: ",10,58, 1,"X "
DATA 12,25,"Use Spot Starters?: ",12,58, 1,"X "
Flds = 3
c = 1
FOR i = 1 TO Flds
Flitrow(i) = VAL(READ$(c)) + rowO
Flitcol(i) = VAL(READ$(c+1)) + colO
Flit$(i) = READ$(c+2)
Frow(i) = VAL(READ$(c+3)) + rowO
Fcol(i) = VAL(READ$(c+4)) + colO
Flen(i) = VAL(READ$(c+5))
Fed$(i) = READ$(c+6)
c = c + 7
NEXT
REDIM FContents$(13)
FContents$(1) = "5"
FContents$(2) = "S"
FContents$(3) = "Y"
CursorPtr = 1
DO
RotationMethLoop:
CALL ScreenIO(Keyed, KeyF3, 0, KeyEsc, Flds, CursorPtr, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
IF Keyed = KeyF3 THEN
CmdSP$ = nulls$
EXIT SUB
END IF
'Edit Field Contents
Error1$ = "N"
IF INSTR("12345", FContents$(1)) = 0 THEN
Error1$ = "Y"
CursorPtr = 1
GOTO RotationMethLoop
END IF
IF INSTR("RS12345", FContents$(2)) = 0 THEN
Error1$ = "Y"
CursorPtr = 2
GOTO RotationMethLoop
END IF
IF INSTR("YN", FContents$(3)) = 0 THEN
Error1$ = "Y"
CursorPtr = 3
END IF
LOOP WHILE Error1$ = "Y"
CmdSpot$ = FContents$(3)
CmdSP$ = FContents$(2) + FContents$(1)
END SUB
SUB SameTeamsSetup (kc, Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
CALL DrawFrm(18+rowO, 22+colO, 22+rowO, 61+colO, defattr, nulls$, "ESC:Continue F3:Cancel", 0, 0, 2)
FContents$(1) = "N"
Flds = 1
DATA 20,24,"Play again with same teams? [y/N] ",20,58,01,"X "
c = 1
FOR i = 1 TO Flds
Flitrow(i) = VAL(READ$(c)) + rowO
Flitcol(i) = VAL(READ$(c+1)) + colO
Flit$(i) = READ$(c+2)
Frow(i) = VAL(READ$(c+3)) + rowO
Fcol(i) = VAL(READ$(c+4)) + colO
Flen(i) = VAL(READ$(c+5))
Fed$(i) = READ$(c+6)
c = c + 7
NEXT
CursorPtr = 1
DO
s = defattr
defattr = dimattr
CALL ScreenIO(Keyed, KeyF3, 0, KeyEsc, Flds, CursorPtr, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
defattr = s
ErrorSw$ = "N"
'Cancel
IF Keyed = KeyF3 THEN EXIT DO
IF FContents$(1) <> "Y" AND FContents$(1) <> "N" THEN ErrorSw$ = "Y"
LOOP WHILE ErrorSw$ = "Y"
kc = Keyed
END SUB
SUB SCHDateTeamIO (Keyed, Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
DATA 08,20,"Single League [A/N] :",08,43, 1,"X "
DATA 10,20,"Single Team [filename]:",10,43, 8,"X "
DATA 12,20,"Date Range [MM/DD/YY]:",12,43, 8,"X "
DATA 12,51,"-", 12,52, 8,"X "
Flds = 4
c = 1
FOR i = 1 TO Flds
Flitrow(i) = VAL(READ$(c)) + rowO
Flitcol(i) = VAL(READ$(c+1)) + colO
Flit$(i) = READ$(c+2)
Frow(i) = VAL(READ$(c+3)) + rowO
Fcol(i) = VAL(READ$(c+4)) + colO
Flen(i) = VAL(READ$(c+5))
Fed$(i) = READ$(c+6)
c = c + 7
NEXT
REDIM FContents$(13)
CursorPtr = 1
CALL Drawfrm(6+rowO, 18+colO, 15+rowO, 61+colO, defattr, "Schedule Filter", "ESC:Continue F3:Abort", 1, 0, 2)
QPRINTs 14+rowO, 27+colO,"[Leave Blank for All Games]", dimattr
DO
CALL ScreenIO(Keyed, KeyF3, 0, KeyEsc, Flds, CursorPtr, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
'Trap F3
IF Keyed = KeyF3 THEN EXIT SUB
'Edit Field Contents
Error1$ = "N"
CmdFavLeague$ = UCASE$(RTRIM$(FContents$(1)))
CmdFavTeam$ = UCASE$(RTRIM$(FContents$(2)))
CmdDateL$ = RTRIM$(FContents$(3))
CmdDateH$ = RTRIM$(FContents$(4))
IF LEN(CmdDateH$) THEN
IF NOT ValidMMDDYY(CmdDateH$) THEN
MyBeep
LOCATE 13+rowO, 23+colO: PRINT "** Date must be in MM/DD/YY form **";
SLEEP 1000
CursorPtr = 4
Error1$ = "Y"
END IF
END IF
IF LEN(CmdDateL$) THEN
IF NOT ValidMMDDYY(CmdDateL$) THEN
MyBeep
LOCATE 13+rowO, 20+colO: PRINT "** Date must be in MM/DD/YY form **";
SLEEP 1000
CursorPtr = 3
Error1$ = "Y"
END IF
END IF
IF LEN(CmdFavTeam$) THEN
k = CountGamesInSCH (nulls$, CmdFavTeam$, nulls$, nulls$, SubRecLen, VisiOffset, HomeOffset, OptiOffset)
IF k = 0 THEN
MyBeep
LOCATE 13+rowO, 20+colO: PRINT "** Team does not appear in .SCH! **";
SLEEP 1000
CursorPtr = 2
Error1$ = "Y"
END IF
END IF
LOOP WHILE Error1$ = "Y"
IF LEN(CmdDateL$) > 0 AND LEN(CmdDateH$) = 0 THEN CmdDateH$ = CmdDateL$
END SUB
SUB ScreenIO (Keyed, EscKey, CustomEscKey, AcceptKey, Flds, CursorPtr, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
' Print screen literals and field contents
' Flen's which are NEGATIVE are to be dimmed and skipped
FOR i = 1 TO Flds
IF Flitrow(i) > 0 AND Flitrow(i) <= ConsRows AND Flitcol(i) > 0 AND Flitcol(i) <= ConsCols THEN
IF Flen(i) < 0 THEN attr = dimattr ELSE attr = defattr
QPRINTs Flitrow(i), Flitcol(i), Flit$(i), attr
END IF
IF Frow(i) > 0 AND Frow(i) <= ConsRows AND Fcol(i) > 0 AND Fcol(i) <= ConsCols THEN
IF Flen(i) < 0 THEN attr = dimattr ELSE attr = revattr
'Print field contents or blanks
IF LEN(FContents$(i)) = 0 THEN
QPRINTs Frow(i), Fcol(i), SPACE$(ABS(Flen(i))), attr
ELSE
QPRINTs Frow(i), Fcol(i), PADRIGHT$(FContents$(i), ABS(Flen(i))), attr
END IF
END IF
NEXT i
InsToggle = 0 'overwrite mode
CsrSize = 100
' Find 1st Input Field (not necessarily Fld = 1)
' Flen's which are NEGATIVE are to be dimmed and skipped
i = 1
DO WHILE Frow(i) = 0 OR Fcol(i) = 0 OR Flen(i) < 0
INCR i
IF i > Flds THEN i = 1: EXIT DO
LOOP
FirstInputField = i
Fldptr = CursorPtr
LOCATE Frow(Fldptr), Fcol(Fldptr)
COLOR revfor, revbac
' Loop until Escape-Key. Data is manipulated on-screen and returned in the
' FContents$() array
DO
ResetPtr:
GOSUB ScrIOSpecialCases
'ResetPtr:
row = Frow(Fldptr)
col = Fcol(Fldptr)
leng = ABS(Flen(Fldptr)) 'Just in case I screwed up
edit$ = Fed$(Fldptr)
default$ = FContents$(Fldptr)
'Get Input from keyboard or mouse
FContents$(FldPtr) = MYINPUT$(TRUE, EscKey, CustomEscKey, AcceptKey, kc, revfor, revbac, row, col, leng, edit$, 0, 999999, default$, msx, msy)
'If returning from mouse input (kc=-99), we might have clicked anywhere
IF msy > 0 AND msx > 0 THEN
'mouse click somewhere
CALL FlashField (msy, msx, 1, 2, 100, 0)
IF CHR$(SCREEN(msy, msx)) = CloseButton$ THEN 'ESC button (but accept input)
kc = AcceptKey
'L = PlayWav("4540.wav")
EXIT DO
END IF
IF CHR$(SCREEN(msy, msx)) = AbortButton$ THEN 'Abort button
kc = EscKey
EXIT DO
END IF
'Did we click in an input field?
FOR i = 1 TO Flds
IF Frow(i) > 0 AND Fcol(i) > 0 AND Flen(i) > 0 THEN
IF msx >= Fcol(i) AND msx < Fcol(i) + Flen(i) AND msy = Frow(i) THEN
Fldptr = i
GOTO ResetPtr
END IF
END IF
NEXT
'Did we click inside one of the "literal" areas?
FOR i = 1 TO Flds
IF Flitrow(i) > 0 AND Flitcol(i) > 0 AND Flen(i) > 0 AND _
Frow(i) > 0 AND Fcol(i) > 0 THEN
'Within Literal-Area?
IF (msx >= Flitcol(i) AND msx < Flitcol(i) + LEN(FLit$(i)) AND _
msy = Flitrow(i)) THEN
Fldptr = i
a$ = UCASE$(CHR$(SCREEN(msy, msx)))
IF a$ >= "0" AND a$ <= "Z" THEN FContents$(FldPtr) = a$
GOTO ResetPtr
END IF
END IF
NEXT
'"TakeFromAnywhere"?
IF TakeFromAnywhere = 1 THEN 'DefSwitch Special case
a$ = UCASE$(CHR$(SCREEN(msy, msx)))
IF a$ >= "0" AND a$ <= "Z" THEN FContents$(FldPtr) = a$
LOCATE row, col
PRINT a$;
END IF
IF TakeFromAnywhere = 2 THEN 'StatRecordIO Special case for F4
IF msy = 8+rowO AND msx > 39+colO AND msx < 44+colO THEN
kc = CustomEscKey
END IF
END IF
IF CHR$(SCREEN(msy, msx)) = "+" THEN 'Custom ESC
kc = CustomEscKey
END IF
END IF
' Shift-tab or Up-arrow or Left-arrow
IF kc = -15 OR kc = -72 OR kc = -75 THEN
DO
DECR Fldptr
LOOP UNTIL (Frow(Fldptr) <> 0 AND Fcol(Fldptr) <> 0 AND Flen(Fldptr) > 0) OR Fldptr < 1
IF Fldptr < 1 THEN Fldptr = FirstInputField
LOCATE Frow(Fldptr), Fcol(Fldptr)
' C/R, R-Tab, Down-arrow, Right-arrow
ELSE
DO
INCR Fldptr
IF Fldptr > Flds THEN Fldptr = FirstInputField: EXIT DO
LOOP UNTIL Frow(Fldptr) <> 0 AND Fcol(Fldptr) <> 0 AND Flen(Fldptr) > 0
LOCATE Frow(Fldptr), Fcol(Fldptr)
'L = PlayWav("37979.wav")
END IF
LOOP UNTIL kc = EscKey OR kc = AcceptKey OR kc = CustomEscKey
Keyed = kc
COLOR deffor, defbac
LOCATE 1, 1
CURSOR OFF
EXIT SUB
ScrIOSpecialCases:
'For Ground Rule Screen
IF LEFT$(Flit$(1), 9) = "Automatic" THEN
FOR i = 2 TO 3
IF FContents$(i) = "Y" THEN
xS$ = "Computer will manage '" + Names(i - 1)
ELSE
xS$ = "Player will manage '" + Names(i - 1)
END IF
QPRINTs i+2+rowO, 34+colO, xS$, dimattr
NEXT
END IF
RETURN
END SUB
SUB ScoreBrd (DoFrame, DoAllInns) STATIC
' DoFrame -
' DoAllInns -
' Nothing done with announcer in this routine
'DIM ss AS STRING * 2
ss$ = " "
CURSOR OFF
IF DoFrame = FALSE THEN
GOTO ScoreBoardNumbers
END IF
'Scoreboard box
xS$ = STRING$(39, 205)
QPRINTs 1, 1, CHR$(213) + xS$, scoattr
QPRINTs 2, 1, CHR$(179) + " 1 2 3 4 5 6 7 8 9 10 R H E", scoattr
QPRINTs 3, 1, CHR$(179), scoattr
QPRINTs 4, 1, CHR$(179), scoattr
QPRINTs 5, 1, CHR$(212)+CHR$(205)+CHR$(181)+CHR$(32), scoattr
QPRINTs 5, 5, "Out:", prmattr
x$ = CHR$(32)+CHR$(198)+LEFT$(xS$, 28)
QPRINTs 5, 11, x$, scoattr
'Draw blank announcer's box
xS$ = STRING$(ConsCols - 42, 205)
QPRINTs 1, 41, CHR$(209), scoattr
x$ = xS$ + CHR$(184)
QPRINTs 1, 42, x$, scoattr
QPRINTs 2, 41, CHR$(179), scoattr
QPRINTs 2, ConsCols, CHR$(179), scoattr
QPRINTs 3, 41, CHR$(179), scoattr
QPRINTs 3, ConsCols, CHR$(179), scoattr
QPRINTs 4, 41, CHR$(179), scoattr
QPRINTs 4, ConsCols, CHR$(179), scoattr
QPRINTs 5, 41, CHR$(207), scoattr
x$ = xS$ + CHR$(190)
QPRINTs 5, 42, x$, scoattr
xS$ = SPACE$(ConsCols - 42)
QPRINTs 2, 42, xS$, scdattr
QPRINTs 3, 42, xS$, scdattr
QPRINTs 4, 42, xS$, scdattr
ScoreBoardNumbers:
'Handle Home Runs
IF IGone THEN
'Is it an "instant win" situation?
'If it is we need to show the numbers, because program will not
'get another chance to update the scoreboard. Any other home run
'will not update the scoreboard here.
IF inn >= RegInns AND it = 2 THEN
IF itruns(2) > itruns(1) THEN GOTO ScoreBoardPost
END IF
'If not, do not show the numbers
GOTO ScoreBoardX
END IF
ScoreBoardPost:
'Put up the numbers
'Erase scoreboard numbers if necessary
IF DoAllInns OR (innct = 1 AND it = 1) THEN
xS$ = STRING$(20, 32)
QPRINTs 3, 12, xS$, scdattr
QPRINTs 4, 12, xS$, scdattr
END IF
IF it = 1 THEN
attr1 = scoattr
attr2 = scdattr
ELSE
attr1 = scdattr
attr2 = scoattr
END IF
QPRINTs 3, 2, LEFT$(Names(1), 10), attr1
QPRINTs 4, 2, LEFT$(Names(2), 10), attr2
'Visitor
FOR i = 1 TO 10
IF it = 1 AND i = innct THEN attr = revattr ELSE attr = scdattr
IF i <= innct THEN
IF i = innct AND it = 1 THEN
IF iScoreBd(1, i) = 0 THEN
ss$ = CHR$(219)+CHR$(32)
ELSE
IF iScoreBd(1, i) < 10 THEN
ss$ = CHR$(219) + LTRIM$(STR$(iScoreBd(1, i)))
ELSE
ss$ = LTRIM$(STR$(iScoreBd(1, i)))
END IF
END IF
ELSE
ss$ = PADLEFT$(LTRIM$(STR$(iScoreBd(1, i))), 2)
END IF
IF DoAllInns OR i = innct THEN
QPRINTs 3, (10 + i*2), ss$, attr
END IF
END IF
NEXT
'Home
FOR i = 1 TO 10
IF it = 2 AND i = innct THEN attr = revattr ELSE attr = scdattr
IF i <= innct THEN
IF i = innct THEN
IF it = 2 THEN
IF iScoreBd(2, i) = 0 THEN
ss$ = CHR$(219) + CHR$(32)
ELSEIF iScoreBd(2, i) < 10 THEN
ss$ = CHR$(219) + LTRIM$(STR$(iScoreBd(2, i)))
ELSE
ss$ = LTRIM$(STR$(iScoreBd(2, i)))
END IF
QPRINTs 4, (10 + i*2), ss$, attr
END IF
ELSE
IF (i = innct - 1) OR DoAllInns THEN
ss$ = PADLEFT$(LTRIM$(STR$(iScoreBd(2, i))), 2)
QPRINTs 4, (10 + i*2), ss$, attr
END IF
END IF
END IF
NEXT
ScoreBoardTots:
a$ = SPACE$(9)
MID$(a$, 1, 3) = LFORMAT$(itruns(1),"###")
MID$(a$, 4, 3) = LFORMAT$(ithits(1),"###")
MID$(a$, 7, 3) = LFORMAT$(iterrs(1),"###")
QPRINTs 3, 32, a$, scdattr
a$ = SPACE$(9)
MID$(a$, 1, 3) = LFORMAT$(itruns(2),"###")
MID$(a$, 4, 3) = LFORMAT$(ithits(2),"###")
MID$(a$, 7, 3) = LFORMAT$(iterrs(2),"###")
QPRINTs 4, 32, a$, scdattr
ScoreBoardX:
QPRINTs 5, 9, STR$(iout), prmattr
END SUB
SUB SearchPbyP (ARRAYx() AS PbyP_OVL, beg, leng, rangelo, rangehi, Find$, FoundAt, mini) STATIC
FoundAt = 0 'no matching element yet
mini = rangelo
maxi = rangehi
DO
Try = (mini + maxi) \ 2 'start testing in middle
xS$ = ARRAYx(Try).PbyP_Rec
xS$ = MID$(xS$, beg, leng)
IF xS$ = Find$ THEN 'found it!
FoundAt = Try 'return matching element
EXIT DO 'all done
END IF
IF xS$ > Find$ THEN 'too high, cut in half
maxi = Try - 1
ELSE
mini = Try + 1 'too low, cut other way
END IF
LOOP WHILE maxi >= mini
END SUB
SUB SearchStandingsTable (Lg$, Dv$, Team$, ndx)
ON ERROR GOTO ERRORTRAP
i = 1
DO
IF i > WLx THEN
INCR WLx
WLRec(WLx).WLTeam = Team$
WLRec(WLx).WLWins = 0
WLRec(WLx).WLLoss = 0
WLRec(WLx).WLLeague = Lg$
WLRec(WLx).WLDiv = Dv$
WLRec(WLx).WLPct = "0000"
ndx = WLx
EXIT DO
END IF
IF WLRec(i).WLLeague = Lg$ AND RTRIM$(WLRec(i).WLTeam) = RTRIM$(Team$) THEN
ndx = i
EXIT DO
END IF
INCR i
LOOP
EXIT SUB
ErrorTrap:
LOCATE 10, 30
PRINT "ERROR: SearchSta"; ERRCLEAR
x$ = WAITKEY$
END SUB
SUB SelectPhotoIO(List1() AS List1Type, choices, Selection$)
Shadow = 0
ESCPoint = 2
zS$ = ""
yS$ = "Where ya wanna go today? [PgUp/PgDown]"
row1 = 2 + rowO
col1 = 3 + colO
row2 = 21 + rowO
col2 = 78 + colO
QPush
'CALL GetScreen(Scr3$, row1, col1, row2, col2)
CALL Drawfrm (row1, col1, row2, col2, defattr, zS$, yS$, Shadow, 0, ESCPoint)
r = 9 + rowO
columns = 1
itemsincol = 18
x1$ = CHR$(193): x2$ = CHR$(194)
QPRINTs r, col2, x1$, defattr
QPRINTs r + 1, col2, UpPtr$, defattr
QPRINTs r + 2, col2, DnPtr$, defattr
QPRINTs r + 3, col2, x2$, defattr
CALL PickFromList(List1(), choices, itemsincol, columns, 73, row1,col1,row2,col2, dimattr, revattr, Pick, RetKey, nulls$, mous, ms$)
IF Pick > 0 AND Pick <= choices THEN
rec$ = List1(Pick).ListItem
Selection$ = RTRIM$(MID$(rec$, 1, 20))
ELSE
Selection$ = ""
END IF
'CALL PutScreen(Scr3$, row1, col1, row2, col2)
QPop
END SUB
SUB SetColors (ColorScheme)
IF ColorScheme = 1 THEN
fldfor = 14: fldbac = 2 'yellow on green
runfor = 0: runbac = 2 'black on green
END IF
IF ColorScheme = 2 THEN
fldfor = 15: fldbac = 2 'bright on green
runfor = 0: runbac = 2 'black on green
END IF
IF ColorScheme = 3 THEN
fldfor = 0: fldbac = 2 'black on green
runfor = 0: runbac = 2 'black on green
END IF
IF ColorScheme = 4 THEN
fldfor = 14: fldbac = 3 'yellow on sky-blue
runfor = 0: runbac = 3 'black on sky-blue
END IF
IF ColorScheme = 5 THEN
fldfor = 15: fldbac = 3 'bright on sky-blue
runfor = 0: runbac = 3 'black on sky-blue
END IF
IF ColorScheme = 6 THEN
fldfor = 0: fldbac = 3 'black on sky-blue
runfor = 0: runbac = 3 'black on sky-blue
END IF
fldattr = CALCATTR(fldfor, fldbac)
'labattr only used for smaller screens where stats are displayed
'in the middle of the screen
labfor = 0
labbac = fldbac
labattr = CALCATTR(labfor, labbac)
END SUB
SUB SetDH
IF CmdDH$ = "Y" OR CmdDH$ = "A" THEN dh = -1
IF CmdDH$ = "N" THEN dh = 0
IF CmdDH$ = "H" THEN
IF League(2) = "A" THEN
IF Century(2) = "19" AND MID$(Names(2), 1, 2) > "73" THEN
dh = -1
ELSEIF Century(2) = "20" THEN
dh = -1
ELSE
dh = 0
END IF
ELSE
dh = 0
END IF
'DAT Override switch: *DH=Y
IF DHDATOvr(2) = -1 THEN dh = -1
'DAT Override switch: *DH=N
IF DHDATOvr(2) = 1 THEN dh = 0
END IF
IF CmdDH$ = "E" THEN
IF DHinDAT(1) OR DHinDAT(2) THEN dh = -1 ELSE dh = 0
END IF
IF dh THEN
CALL SwitchToDH (1)
CALL SwitchToDH (2)
ELSE
'Also puts pitcher's hitting stats in correct slot
CALL SwitchToNoDH (1)
CALL SwitchToNoDH (2)
END IF
END SUB
SUB SetHomeTorF (t$, DspSw)
' This always works with the window on the right side - the Home side
IF t$ = "T" THEN TorF = TRUE
IF t$ = "F" THEN TorF = FALSE
IF DspSw THEN
IF TorF = FALSE THEN
QPRINTs 11 + RowO + HomePtr, 47+ColO, " ", defattr
QPRINTs 11 + RowO + HomePtr, 65+ColO, "x", defattr
ELSE
QPRINTs 11 + RowO + HomePtr, 47+ColO, "x", defattr
QPRINTs 11 + RowO + HomePtr, 65+ColO, " ", defattr
END IF
ELSE
FOR i = 1 TO 3
QPRINTs 11 + RowO + HomePtr, 47+ColO, "*", defattr
QPRINTs 11 + RowO + HomePtr, 65+ColO, "*", defattr
SLEEP 40
QPRINTs 11 + RowO + HomePtr, 47+ColO, " ", defattr
QPRINTs 11 + RowO + HomePtr, 65+ColO, " ", defattr
SLEEP 40
NEXT
END IF
IF it = 2 THEN
SELECT CASE HomePtr
CASE 1
HomeReady = TorF
CASE 2
PH = TorF
CASE 3
PRun = TorF
CASE 4
ViewHome = TorF
CASE 5
ViewVisi = TorF
CASE 6
IF WarmUpRule THEN BULLO = TorF
CASE 8
Steal = TorF
CASE 9
Bunt = TorF
CASE 10
HitAndRun = TorF
CASE ELSE
END SELECT
END IF
IF it = 1 THEN
SELECT CASE HomePtr
CASE 1
HomeReady = TorF
CASE 2
BullD = TorF
CASE 3
Subx = TorF
CASE 4
SwPos = TorF
CASE 5
ViewHome = TorF
CASE 6
ViewVisi = TorF
CASE 8
IWalk = TorF
CASE 9
Tight = TorF
CASE 10
POut = TorF
CASE 11
PAround = TorF
CASE ELSE
END SELECT
END IF
END SUB
SUB SetVisiTorF (t$, DspSw)
'This always works with the window on the left side - the Visitor side
IF t$ = "T" THEN TorF = TRUE
IF t$ = "F" THEN TorF = FALSE
IF DspSw THEN
IF TorF = FALSE THEN
LOCATE 11+RowO + VisiPtr, 16+ColO
PRINT " ";
LOCATE 11+RowO + VisiPtr, 34+ColO
PRINT "x";
ELSE
LOCATE 11+RowO + VisiPtr, 16+ColO
PRINT "x";
LOCATE 11+RowO + VisiPtr, 34+ColO
PRINT " ";
END IF
ELSE
FOR i = 1 TO 3
LOCATE 11+RowO + VisiPtr, 16+ColO
PRINT "*";
LOCATE 11+RowO + VisiPtr, 34+ColO
PRINT "*";
SLEEP 40
LOCATE 11+RowO + VisiPtr, 16+ColO
PRINT " ";
LOCATE 11+RowO + VisiPtr, 34+ColO
PRINT " ";
SLEEP 40
NEXT
END IF
IF it = 1 THEN
SELECT CASE VisiPtr
CASE 1
VisiReady = TorF
CASE 2
PH = TorF
CASE 3
PRun = TorF
CASE 4
ViewVisi = TorF
CASE 5
ViewHome = TorF
CASE 6
IF WarmUpRule THEN BULLO = TorF
CASE 8
Steal = TorF
CASE 9
Bunt = TorF
CASE 10
HitAndRun = TorF
CASE ELSE
END SELECT
END IF
IF it = 2 THEN
SELECT CASE VisiPtr
CASE 1
VisiReady = TorF
CASE 2
BullD = TorF
CASE 3
Subx = TorF
CASE 4
SwPos = TorF
CASE 5
ViewVisi = TorF
CASE 6
ViewHome = TorF
CASE 8
IWalk = TorF
CASE 9
Tight = TorF
CASE 10
POut = TorF
CASE 11
PAround = TorF
CASE ELSE
END SELECT
END IF
END SUB
SUB SetPlatoon
FOR it = 1 TO 2
id = 3 - it
zS$ = UCASE$(DataHand(iyp(1, id), id)) 'handedness of opposing pitcher
FOR i = 1 TO 9
IF DataPos(i, it) <> 1 THEN
IF DataPlat(i, it) <> " " AND DataHand(i, it) = zS$ THEN
yS$ = DataPlat(i, it)
FOR j = LastPiAd(it) + 1 TO MAXPLAYERS
IF yS$ = DataPlat(j, it) AND DataHand(j, it) <> zS$ THEN
k = DataPos(i, it)
'Can the sub guy (j) play position (k)?
OK = FALSE
'Are we playing "strict" or "loose"?
IF DataPosi(j, it, 1) > 0 THEN 'Strict
IF FoundPosition (k, j, it) THEN
OK = TRUE
END IF
ELSE
subdefPos = DataPos(j, it)
SELECT CASE k
CASE 2
IF subdefPos = 2 THEN OK = TRUE
CASE 3
IF subdefPos = 3 OR subdefPos = 5 THEN OK = TRUE
CASE 4
IF subdefPos = 4 OR subdefPos = 6 THEN OK = TRUE
CASE 5
IF subdefPos = 5 OR subdefPos = 6 THEN OK = TRUE
CASE 6
IF subdefPos = 6 THEN OK = TRUE
CASE 7, 8, 9
IF subdefPos = 7 OR subdefPos = 8 OR subdefPos = 9 THEN OK = TRUE
END SELECT
END IF
'Is the sub guy's name the same as the starting pitcher?
IF DataName(j, it) = DataName(ipa(it), it) THEN OK = FALSE
IF OK THEN
CALL Switch(i, j, it) 'Swap players i and j on team it
DataPos(i, it) = k
END IF
END IF
NEXT
END IF
END IF
NEXT
NEXT
END SUB
SUB SetRefByBO
FOR tm = 1 TO 2
FOR i = 1 TO 9
zS$ = LTRIM$(STR$(DataRef(i, tm)))
RefByBO(i, tm) = PADZEROS$(zS$, 2)
NEXT
NEXT
END SUB
SUB SetRestartData
'The active CmdStat$ must have been picked earlier
SETSCHDate$ = nulls$
IF CmdStat$ > "!" THEN
'Schedule Restart info
IF LEN(DIR$(CmdWritePath$ + CmdStat$ + ".RES")) THEN
OPEN CmdWritePath$ + CmdStat$ + ".RES" FOR RANDOM AS #5 LEN = LEN(RestartRec)
GET #5, 1, RestartRec
SETSCHDate$ = RestartRec.ResSCHDate
SETSlotPtr = RestartRec.ResSCHSlotPtr
SETSlotGameCtr = RestartRec.ResSlotGameCtr
SETSlotGames = RestartRec.ResSlotGames
SimGameCtr = RestartRec.ResSimGameCtr
CLOSE #5
END IF
' Pitching Rotations
IF LEN(DIR$(CmdWritePath$ + CmdStat$ + ".ROT")) THEN
OPEN CmdWritePath$ + CmdStat$ + ".ROT" FOR RANDOM AS #6 LEN = LEN(RotRec(1))
RTx = LOF(6) / LEN(RotRec(1))
FOR i = 1 TO RTx
GET #6, i, RotRec(i)
NEXT
CLOSE #6
END IF
' Standings
IF LEN(DIR$(CmdWritePath$ + CmdStat$ + ".STD")) THEN
OPEN CmdWritePath$ + CmdStat$ + ".STD" FOR RANDOM AS #7 LEN = LEN(WLRec(1))
WLx = LOF(7) / LEN(WLRec(1))
FOR i = 1 TO WLx
GET #7, i, WLRec(i)
NEXT
CLOSE #7
END IF
END IF
'SetPositioninSCH
SoundOn = FALSE
'Reopen to get first line of .SCH file or read until we get valid teams
OPEN CmdPath$ + CmdSCH$ FOR BINARY AS #2
RecLen = 0
L& = LOF(2)
IF L& MOD 210 = 0 THEN RecLen = 210: SchGamesPerRecord = 7
IF L& MOD 430 = 0 THEN RecLen = 430: SchGamesPerRecord = 15
IF RecLen > 0 THEN SchRecords = L& / RecLen ELSE SchRecords = 0
SchBuffer$ = SPACE$(RecLen)
GET #2 ,, SchBuffer$ 'Skip 1st rec
rec = 1
OUTTAHERE = FALSE
DO
SchSlotPtr = 0
INCR rec
IF rec > SchRecords THEN EXIT DO
GET #2 ,, SchBuffer$
IF MID$(SchBuffer$, 1, 1) = "D" THEN ITERATE DO
'Set SCHDate$
SCHDate$ = MID$(SchBuffer$, 3, 8)
DO WHILE SchSlotPtr < SchGamesPerRecord 'formerly 7
INCR SchSlotPtr
CALL ReadSCHSlot
IF CmdVFil$ > "!" AND CmdHFil$ > "!" AND FilterOK THEN
IF SETSCHDate$ > "!" THEN
IF SCHDate$ = SETSCHDate$ AND SchSlotPtr = SETSlotPtr THEN
IF SETSlotGameCtr < SETSlotGames THEN
SlotGameCtr = SETSlotGameCtr
OUTTAHERE = TRUE
EXIT DO
ELSE
SlotGameCtr = 0
SETSCHDate$ = nulls$
END IF
END IF
ELSE
OUTTAHERE = TRUE
EXIT DO
END IF
END IF
LOOP
LOOP UNTIL OUTTAHERE
END SUB
SUB SetSCHBookMark
REGISTER i AS INTEGER
IF CmdStat$ < "!" THEN EXIT SUB
a$ = nulls$
xS$ = CmdWritePath$ + CmdStat$ + ".RES"
yS$ = CmdWritePath$ + CmdStat$ + ".ROT"
zS$ = CmdWritePath$ + CmdStat$ + ".STD"
IF EOF(2) THEN 'SCH is over! [perhaps with "filters"]
a$ = "DEL"
IF LEN(DIR$(xS$)) THEN
KILL xS$
END IF
IF LEN(DIR$(yS$)) THEN
KILL yS$
END IF
IF LEN(DIR$(zS$)) THEN
KILL zS$
END IF
ELSE 'SCH not over - create/update Restart File
OPEN xS$ FOR RANDOM AS #5 LEN = LEN(RestartRec)
RestartRec.ResSCHName = CmdSCH$
RestartRec.ResSCHDate = SCHDate$
RestartRec.ResSCHSlotPtr = SCHSlotPtr
RestartRec.ResSlotGameCtr = SlotGameCtr
RestartRec.ResSlotGames = CmdSlotGames
RestartRec.ResSimGameCtr = SimGameCtr
PUT #5, 1, RestartRec
CLOSE #5
IF RTx > 0 THEN
OPEN yS$ FOR RANDOM AS #6 LEN = LEN(RotRec(1))
FOR i = 1 TO RTx
PUT #6,, RotRec(i)
NEXT
CLOSE #6
END IF
IF WLx > 0 THEN
OPEN zS$ FOR RANDOM AS #7 LEN = LEN(WLRec(1))
FOR i = 1 TO WLx
PUT #7,, WLRec(i)
NEXT
CLOSE #7
END IF
END IF
END SUB
SUB SetSwitches (nargs)
'In:
' ArgList()
' nargs
'Out:
' CmdVM$
' CmdHM$
' CmdSound$
' CmdDH$
' CmdNoOpt$
' CmdSlotGames
REGISTER i AS INTEGER
CmdVM$ = nulls$
CmdHM$ = nulls$
CmdHomeFieldAdv$ = "Y"
CmdSlotGames = 1
CmdDelIsOnCommandLine = FALSE
FOR i = 1 TO nargs
ArgList(i).Arg = UCASE$(ArgList(i).Arg)
Temp$ = RTRIM$(ArgList(i).Arg)
IF INSTR(Temp$, "/P:") THEN CmdPath$ = MID$(Temp$, 4)
IF INSTR(Temp$, "/PW:") THEN CmdWritePath$ = MID$(Temp$, 5)
IF INSTR(Temp$, "/V:") THEN CmdVFil$ = MID$(Temp$, 4)
IF INSTR(Temp$, "/H:") THEN CmdHFil$ = MID$(Temp$, 4)
IF INSTR(Temp$, "/N:") THEN CmdSlotGames = VAL(MID$(Temp$, 4))
IF INSTR(Temp$, "/SCH:") THEN CmdSch$ = MID$(Temp$, 6)
IF INSTR(Temp$, "/SER:") THEN CmdSER$ = MID$(Temp$, 6)
IF INSTR(Temp$, "/ST:") THEN CmdStat$ = MID$(Temp$, 5)
IF INSTR(Temp$, "/STB:") THEN CmdStar$ = MID$(Temp$, 6)
IF INSTR(Temp$, "/BX:") THEN CmdBoxF$ = MID$(Temp$, 5)
IF INSTR(Temp$, "/SC:") THEN CmdScrF$ = MID$(Temp$, 5)
IF INSTR(Temp$, "/LS:") THEN CmdLinF$ = MID$(Temp$, 5)
IF INSTR(Temp$, "/SP:") THEN CmdSP$ = MID$(Temp$, 5)
IF INSTR(Temp$, "/VP:") THEN CmdVP$ = MID$(Temp$, 5)
IF INSTR(Temp$, "/HP:") THEN CmdHP$ = MID$(Temp$, 5)
IF INSTR(Temp$, "/AUL:") THEN CmdAutoLU$ = MID$(Temp$, 6)
IF Temp$ ="/AUL" THEN CmdAutoLU$ = "Y"
IF INSTR(Temp$, "/AL:") THEN CmdAutoLU$ = MID$(Temp$, 5)
IF Temp$ ="/AL" THEN CmdAutoLU$ = "Y"
IF INSTR(Temp$, "/VAL:") THEN CmdVAutoLU$ = MID$(Temp$, 6)
IF Temp$ ="/VAL" THEN CmdVAutoLU$ = "Y"
IF INSTR(Temp$, "/HAL:") THEN CmdHAutoLU$ = MID$(Temp$, 6)
IF Temp$ ="/HAL" THEN CmdHAutoLU$ = "Y"
IF INSTR(Temp$, "/ABO:") THEN CmdAdjustBO$ = MID$(Temp$, 6)
IF Temp$ ="/ABO" THEN CmdAdjustBO$ = "Y"
IF INSTR(Temp$, "/VBO:") THEN CmdVAdjustBO$ = MID$(Temp$, 6)
IF Temp$ ="/VBO" THEN CmdVAdjustBO$ = "Y"
IF INSTR(Temp$, "/HBO:") THEN CmdHAdjustBO$ = MID$(Temp$, 6)
IF Temp$ ="/HBO" THEN CmdHAdjustBO$ = "Y"
IF INSTR(Temp$, "/FOC:") THEN CmdFocus$ = MID$(Temp$, 6)
IF Temp$ ="/FOC" THEN CmdFocus$ = "Y"
IF INSTR(Temp$, "/SPT:") THEN CmdSpot$ = MID$(Temp$, 6)
IF Temp$ ="/SPT" THEN CmdSpot$ = "Y"
IF INSTR(Temp$, "/VSPT:") THEN CmdVSpot$ = MID$(Temp$, 7)
IF Temp$ ="/VSPT" THEN CmdVSpot$ = "Y"
IF INSTR(Temp$, "/HSPT:") THEN CmdHSpot$ = MID$(Temp$, 7)
IF Temp$ ="/HSPT" THEN CmdHSpot$ = "Y"
IF INSTR(Temp$, "/VAM:") THEN CmdVAutoMgr$ = MID$(Temp$, 6)
IF Temp$ ="/VAM" THEN CmdVAutoMgr$ = "Y"
IF INSTR(Temp$, "/HAM:") THEN CmdHAutoMgr$ = MID$(Temp$, 6)
IF Temp$ ="/HAM" THEN CmdHAutoMgr$ = "Y"
IF INSTR(Temp$, "/VM:") THEN CmdVM$ = MID$(Temp$, 5)
IF INSTR(Temp$, "/HM:") THEN CmdHM$ = MID$(Temp$, 5)
IF INSTR(Temp$, "/DH:") THEN CmdDH$ = MID$(Temp$, 5)
IF Temp$ ="/DH" THEN CmdDH$ = "Y"
IF INSTR(Temp$, "/DEL:") THEN CmdDel = VAL(MID$(Temp$, 6)) : CmdDelIsOnCommandLine = TRUE
IF INSTR(Temp$, "/C:") THEN CmdColor$ = MID$(Temp$, 4)
IF Temp$ ="/C" THEN CmdColor$ = "Y"
IF INSTR(Temp$, "/S:") THEN CmdSound$ = MID$(Temp$, 4)
IF Temp$ ="/S" THEN CmdSound$ = "Y"
IF INSTR(Temp$, "/PG:") THEN CmdPauseAftGame$ = MID$(Temp$, 5)
IF Temp$ ="/PG" THEN CmdPauseAftGame$ = "Y"
IF INSTR(Temp$, "/PD:") THEN CmdPauseAftDate$ = MID$(Temp$, 5)
IF Temp$ ="/PD" THEN CmdPauseAftDate$ = "Y"
IF INSTR(Temp$, "/ERA:") THEN CmdERA$ = MID$(Temp$, 6)
IF INSTR(Temp$, "/DEBUG") THEN CmdDeBug$ = "Y"
IF INSTR(Temp$, "/NOOPT") THEN CmdNoOpt$ = "Y"
IF INSTR(Temp$, "/CC:") THEN CmdCols$ = MID$(Temp$, 5)
IF INSTR(Temp$, "/CR:") THEN CmdRows$ = MID$(Temp$, 5)
IF INSTR(Temp$, "/X:") THEN CmdAutoExit$ = MID$(Temp$, 4) 'new 4.8
IF Temp$ ="/X" THEN CmdAutoExit$ = "Y"
IF INSTR(Temp$, "/T:") THEN CmdHomeFieldAdv$ = MID$(Temp$, 4) 'new 4.8
IF Temp$ ="/T" THEN CmdHomeFieldAdv$= "N"
NEXT
'Edit CmdVFil$ and CmdHFil$ a bit
ii = INSTR(CmdVFil$, ".")
IF ii > 0 THEN CmdVFil$ = MID$(CmdVFil$, 1, ii-1)
IF LEN(CmdVFil$) > 8 THEN CmdVFil$ = MID$(CmdVFil$, 1, 8)
ii = INSTR(CmdHFil$, ".")
IF ii > 0 THEN CmdHFil$ = MID$(CmdHFil$, 1, ii-1)
IF LEN(CmdHFil$) > 8 THEN CmdHFil$ = MID$(CmdHFil$, 1, 8)
IF CmdCols$ <> nulls$ THEN
n = VAL(CmdCols$)
IF n > 0 AND n < 200 THEN ConsCols = n
END IF
IF CmdRows$ <> nulls$ THEN
n = VAL(CmdRows$)
IF n > 0 AND n < 100 THEN ConsRows = n
END IF
CmdVM$ = RTRIM$(CmdVM$)
CmdHM$ = RTRIM$(CmdHM$)
CmdERA$ = RTRIM$(CmdERA$)
IF CmdVM$ = "+" THEN
IF NOT FoundInMMList (CmdVFil$) THEN CALL AddToMMList (CmdVFil$)
ELSEIF CmdVM$ = "-" THEN
CALL DelFrMMList (CmdVFil$)
END IF
IF CmdHM$ = "+" THEN
IF NOT FoundInMMList (CmdHFil$) THEN CALL AddToMMList (CmdHFil$)
ELSEIF CmdHM$ = "-" THEN
CALL DelFrMMList (CmdHFil$)
END IF
IF CmdPath$ <> nulls$ THEN
IF RIGHT$(CmdPath$, 1) <> "\" THEN CmdPath$ = CmdPath$ + "\"
END IF
IF CmdWritePath$ <> nulls$ THEN
IF RIGHT$(CmdWritePath$, 1) <> "\" THEN CmdWritePath$ = CmdWritePath$ + "\"
END IF
IF CmdSch$ <> nulls$ THEN
SchedSw = TRUE
i = INSTR(CmdSch$, ".")
IF i THEN CmdSch$ = LEFT$(CmdSch$, i - 1)
CmdSch$ = RTRIM$(CmdSch$) + ".SCH"
END IF
IF CmdSER$ <> nulls$ THEN
SeriesSw = TRUE
i = INSTR(CmdSER$, ".")
IF i THEN CmdSER$ = LEFT$(CmdSER$, i - 1)
CmdSER$ = RTRIM$(CmdSER$) + ".SER"
END IF
IF CmdStat$ <> nulls$ THEN
i = INSTR(CmdStat$, ".")
IF INSTR(CmdStat$, ".") THEN
CmdStat$ = LEFT$(CmdStat$, i - 1)
ELSE
CmdStat$ = RTRIM$(CmdStat$)
END IF
END IF
IF CmdSP$ = nulls$ THEN CmdSP$ = "S5"
'Sound Defaults: if using a .sch/.ser file default is "no" else "yes"
SoundOn = (CmdSound$ = "Y")
IF CmdAutoLU$ = "Y" THEN
AutoLineUpSw(1) = TRUE
AutoLineUpSw(2) = TRUE
END IF
IF CmdVAutoLU$ = "Y" THEN AutoLineUpSw(1) = TRUE
IF CmdHAutoLU$ = "Y" THEN AutoLineUpSw(2) = TRUE
IF CmdAdjustBO$ = "Y" OR CmdAdjustBO$ = "C" OR CmdAdjustBO$ = "F" THEN
AdjustBO(1) = CmdAdjustBO$
AdjustBO(2) = CmdAdjustBO$
END IF
IF CmdVAdjustBO$ = "Y" OR CmdVAdjustBO$ = "C" OR CmdVAdjustBO$ = "F" THEN AdjustBO(1) = CmdVAdjustBO$
IF CmdHAdjustBO$ = "Y" OR CmdHAdjustBO$ = "C" OR CmdHAdjustBO$ = "F" THEN AdjustBO(2) = CmdHAdjustBO$
IF CmdPauseAftGame$ <> "Y" THEN CmdPauseAftGame$ = "N"
IF CmdPauseAftDate$ <> "Y" THEN CmdPauseAftDate$ = "N"
'Color Defaults
'Override color if desired
IF CmdColor$ <> nulls$ THEN mon$ = CmdColor$
'1=dark blue 2=green 3=sky-blue 4=red 5=purple 6=brown 7=grey
CALL SetColors (ColorScheme) 'sets field and label colors
deffor = 15: defbac = 1 'bright on dark blue
revfor = 0: revbac = 7 'black on grey
drtfor = 15: drtbac = 6 'bright on brown DIRT
prmfor = 14: prmbac = 0 'yellow on black
linfor = 0: linbac = 7 'black on grey
errfor = 15: errbac = 4 'bright on red
scofor = 15: scobac = 0 'bright on black
scdfor = 7: scdbac = 0 'grey on black
drkfor = 3: drkbac = 0 'sky blue on black
dimfor = 7: dimbac = 1 'grey on dark blue
defattr = CALCATTR(deffor, defbac)
revattr = CALCATTR(revfor, revbac)
drtattr = CALCATTR(drtfor, drtbac)
prmattr = CALCATTR(prmfor, prmbac)
linattr = CALCATTR(linfor, linbac)
errattr = CALCATTR(errfor, errbac)
scoattr = CALCATTR(scofor, scobac)
scdattr = CALCATTR(scdfor, scdbac)
drkattr = CALCATTR(drkfor, drkbac)
dimattr = CALCATTR(dimfor, dimbac)
skipattr = CALCATTR(0, 1) 'black on blue
END SUB
SUB ShowDoc
'This will launch Wordpad in separate window
IF LEN(DIR$("BASEBALL.RTF")) THEN
zS$ = WordPadSpec$ + " BASEBALL.RTF"
ELSEIF LEN(DIR$("BASEBALL.DOC")) THEN
zS$ = WordPadSpec$ + " BASEBALL.DOC"
ELSE
CALL PopMsg(18+rowO, 12+colO, " BASEBALL.RTF or BASEBALL.DOC not found in current directory", errattr, 2, kc)
EXIT SUB
END IF
ShowWindState& = 1
ConsoleShell zS$, ShowWindState&
END SUB
SUB ShowStandings (delayy) STATIC
ON ERROR GOTO ErrorTrap
REGISTER i AS LONG
IF SaveL = 0 THEN DIM SaveDivByLeagues(3) AS LONG
IF WLx < 1 THEN GOTO ExitShowStandings
'Compute WLPct(i)
FOR i = 1 TO WLx
Games = WLRec(i).WLWins + WLRec(i).WLLoss
IF Games > 0 THEN
xF! = WLRec(i).WLWins / Games
n = xF! * 1000
xS$ = LTRIM$(STR$(n))
WLRec(i).WLPct = PADZEROS$(xS$, 4)
ELSE
WLRec(i).WLPct = "0000"
END IF
NEXT
'Sort the WLRec by WLLeague/WLDiv/WLPct
ARRAY SORT WLRec(1) FOR WLx, FROM 21 TO 26, DESCEND
'Count Leagues and Divisions
REDIM DivByLeagues(3) AS LONG
L=0
i=1
DO WHILE i <= WLx
D=0
IF L = 3 THEN EXIT DO
INCR L
SaveLeague$ = WLRec(i).WLLeague
DO WHILE SaveLeague$ = WLRec(i).WLLeague AND i <= WLx
IF D = 3 THEN EXIT DO
INCR D
SaveDiv$ = WLRec(i).WLDiv
DO WHILE SaveDiv$ = WLRec(i).WLDiv AND _
SaveLeague$ = WLRec(i).WLLeague AND i <= WLx
INCR i
IF i > WLx THEN EXIT DO
LOOP
IF L < 4 THEN DivByLeagues(L) = D
IF i > WLx THEN EXIT DO
LOOP
IF i > WLx THEN EXIT DO
LOOP
'Decide whether to print veritically or horizontally
Horz = FALSE
FOR i = 1 TO L
IF DivByLeagues(i) > 2 THEN Horz = TRUE
NEXT
'Decide whether we need to erase the screen or not
erasescreen = 0
IF L > SaveL THEN SaveL = L: erasescreen = -1
FOR i = 1 TO L
IF DivByLeagues(i) <> SaveDivByLeagues(i) THEN
SaveDivByLeagues(i) = DivByLeagues(i)
erasescreen = -1
END IF
NEXT
IF erasescreen THEN
COLOR deffor, defbac
CLS
CALL Prompt(0) '0 = [O]ptions [T]oggle display '1 = [N]ew
END IF
QPRINTs 1, MidCol-5, "Standings", defattr
i = 1
LegCtr = 0
BiggestRow = 0
DO
SaveLeague$ = WLRec(i).WLLeague
SELECT CASE SaveLeague$
CASE "A"
LeagueName$ = "A.L."
CASE "N"
LeagueName$ = "N.L."
CASE "F"
LeagueName$ = "Federal"
CASE ELSE
LeagueName$ = SaveLeague$
END SELECT
IF Horz THEN
IF LegCtr = 0 THEN r = 2
IF LegCtr = 1 THEN r = 12
c = 1
ELSE
c = LegCtr * 31 + 1 '27
r = 2
END IF
IF c < 56 THEN
QPRINTs r, c, LeagueName$, defattr
END IF
DivCtr = 0
DO WHILE WLRec(i).WLLeague = SaveLeague$ AND i <= WLx
IF Horz THEN
IF LegCtr = 0 THEN r = 3
IF LegCtr = 1 THEN r = 12
c = DivCtr * 27 + 1
ELSE
r = DivCtr * 9 + 3
c = LegCtr * 31 + 1 '27
END IF
SaveDiv$ = WLRec(i).WLDiv
IF (Horz AND LegCtr = 0) OR (NOT Horz) THEN
DivName$ = SPACE$(16)
IF SaveDiv$ = "N" THEN DivName$ = "North"
IF SaveDiv$ = "S" THEN DivName$ = "South"
IF SaveDiv$ = "E" THEN DivName$ = "East"
IF SaveDiv$ = "C" THEN DivName$ = "Central"
IF SaveDiv$ = "W" THEN DivName$ = "West"
IF c < 56 AND r < 13 THEN
QPRINTs r, c, DivName$, defattr
IF r = 3 THEN
INCR r
IF MenuOpt$ = "T" THEN
QPRINTs r, c, " Won Lost Pct", defattr
ELSE
QPRINTs r, c, " Won Lost Pct", defattr
END IF
END IF
END IF
END IF
DO WHILE WLRec(i).WLDiv = SaveDiv$ AND WLRec(i).WLLeague = SaveLeague$ AND i <= WLx
INCR r
IF Horz THEN
IF LegCtr = 0 AND r > 11 THEN GOTO SSNextRec
END IF
IF r > 19 THEN GOTO SSNextRec
IF c < 56 THEN
IF MenuOpt$ = "T" THEN
a$ = SPACE$(29)
MID$(a$, 1, 11) = WLRec(i).WLTeam
MID$(a$, 12, 6) = LFORMAT$(WLRec(i).WLWins, "######")
MID$(a$, 19, 6) = LFORMAT$(WLRec(i).WLLoss, "######")
IF WLRec(i).WLPct > "0998" THEN
MID$(a$, 26, 4) = "1.00"
ELSE
MID$(a$, 26, 1) = "."
MID$(a$, 27, 3) = RIGHT$(WLRec(i).WLPct, 3)
END IF
ELSE
a$ = SPACE$(24)
MID$(a$, 1, 11) = WLRec(i).WLTeam
MID$(a$, 12, 4) = LFORMAT$(WLRec(i).WLWins, "####")
MID$(a$, 16, 4) = LFORMAT$(WLRec(i).WLLoss, "####")
IF WLRec(i).WLPct > "0998" THEN
MID$(a$, 21, 4) = "1.00"
ELSE
MID$(a$, 21, 1) = "."
MID$(a$, 22, 3) = RIGHT$(WLRec(i).WLPct, 3)
END IF
END IF
QPRINTs r, c, a$, dimattr
IF r > BiggestRow THEN BiggestRow = r
END IF
SSNextRec:
INCR i
IF i > WLx THEN EXIT DO
LOOP
'Division Changed
INCR DivCtr
IF i > WLx THEN EXIT DO
LOOP
'League Changed
INCR LegCtr
LOOP UNTIL i > WLx
'Display Hi-lites
IF HLx > 0 AND HLx <> HLxOld THEN
HLxOld = HLx
REDIM List1(1 TO 400) AS List1Type
i = 0
DO WHILE i < HLx
INCR i
xS$ = PADRIGHT$(LTRIM$(STR$(HLRec(i).HLGameNo)), 6) + HLRec(i).HLMessage
List1(i).ListItem = xS$
LOOP
r1 = BiggestRow + 2
r2 = ConsRows - 1
c1 = 2
c2 = ConsCols - 1
QPRINTs r1-1, c1, SPACE$(c2-c1+1), defattr 'blank line
IF Delayy = FALSE THEN
CALL Drawfrm(r1, c1, r2, c2, defattr, "Hi-Lites", "", 0, 0, 0)
RetKey = -97 'Display and return instantly
ELSE
CALL Drawfrm(r1, c1, r2, c2, defattr, "Hi-Lites", "ESC PgUp/PgDown", 0, 0, 0)
RetKey = -98 'Display and wait for paging keys
END IF
CALL PickFromList(List1(), HLx, r2-r1-1, 2, INT((c2-c1)/2)-2, r1, c1, r2, c2, dimattr, revattr, Pick, RetKey, nulls$, mous, ms$)
ERASE List1
EXIT SUB
END IF
ExitShowStandings:
IF Delayy THEN PauseIt
EXIT SUB
ErrorTrap:
LOCATE 10, 30
PRINT "ERROR: Standings"; ERRCLEAR
x$ = WAITKEY$
END SUB
SUB ShowVirtWin (p1, maxLines, RowOff, ColOff, startline, startcol, rowlock, collock, collimit)
'Clear out viewing window
'maxLines = 10
'startline = 3
'startcol = 3
'rowlock = 10
'collock = 20
'collimit = 76
'locate 6, 30: PRINT "Entering ShowVirtWin "; : xS$ = Waitkey$
'locate 6, 30: PRINT " ";
'Scroll Down 10, 3, 3, 12, 78
'SCROLL DOWN maxLines, startline, startcol, startline + maxLines - 1, startcol + collimit - 1
'locate 6, 30: PRINT "Just did a scroll down"; : xS$ = Waitkey$
'locate 6, 30: PRINT " ";
IF ConsRows = 25 AND ConsCols = 80 THEN BeginBuffer
sr = startline - 1
FOR r = 1 TO rowlock
xS$ = MID$(VirtualWin(r).item, 1, collock)
GOSUB FixAttr
INCR sr
QPRINTs sr, startcol, xS$, attr
xS$ = MID$(VirtualWin(r).item, collock + ColOff + 1)
xS$ = PADRIGHT$(xS$, collimit - collock)
QPRINTs sr, startcol + collock, xS$, attr
NEXT
'locate 6, 30: PRINT "Just did first part "; : xS$ = Waitkey$
'locate 6, 30: PRINT " ";
r = rowlock + RowOff + p1
DO WHILE (sr - startline + 1) < maxLines
IF r > MAXPLAYERS + 4 THEN EXIT DO
xS$ = MID$(VirtualWin(r).item, 1, collock)
L = LEN(xS$)
' IF xS$ = SPACE$(L) THEN EXIT DO
IF xS$ < " !" THEN xS$ = SPACE$(L)
INCR sr
GOSUB FixAttr
QPRINTs sr, startcol, xS$, attr
xS$ = MID$(VirtualWin(r).item, collock + ColOff + 1)
L = LEN(xS$)
IF xS$ < " !" THEN xS$ = SPACE$(L)
xS$ = PADRIGHT$(xS$, collimit - collock)
QPRINTs sr, startcol + collock, xS$, attr
IF xS$ = SPACE$(L) THEN EXIT DO
INCR r
LOOP
'locate 6, 30: PRINT "Just did 2nd part "; : xS$ = Waitkey$
'locate 6, 30: PRINT "Out of ShowVirtWin ";
IF ConsRows = 25 AND ConsCols = 80 THEN EndBuffer
EXIT SUB
FixAttr:
IF LEFT$(xS$, 1) = "~" THEN
xS$ = MID$(xS$, 2) + " "
attr = defattr
ELSE
attr = dimattr
END IF
RETURN
END SUB
SUB SingleRoutine
InfieldHit = FALSE
ConsiderExtraBase = FALSE
IF Errorx = FALSE THEN
'Decide where the hit went
ppF! = FindPP!
ELSE
'An infielder made an error on the play
IF SoundOn THEN CALL WavRegularGrounder
IF OneBaseError THEN
ii = 1
jj = 1
GOTO SingleAdvance
ELSEIF ThrowError THEN
ii = 2
jj = 2
GOTO SingleAdvance
ELSE
'The ground ball error has gone to the outfield
OrgWhoAtPos = WhoAtPos
WhoAtPos = OUTfrIN(WhoAtPos, 0)
END IF
END IF
IF Errorx = FALSE THEN
IF RND < .6 THEN 'FLY (60% of hits)
WhoAtPos = OUTFIELDWHOAT(ppF!)
wag = WHOATGUY(WhoAtPos)
IF DelFac THEN
IF RND < .10 THEN
'Short dramatic flys
IF SoundOn THEN CALL WavShortFly
CALL Msg ("07", "0", "1", "02", 0, id, man2, team2)
CALL Msg ("07", "0", "2", "02", wag, id, man2, team2)
CALL Msg ("07", "0", "3", "02", 0, id, man2, team2)
CALL Msg ("29", "0", "0", "15", 0, id, man2, team2)
CALL Msg ("29", "0", "0", "09", ib, it, man2, team2)
ELSE
'Regular flys
IF SoundOn THEN CALL WavRegularHit
p$ = LTRIM$(STR$(WhoAtPos))
t$ = PADZEROS$(LTRIM$(STR$(RND(1,4))) , 2)
IF t$ = "02" THEN i = ib: j = it ELSE i = wag: j = id
CALL Msg ("12", p$, "1", t$, 0, id, man2, team2)
CALL Msg ("12", p$, "2", t$, i, j, man2, team2)
CALL Msg ("12", p$, "3", t$, ib, it, man2, team2)
END IF
END IF
ELSE 'GROUND (40% of hits)
WhoAtPos = GROUNDBALLWHOAT (ppF!)
wag = WHOATGUY(WhoAtPos)
p$ = LTRIM$(STR$(WhoAtPos))
x! = RND
'Infield Hit?
IF RND < .25 OR p$ < "3" THEN 'Set % of infield hits (25% of 40% = 10%)
'Possibility of Infield Hit and wild throw (Hit and error)
WildThrow = FALSE
IF WhoAtPos <> 3 THEN
defperF! = DEFPCT!(wag)
zF! = (1.0 - defperF!) * .65 'Increase constant for fewer errors
IF RND > (defperF! + zF!) THEN WildThrow = TRUE
END IF
IF DelFac THEN
IF x! < .15 THEN 'set "type" of infield hit
t$ = "01" ' (most are "slow")
ELSEIF x! < .30 THEN
t$ = "02"
ELSE
t$ = "04"
END IF
IF p$ = "1" THEN t$ = "04"
IF SoundOn THEN
IF t$ = "04" THEN
CALL WavSoftGrounder
ELSE
CALL WavRegularGrounder
END IF
END IF
CALL Msg ("03", p$, "1", t$, 0, id, man2, team2)
CALL Msg ("03", p$, "2", t$, wag, id, man2, team2)
CALL Msg ("03", p$, "3", t$, wag, id, man2, team2)
'Not in time
CALL Msg ("23", "0","0","01", 0, it, man2, team2)
IF WildThrow THEN
AddToAnnouncer id, "Wild throw! Into the dugout!"
IF NUMBERON > 0 THEN
AddToAnnouncer it, "Everybody gets an extra base!"
END IF
AddToAnnouncer it, "The hitter will wind up on second."
AddToAnnouncer it, "Score that one: a hit and an error."
ELSE
CALL Msg ("23", "0","0","02", 0, it, man2, team2)
END IF
END IF
InfieldHit = TRUE
ELSE
'Shot through the infield somewhere
IF DelFac THEN
IF x! < .5 THEN 'No "slow" or "right at"
t$ = "01"
ELSE
t$ = "02"
END IF
IF SoundOn THEN CALL WavRegularGrounder
CALL Msg ("03", p$, "1", t$, 0, id, man2, team2)
IF RND < .6 THEN 'tough chance/can't get there
CALL Msg ("22", "0", "0", "00", wag, id, man2, team2)
END IF
'Do PostAnnouncer here to flash the infielder
CALL PostAnnouncer (TRUE, TRUE)
SLEEP 1000
ANx = 0
'Next time it should flash the outfielder
CALL Msg ("29", "0", "0", "09", ib, it, man2, team2) 'BASE HIT
END IF
Middle = FALSE
IF p$ = "4" AND t$ = "01" THEN Middle = TRUE
IF p$ = "6" AND t$ = "02" THEN Middle = TRUE
WhoAtPos = OUTfrIN (WhoAtPos, Middle) 'Point action to outfield
wag = WHOATGUY(WhoAtPos)
END IF
END IF
END IF
'How far to advance runners? (default)
ThrowOutChance1 = 0
ThrowOutChance2 = 0
ThrowToThird = FALSE
ConcedeRun = FALSE
Gamble = 0
ii = 1
jj = 1
IF HitAndRun OR InfieldHit THEN
IF HitAndRun AND InfieldHit THEN
IF RND < .33 THEN '2009 - was .51
ii = 2
jj = 2
END IF
ELSEIF HitAndRun THEN
IF RND < .9 THEN '2009 - was always
ii = 2
jj = 2
END IF
END IF
GOTO SingleTOCheck
END IF
IF ir2 THEN
IF ir3 THEN i = 2 ELSE i = 1
IF (itruns(it) + i < itruns(id)) THEN 'Tying run will not score...
IF ir1 THEN
IF amgr(id) = 0 AND AutoDefense = 0 THEN
CALL PostAnnouncer (TRUE, TRUE)
ANx = 0
SLEEP 1500
r = 10+rowO
c = 25+colO
x$ = " Defense: Throw to 3rd? [y/N] "
CALL PopMsg(r, c, x$, errattr, 0, kc)
IF UCASE$(CHR$(kc)) = "Y" THEN
ThrowToThird = TRUE
jj = 2 'Concede run - throw to third
END IF
ELSE
'When should defense throw to 3rd instead of to home?
'Faster runner on 2nd or slow runner on 1st
IF ( (DataSpeed(ir2, it) - DataSpeed(ir1, it) > 1) OR _
DataSpeed(ir1, it) < 4 ) THEN
ThrowToThird = TRUE
jj = 2
END IF
END IF
ELSE 'ir1 = 0
IF amgr(id) = 0 AND AutoDefense = 0 THEN
CALL PostAnnouncer (TRUE, TRUE)
ANx = 0
SLEEP 1500
r = 10+rowO
c = 16+colO
IF ir3 = 0 THEN
x$ = " Defense: Concede run / Hold batter on 1st? [y/N] "
ELSE
x$ = " Defense: Concede runs / Hold batter on 1st? [y/N] "
END IF
CALL PopMsg(r, c, x$, errattr, 0, kc)
IF UCASE$(CHR$(kc)) = "Y" THEN
ConcedeRun = TRUE
jj = 2 'Concede run - throw to 2nd
END IF
ELSE
'When should defense concede run[s] and just keep batter on 1st?
'Runner on 2nd is fast OR Batter is fast
IF ( (DataSpeed(ir2, it) > 6) OR _
DataSpeed(ib, it) > 7 ) THEN
ConcedeRun = TRUE
jj = 2 'Concede run - throw to 2nd
END IF
END IF
END IF
END IF
END IF
IF ir2 > 0 AND ThrowToThird = FALSE AND ConcedeRun = FALSE THEN
'Advance runner on 2nd jj
'Safe% 2nd-Home
'Sp 0/1out 2out new
' 1 64 76
' 2 68 80
' 3 72 84
' 4 76 88
' 5 80 92
' 6 84 96
' 7 88 98
' 8 92 98
' 9 96 98
IF iout = 2 THEN i = 12 ELSE i = 0
n = 4 * DataSpeed(ir2, it) + 60 + i '4.6
n = n + (7 - FRND(13)) '+/- 6
IF n > 98 THEN n = 98
IF amgr(it) = 0 AND AutoCoach = 0 THEN
CALL PostAnnouncer (TRUE, TRUE)
ANx = 0
SLEEP 1500
r = 10+rowO
c = 22+colO
x$ = " Score runner from 2nd? [y/N] (" + LFORMAT$(n, "##") + "%)"
CALL PopMsg(r, c, x$, errattr, 0, kc)
IF UCASE$(CHR$(kc)) = "Y" THEN
jj = 2
ThrowOutChance1 = 100 - n
END IF
ELSE
IF iout = 0 THEN SucLim = 80 '84
IF iout = 1 THEN SucLim = 72 '76
IF iout = 2 THEN SucLim = 68 '72
'Special Case:
IF iout = 2 THEN
RunsBehind = itruns(id) - itruns(it)
IF ir3 THEN a = 2 ELSE a = 1
IF RunsBehind = a OR RunsBehind = (a - 1) THEN
SucLim = 50
END IF
END IF
IF n >= SucLim THEN
jj = 2
ThrowOutChance1 = 100 - n 'chance of getting thrown out at home
IF SucLim = 50 AND n < 79 THEN
Gamble = TRUE
ii = 2
ThrowOutChance2 = 3 'chance of getting thrown out at third
GOTO SingleTOCheck
END IF
END IF
END IF
END IF
IF ir1 THEN 'Advance runner on 1st ii
IF (ir2 <> 0 AND jj = 1) THEN
ii = 1 'Don't overrun somebody
ELSE
'Safe% 1st-3rd
'
' left center right
'Sp 0/1out 2out 0/1out 2out 0/1out 2out
'
' 1 48 60 56 68 64 76
' 2 52 64 60 72 68 80
' 3 56 68 64 76 72 84
' 4 60 72 68 80 76 88
' 5 64 76 72 84 80 92
' 6 68 80 76 88 84 96
' 7 72 84 80 92 88 98
' 8 76 88 84 96 92 98
' 9 80 92 88 98 96 98
IF iout = 2 THEN i = 12 ELSE i = 0
n = 4 * DataSpeed(ir1, it) + 52 + i
IF ThrowToThird THEN n = n - 20
IF WhoAtPos = 7 THEN i = -8
IF WhoAtPos = 8 THEN i = 0
IF WhoAtPos = 9 THEN i = 8
n = n + i
n = n + (9 - FRND(15)) '+/- 8
IF n > 98 THEN n = 98
IF amgr(it) = 0 AND AutoCoach = 0 THEN
CALL PostAnnouncer (TRUE, TRUE)
ANx = 0
SLEEP 1500
r = 10+rowO
c = 26+colO
x$ = " Go 1st-to-3rd? [y/N] (" + LFORMAT$(n, "##") + "%)"
CALL PopMsg(r, c, x$, errattr, 0, kc)
IF UCASE$(CHR$(kc)) = "Y" THEN
ii = 2
ThrowOutChance2 = 100 - n
END IF
ELSE
IF iout = 0 THEN SucLim = 88 '90 88
IF iout = 1 THEN SucLim = 70 '76 74
IF iout = 2 THEN SucLim = 92 '92 90
IF n >= SucLim THEN 'Try to go 1st-3rd
ii = 2
ThrowOutChance2 = 100 - n
END IF
END IF
END IF
END IF
SingleTOCheck:
IF DelFac THEN
IF ir3 > 0 THEN CALL AnnScoring(ir3)
IF Gamble THEN
xS$ = "They'll gamble to score " + LASTNAME$(DataName(ir2, it)) + "..."
CALL AddToAnnouncer (it, xS$)
END IF
END IF
IF ir1 OR ir2 THEN
CALL ThrowOutCheck (ii, jj, ThrowOutChance1, ThrowOutChance2, ThrowToThird, ConcedeRun)
IF jj = 2 AND ref2 = 0 AND ConcedeRun = FALSE THEN
'Had a chance to throw out somebody but did not
'Sometimes take extra base
ConsiderExtraBase = TRUE
END IF
END IF
SingleAdvance:
CALL Advanc(ii, jj, 1)
IF ref2 THEN INCR iout 'Anybody get thrown out?
ir1 = ib
mpp(ib) = ip
IF Errorx THEN
mpp(ib) = -mpp(ib) 'Flip to negative to show batter got on via an error
IF OneBaseError OR ThrowError THEN GOTO SubEXIT
ELSE
CALL CreditHit
Result$ = "1B"
'Possibility of throwing error on infield hits
IF InfieldHit THEN
IF WildThrow THEN
INCR iterrs(id)
INCR inne
INCR innadverr
i = DataRef(wag, id)
INCR GpPos(i, id, WhoAtPos)
INCR merr(i, id)
INCR SumErrors(WhoAtPos)
Errorx = TRUE
CALL Advanc(1, 1, 1) 'Everybody advances one extra base
Errorx = FALSE
Result$ = Result$ + "/E-" + LTRIM$(STR$(WhoAtPos))
WildThrow = FALSE
END IF
END IF
IF InfieldHit THEN GOTO SubEXIT
'Done, if infield hit
END IF
'Did the outfielder muff the ball?
'Not if runner was thrown out!
'Not if throw went through even if runner was not thrown out
IF (ref2 > 0 OR ConsiderExtraBase = TRUE) AND ir2 = 0 THEN
'Runner on 1st can sometimes take extra base on the throw
IF DataSpeed(ir1, it) + FRND(10) > 12 THEN '13?
ir2 = ir1
ir1 = 0
IF DelFac THEN AddToAnnouncer it, "Runner moves up on the throw."
GOTO SubEXIT 'Never outfield muff if move up on throw
END IF
END IF
IF ref2 > 0 THEN GOTO SubEXIT 'Never outfield muff if somebody thrown out
'Check for Outfielder muff
CALL Outfield (WhoAtPos)
'Gamble to stretch single (and some infield errors) into a double? It's not an infield hit or 1-base error.
IF OutFErr = FALSE THEN
IF amgr(it) = 0 AND AutoCoach = 0 THEN
IF ir1 = ib AND ir2 = 0 THEN
'criteria to gamble
RunsBehind = itruns(id) - itruns(it)
IF ir3 THEN a = 2 ELSE a = 1
IF inn > (RegInns - 4) AND (RunsBehind = a OR RunsBehind = a-1) THEN
CALL PostAnnouncer (TRUE, TRUE)
ANx = 0
SLEEP 1500
r = 10+rowO
c = 23+colO
n = 5 * DataSpeed(ir1, it) + 30
x$ = " Stretch hit to a double? [y/N] (" + LFORMAT$(n, "##") + "%)"
CALL PopMsg(r, c, x$, errattr, 0, kc)
IF UCASE$(CHR$(kc)) = "Y" THEN
IF DelFac THEN CALL Msg ("31", "0", "0", "09", ir1, it, man2, team2)
'He's going to try for second!
IF DelFac THEN CALL Msg ("31", "0", "0", "06", ir1, it, man2, team2)
'He slides...
IF RND < (n / 100) THEN
'Made it
IF Errorx = FALSE THEN
INCR m2b(ref, it)
IF UCASE$(DataHand(ip, id)) = "L" THEN
INCR m2bLHP(ref, it)
ELSE
INCR m2bRHP(ref, it)
END IF
INCR mp2b(ip, id)
Result$ = "2B"
END IF
ir2 = ib
ir1 = 0
IF DelFac THEN CALL Msg ("15", "0", "0", "09", ir2, it, man2, team2)
'Safe
IF DelFac THEN CALL Msg ("31", "0", "0", "11", ir2, it, man2, team2)
'Gamble pays off!
ELSE
'Didn't make it
INCR mpo(ip, id)
IF DelFac THEN CALL Msg ("14", "0", "0", "02", ir1, it, man2, team2)
'OUT! The gamble failed.
ref2 = DataRef(ir1, it)
' Result2$ = "X-@2nd"
INCR Assists(DataRef(WHOATGUY(WhoAtPos), id), id, WhoAtPos)
IF WhoAtPos = 7 THEN m = 4 ELSE m = 6 'who took throw?
INCR PutOuts(DataRef(WHOATGUY(m), id), id, m)
Result2$ = LTRIM$(STR$(WhoAtPos)) + "-" + LTRIM$(STR$(m))
Code2$ = "2"
ir1 = 0
INCR iout
END IF
END IF
END IF
END IF
END IF
END IF
SubEXIT:
END SUB
SUB SnapShot
' make sure RefOrg has been REDIMed (cleared)
' make sure RefByBO has been erased
REDIM RefOrg(MAXPLAYERS, 2) AS GLOBAL RefOrgType
REDIM RefOrgSave(MAXPLAYERS, 2) AS GLOBAL RefOrgType
REDIM RefByBO(9, 2) AS GLOBAL STRING
FOR tm = 1 TO 2
FOR i = 1 TO MAXPLAYERS
ref = DataRef(i, tm)
p = DataPos(i, tm)
RefOrg(i, tm).RefNo = ref
RefOrg(i, tm).RefPos = p
RefOrgSave(i, tm).RefNo = ref
RefOrgSave(i, tm).RefPos = p
' Copy starting lineups positions to RefByBO
IF i < 10 THEN CALL AddToRefByBO (i, tm, ref)
NEXT
NEXT
END SUB
SUB SoundQAdd(SoundCode)
IF SQx < 10 THEN
INCR SQx
SoundQ(SQx) = SoundCode
END IF
END SUB
SUB StatsIO (Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
CALL Drawfrm(8+rowO, 10+colO, 21+rowO, 69+colO, defattr, "Statistics Report Options", "ESC (or close window):Generate Report F3:Cancel", 1, 0, 2)
DATA 10,12,"Statistics File: ", 10,30,38,"X "
DATA 12,12,"Standings [Y,n]", 12,44, 1,"X "
DATA 13,12,"Highlights [Y,n]", 13,44, 1,"X "
DATA 14,12,"Batting/Pitching/Fielding [Y,n]", 14,44, 1,"X "
DATA 15,12," Min. AB ", 15,42, 3,"N "
DATA 16,12," Batting R/L Breakdown [y,N]", 16,44, 1,"X "
DATA 17,12," Fielding [Y,n]", 17,44, 1,"X "
DATA 18,12," Fielding Detail [y,N]", 18,44, 1,"X "
DATA 19,12,"League Leaders [Y,n]", 19,44, 1,"X "
Flds = 9
c = 1
FOR i = 1 TO Flds
Flitrow(i) = VAL(READ$(c)) + rowO
Flitcol(i) = VAL(READ$(c+1)) + colO
Flit$(i) = READ$(c+2)
Frow(i) = VAL(READ$(c+3)) + rowO
Fcol(i) = VAL(READ$(c+4)) + colO
Flen(i) = VAL(READ$(c+5))
Fed$(i) = READ$(c+6)
c = c + 7
NEXT
REDIM FContents$(13)
FContents$(1) = CmdWritePath$ + CmdStat$
FContents$(2) = "Y" 'standings
FContents$(3) = "Y" 'hilights
FContents$(4) = "Y" 'main
FContents$(5) = " 0" 'include AB >= this
FContents$(6) = "N" 'batting r/l
FContents$(7) = "Y" 'fielding
FContents$(8) = "N" 'fielding bd
FContents$(9) = "Y" 'leaders
CursorPtr = 1
DO
StatsLoop:
s = deffor
deffor = dimfor
CALL ScreenIO(Keyed, KeyF3, 0, KeyEsc, Flds, CursorPtr, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
deffor = s
'Trap F3
IF Keyed = KeyF3 THEN EXIT SUB
' Edit Field Contents
Error1$ = "N"
IF FContents$(1) < "!" THEN EXIT SUB
FOR i = 9 TO 2 STEP -1
IF i <> 5 THEN
IF FContents$(i) <> "Y" AND FContents$(i) <> "N" THEN
CursorPtr = i
Error1$ = "Y"
END IF
END IF
NEXT
LOOP WHILE Error1$ = "Y"
PrtStandings = (FContents$(2) = "Y")
PrtHighlights = (FContents$(3) = "Y")
PrtMain = (FContents$(4) = "Y")
RL = (FContents$(6) = "Y")
PrtFielding = (FContents$(7) = "Y")
FieldBD = (FContents$(8) = "Y")
PrtLeaders = (FContents$(9) = "Y")
CALL Stats (RTRIM$(FContents$(1)), OutFile$, PrtStandings, PrtHighlights, PrtMain, PrtFielding, PrtLeaders, VAL(FContents$(5)), RL, FieldBD)
CALL ListFile (OutFile$)
END SUB
SUB Stats (StatFile$, OutFile$, PrtStandings, PrtHighlights, PrtMain, PrtFielding, PrtLeaders, OtherAB, RL, FieldBD)
DIM SR AS StatSummary
DIM BR AS BatSummary
DIM SaveBR AS BatSummary
DIM PR AS PitSummary
DIM FR AS FldSummary
DIM QualPA AS STRING * 4
DIM QualIP AS STRING * 4
DIM SaveTeam AS STRING * 12
DIM LeagueArg AS STRING * 1
DIM NameArg AS STRING * 12
TeamsInLeagueLim = 20
DIM TeamBatSum(1 TO TeamsInLeagueLim) AS STRING
DIM TeamPitSum(1 TO TeamsInLeagueLim) AS STRING
DIM TeamFldSum(1 TO TeamsInLeagueLim) AS STRING
i = 51
REDIM SaveOther(i) AS BatSummary
COLOR deffor, defbac
CLS
IF StatFile$ < "!" THEN BEEP: EXIT SUB
i = INSTR(StatFile$, ".")
IF i > 0 THEN StatFile$ = MID$(StatFile$, 1, i - 1) ELSE StatFile$ = RTRIM$(StatFile$)
IF LEN(DIR$(StatFile$ + ".STS")) = 0 THEN
BEEP
CALL PopMsg(11, 20, "Statistics File: " + StatFile$ + ".STS not found. ", errattr, 0, kc)
CALL PopMsg(11, 12, "Please check to make sure the stat file you want exists. ", errattr, 5, kc)
EXIT SUB
END IF
IF LEN(DIR$(StatFile$ + ".STP")) THEN
CALL CheckForValidFile (StatFile$ + ".STP", 126, Valid1)
ELSE
BEEP
CALL PopMsg(MidRow, MidCol-12, "No Pitcher File Found.", errattr, 0, kc)
EXIT SUB
END IF
IF LEN(DIR$(StatFile$ + ".STB")) THEN
CALL CheckForValidFile (StatFile$ + ".STB", 162, Valid2)
ELSE
BEEP
CALL PopMsg(MidRow, MidCol-12, "No Batter File Found.", errattr, 0, kc)
EXIT SUB
END IF
IF NOT Valid1 OR NOT Valid2 THEN
BEEP
CALL PopMsg(MidRow, MidCol-24, "Sorry. Statistics File: " + StatFile$ + " is an old format. ", errattr, 0, kc)
EXIT SUB
END IF
Outdevice$ = StatFile$ + ".PRN"
CALL Drawfrm(8+rowO, 14+colO, 13+rowO, 66+colO, defattr, nulls$, nulls$, 1, 0, 0)
QPRINTs 10+rowO, 16+colO, "One moment, please.", dimattr
x$ = Outdevice$ + " being generated..."
QPRINTs 11+rowO, 16+colO, x$, dimattr
'=========== .STS Section ==============
IF STATTEAMLIMIT = 0 THEN STATTEAMLIMIT = 300 '.CMD Option
REDIM SA(STATTEAMLIMIT) AS STSAnal
STSHdl = FREEFILE
OPEN StatFile$ + ".STS" FOR RANDOM AS #STSHdl LEN = LEN(SR)
TblMax = 15 'League Leaders tables (number of players to put in each table)
TblEnd = 0 'Running count of number of teams encountered (not related to TblMax)
SumRecs = LOF(STSHdl) / LEN(SR)
EndOfFile = 0
rec = 1
GET #STSHdl,,SR
DO
IF SR.VLeague = "A" THEN SR.VLeague = "a"
LeagueArg = SR.VLeague
NameArg = SR.VNam
GOSUB SearchTable
v = ndx
SA(v).ALeague = SR.VLeague
SA(v).ADiv = SR.VDiv
SA(v).ARuns = SA(v).ARuns + SR.VRuns
SA(v).AOppRuns = SA(v).AOppRuns + SR.HRuns
SA(v).AHits = SA(v).AHits + SR.VHits
SA(v).AErrs = SA(v).AErrs + SR.VErrs
SA(v).ALOB = SA(v).ALOB + SR.VLOB
SA(v).ADP = SA(v).ADP + SR.VDPs
SA(v).AVRunsS = SA(v).AVRunsS + SR.VRuns
SA(v).AVRunsA = SA(v).AVRunsA + SR.HRuns
IF SR.HLeague = "A" THEN SR.HLeague = "a"
LeagueArg = SR.HLeague
NameArg = SR.HNam
GOSUB SearchTable
h = ndx
IF SR.HLeague = "A" THEN SR.HLeague = "a"
SA(h).ALeague = SR.HLeague
SA(h).ADiv = SR.HDiv
SA(h).ARuns = SA(h).ARuns + SR.HRuns
SA(h).AOppRuns = SA(h).AOppRuns + SR.VRuns
SA(h).AHits = SA(h).AHits + SR.HHits
SA(h).AErrs = SA(h).AErrs + SR.HErrs
SA(h).ALOB = SA(h).ALOB + SR.HLOB
SA(h).ADP = SA(h).ADP + SR.HDPs
SA(h).AHRunsS = SA(h).AHRunsS + SR.HRuns
SA(h).AHRunsA = SA(h).AHRunsA + SR.VRuns
IF SR.HRuns > SR.VRuns THEN
INCR SA(h).AWins
INCR SA(h).AHomWins
INCR SA(v).ALosses
INCR SA(v).AVisLosses
ELSE
INCR SA(v).AWins
INCR SA(v).AVisWins
INCR SA(h).ALosses
INCR SA(h).AHomLosses
END IF
INCR rec
IF rec > SumRecs THEN
EndOfFile = -1
ELSE
GET #STSHdl,,SR
END IF
LOOP UNTIL EndOfFile
CLOSE #STSHdl
' Go thru arrays to create winning array
' Figure max number of games played by a single team
MaxGamesTm = 0
FOR i = 1 TO TblEnd
xF! = SA(i).AWins / (SA(i).AWins + SA(i).ALosses)
n = xF! * 1000
xS$ = LTRIM$(STR$(n))
SA(i).APct = PADZEROS$(xS$, 4)
IF SA(i).AWins + SA(i).ALosses > MaxGamesTm THEN
MaxGamesTm = SA(i).AWins + SA(i).ALosses
END IF
NEXT
' Use these figure for qualifying B.A. and ERA stats
QualPlate = MaxGamesTm * 3.1
QualInn = MaxGamesTm
IF QualInn < 1 THEN QualInn = 1
QualPA = STR$(QualPlate)
QualIP = STR$(QualInn)
' Sort by League/Div/Pct
ARRAY SORT SA(1) FOR TblEnd, FROM 1 TO 6, DESCEND
OUTHdl = FREEFILE
OPEN Outdevice$ FOR OUTPUT AS #OUTHdl
PageNo = 1
PRINT #OUTHdl,
PRINT #OUTHdl, "SBS 4.9.3"; TAB(35); "Strategic Baseball Statistics"
PRINT #OUTHdl, "Date: "; DATE$
PRINT #OUTHdl, "Time: "; TIME$
PRINT #OUTHdl, "File: "; StatFile$
PRINT #OUTHdl,
IF PrtStandings = 0 THEN GOTO TryPrtHighlights
LeagueCtr = 0
i = 1
DO
SaveLeague$ = SA(i).ALeague
GOSUB GetLeagueName
PRINT #OutHdl,
PRINT #OUTHdl, LeagueName$
' 0 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 0 0 1 1 2 2 3 3 4
' 1 5 0 5 0 5 0 5 0 5 0 5 0 5 0 5 0 5 0 5 0 5 0 5 0 5 0
PRINT #OUTHdl, " --------- Home -------- --------- Road -------- Avg. "
PRINT #OUTHdl, "Team W L Pct GB W L RS RA W L RS RA RS RA Hits Errs LOB DP Score"
LeagueCtr = LeagueCtr + 1
LegHomWins = 0
LegHomLosses = 0
LegHomRunsS = 0
LegHomRunsA = 0
LegVisWins = 0
LegVisLosses = 0
LegVisRunsS = 0
LegVisRunsA = 0
LegRuns = 0
LegOppRuns = 0
LegHits = 0
LegErrs = 0
LegLOB = 0
LegDP = 0
LegGames = 0
DO WHILE SA(i).ALeague = SaveLeague$ AND i <= TblEnd
SaveDiv$ = SA(i).ADiv
DivName$ = SPACE$(16)
IF SaveDiv$ = "E" THEN DivName$ = "E Division"
IF SaveDiv$ = "C" THEN DivName$ = "C Division"
IF SaveDiv$ = "W" THEN DivName$ = "W Division"
PRINT #OutHdl,
PRINT #OUTHdl, DivName$
d = 1
DO WHILE SA(i).ADiv = SaveDiv$ AND SA(i).ALeague = SaveLeague$ AND i <= TblEnd
IF d = 1 THEN a = SA(i).AWins - SA(i).ALosses
Games = SA(i).AWins + SA(i).ALosses
b = SA(i).AWins - SA(i).ALosses
c = (a - b) \ 2
xF! = (a - b) / 2
IF d = 1 OR (c = 0 AND xF! < .002) THEN
GB$ = " -"
ELSEIF c < 0 THEN
GB$ = " "
ELSE
GB$ = LTRIM$(STR$(c))
END IF
IF xF! - .002 > c THEN GB$ = GB$ + ".5"
GB$ = PADLEFT$(GB$, 5)
a$ = SPACE$(139)
MID$(a$, 1, 12) = SA(i).ANam
MID$(a$, 13, 6) = LFORMAT$(SA(i).AWins, "######")
MID$(a$, 19, 6) = LFORMAT$(SA(i).ALosses, "######")
IF SA(i).APct > "0998" THEN
MID$(a$, 26, 5) = "1.000"
ELSE
MID$(a$, 27, 1) = "."
MID$(a$, 28, 3) = RIGHT$(SA(i).APct, 3)
END IF
MID$(a$, 31, 5) = GB$
MID$(a$, 36, 6) = LFORMAT$(SA(i).AHomWins, "######")
MID$(a$, 42, 6) = LFORMAT$(SA(i).AHomLosses, "######")
MID$(a$, 48, 7) = LFORMAT$(SA(i).AHRunsS, "#######")
MID$(a$, 55, 7) = LFORMAT$(SA(i).AHRunsA, "#######")
MID$(a$, 62, 6) = LFORMAT$(SA(i).AVisWins, "######")
MID$(a$, 68, 6) = LFORMAT$(SA(i).AVisLosses, "######")
MID$(a$, 74, 7) = LFORMAT$(SA(i).AVRunsS, "#######")
MID$(a$, 81, 7) = LFORMAT$(SA(i).AVRunsA, "#######")
MID$(a$, 90, 7) = LFORMAT$(SA(i).ARuns, "#######")
MID$(a$, 97, 7) = LFORMAT$(SA(i).AOppRuns, "#######")
MID$(a$,104, 7) = LFORMAT$(SA(i).AHits, "#######")
MID$(a$,111, 6) = LFORMAT$(SA(i).AErrs, "######")
MID$(a$,117, 7) = LFORMAT$(SA(i).ALOB, "#######")
MID$(a$,124, 6) = LFORMAT$(SA(i).ADP, "######")
MID$(a$,131, 4) = FFORMAT$(SA(i).ARuns / Games, "##.#")
MID$(a$,135, 1) = "-"
MID$(a$,136, 4) = LTRIM$(FFORMAT$(SA(i).AOppRuns / Games, "##.#"))
PRINT #OUTHdl, a$
LegHomWins = LegHomWins + SA(i).AHomWins
LegHomLosses = LegHomLosses + SA(i).AHomLosses
LegHomRunsS = LegHomRunsS + SA(i).AHRunsS
LegHomRunsA = LegHomRunsA + SA(i).AHRunsA
LegVisWins = LegVisWins + SA(i).AVisWins
LegVisLosses = LegVisLosses + SA(i).AVisLosses
LegVisRunsS = LegVisRunsS + SA(i).AVRunsS
LegVisRunsA = LegVisRunsA + SA(i).AVRunsA
LegRuns = LegRuns + SA(i).ARuns
LegOppRuns = LegOppRuns + SA(i).AOppRuns
LegHits = LegHits + SA(i).AHits
LegErrs = LegErrs + SA(i).AErrs
LegLOB = LegLOB + SA(i).ALOB
LegDP = LegDP + SA(i).ADP
LegGames = LegGames + Games
i = i + 1
d = d + 1
LOOP ' Division Changed
LOOP 'League Changed
'Print League Totals
a$ = SPACE$(139)
MID$(a$, 1, 28) = "League Totals"
MID$(a$, 36, 6) = LFORMAT$(LegHomWins, "######")
MID$(a$, 42, 6) = LFORMAT$(LegHomLosses, "######")
MID$(a$, 48, 7) = LFORMAT$(LegHomRunsS, "#######")
MID$(a$, 55, 7) = LFORMAT$(LegHomRunsA, "#######")
MID$(a$, 62, 6) = LFORMAT$(LegVisWins, "######")
MID$(a$, 68, 6) = LFORMAT$(LegVisLosses, "######")
MID$(a$, 74, 7) = LFORMAT$(LegVisRunsS, "#######")
MID$(a$, 81, 7) = LFORMAT$(LegVisRunsA, "#######")
MID$(a$, 90, 7) = LFORMAT$(LegRuns, "#######")
MID$(a$, 97, 7) = LFORMAT$(LegOppRuns, "#######")
MID$(a$,104, 7) = LFORMAT$(LegHits, "#######")
MID$(a$,111, 6) = LFORMAT$(LegErrs, "######")
MID$(a$,117, 7) = LFORMAT$(LegLOB, "#######")
MID$(a$,124, 6) = LFORMAT$(LegDP, "######")
MID$(a$,131, 4) = FFORMAT$(LegRuns / LegGames, "##.#")
MID$(a$,135, 1) = "-"
MID$(a$,136, 4) = LTRIM$(FFORMAT$(LegOppRuns / LegGames, "##.#"))
PRINT #OUTHdl, a$
'Add to Grand Totals
TotHomWins = TotHomWins + LegHomWins
TotHomLosses = TotHomLosses + LegHomLosses
TotHomRunsS = TotHomRunsS + LegHomRunsS
TotHomRunsA = TotHomRunsA + LegHomRunsA
TotVisWins = TotVisWins + LegVisWins
TotVisLosses = TotVisLosses + LegVisLosses
TotVisRunsS = TotVisRunsS + LegVisRunsS
TotVisRunsA = TotVisRunsA + LegVisRunsA
TotRuns = TotRuns + LegRuns
TotOppRuns = TotOppRuns + LegOppRuns
TotHits = TotHits + LegHits
TotErrs = TotErrs + LegErrs
TotLOB = TotLOB + LegLOB
TotDP = TotDP + LegDP
TotGames = TotGames + LegGames
LOOP UNTIL i > TblEnd
'Print Grand Totals
IF LeagueCtr > 1 THEN
a$ = SPACE$(139)
MID$(a$, 1, 28) = "**** Grand Totals ****"
MID$(a$, 36, 6) = LFORMAT$(TotHomWins, "######")
MID$(a$, 42, 6) = LFORMAT$(TotHomLosses, "######")
MID$(a$, 48, 7) = LFORMAT$(TotHomRunsS, "#######")
MID$(a$, 55, 7) = LFORMAT$(TotHomRunsA, "#######")
MID$(a$, 62, 6) = LFORMAT$(TotVisWins, "######")
MID$(a$, 68, 6) = LFORMAT$(TotVisLosses, "######")
MID$(a$, 74, 7) = LFORMAT$(TotVisRunsS, "#######")
MID$(a$, 81, 7) = LFORMAT$(TotVisRunsA, "#######")
MID$(a$, 90, 7) = LFORMAT$(TotRuns, "#######")
MID$(a$, 97, 7) = LFORMAT$(TotOppRuns, "#######")
MID$(a$,104, 7) = LFORMAT$(TotHits, "#######")
MID$(a$,111, 6) = LFORMAT$(TotErrs, "######")
MID$(a$,117, 7) = LFORMAT$(TotLOB, "#######")
MID$(a$,124, 6) = LFORMAT$(TotDP, "######")
MID$(a$,131, 4) = FFORMAT$(TotRuns / TotGames, "##.#")
MID$(a$,135, 1) = "-"
MID$(a$,136, 4) = LTRIM$(FFORMAT$(TotOppRuns / TotGames, "##.#"))
PRINT #OUTHdl, a$
END IF
'=========== Highlight Section ==============
TryPrtHighlights:
ERASE SA
IF PrtHighlights = 0 THEN GOTO TryPrtMain
IF LEN(DIR$(StatFile$ + ".STH")) THEN
STHHdl = FREEFILE
OPEN StatFile$ + ".STH" FOR BINARY AS #STHHdl
IF LOF(STHHdl) = 0 THEN
CLOSE #STHHdl
ELSE
CLOSE #STHHdl
PRINT #OUTHdl,
PRINT #OUTHdl, "Highlights of this Simulation"
PRINT #OUTHdl,
PRINT #OUTHdl, "Game/Event"
OPEN StatFile$ + ".STH" FOR INPUT AS #STHHdl
DO
LINE INPUT #STHHdl, rec$
PRINT #OUTHdl, rec$
LOOP WHILE NOT EOF(STHHdl)
CLOSE #STHHdl
END IF
END IF
'======= Print long batting streaks still in progress =======
PRINT #OUTHdl,
PRINT #OUTHdl, "Batting Streaks in Progress (at least 10 games)"
PRINT #OUTHdl,
STBHdl = FREEFILE
OPEN StatFile$ + ".STB" FOR RANDOM AS #STBHdl LEN = LEN(BR)
BatRecs = LOF(STBHdl) / LEN(BR)
BatRecs = BatRecs - 2 'Ignore 1st and last records
GET #STBHdl ,, BR 'Read sequentially
GET #STBHdl ,, BR 'Skip 1st record
rec = 1
i = 0
EndOfFile = 0
DO WHILE NOT EndOfFile
'Process "rec"
IF BR.BStreak > 9 THEN
PRINT #OUTHdl, BR.BTmNam; " "; BR.BNam; " "; BR.BStreak
i = -1
END IF
rec = rec + 1
IF rec > BatRecs THEN
EndOfFile = -1
ELSE
GET #STBHdl, , BR
END IF
LOOP
IF i = 0 THEN PRINT #OUTHdl, "None"
CLOSE #STBHdl
'=========== Main Batting / Pitching /Fielding Section ==============
' Both files should already be sorted by League/Team/Player
' Summarize and Print
TryPrtMain:
IF PrtMain = 0 AND PrtLeaders = 0 THEN CLOSE #OUTHdl: GOTO QuickExit
STBHdl = FREEFILE
OPEN StatFile$ + ".STB" FOR RANDOM AS #STBHdl LEN = LEN(BR)
STPHdl = FREEFILE
OPEN StatFile$ + ".STP" FOR RANDOM AS #STPHdl LEN = LEN(PR)
STFHdl = FREEFILE
OPEN StatFile$ + ".STF" FOR RANDOM AS #STFHdl LEN = LEN(FR)
BatRecs = LOF(STBHdl) / LEN(BR)
BatRecs = BatRecs - 2 'Ignore 1st and last records
GET #STBHdl ,, BR 'Read sequentially
GET #STBHdl ,, BR 'Skip 1st record
'IF CollapseYY THEN BR.BTmNam = "XX" + MID$(BR.BTmNam, 3, 10)
PitRecs = LOF(STPHdl) / LEN(PR) - 1 'Last record is ZZZZZZZ's
PRPointer = 2 'Start at 2nd record
FldRecs = LOF(STFHdl) / LEN(FR) - 1 'Last record is ZZZZZZZ's
FRPointer = 2 'Start at 2nd record
rec = 1
EndOfFile = 0
PREndOfFile = 0
FREndOfFile = 0
DO WHILE NOT EndOfFile
SaveLeague$ = BR.BLeague
GOSUB GetLeagueName
IF PrtMain THEN
GOSUB NewPage
PRINT #OUTHdl,
PRINT #OUTHdl, "League: "; LeagueName$
END IF
'League-leader value arrays
REDIM TblP1!(TblMax)
REDIM TblP2!(TblMax)
REDIM TblP3!(TblMax)
REDIM TblP4 (TblMax)
REDIM TblP5 (TblMax)
REDIM TblP6!(TblMax)
REDIM TblPAvg!(TblMax)
REDIM TblPRuns(TblMax)
REDIM TblPHits(TblMax)
REDIM TblP2B(TblMax)
REDIM TblP3B(TblMax)
REDIM TblPHR(TblMax)
REDIM TblPRBI(TblMax)
REDIM TblPBB(TblMax)
REDIM TblPSB(TblMax)
REDIM TblPInn!(TblMax)
REDIM TblPERA!(TblMax)
REDIM TblPSO(TblMax)
REDIM TblPWins(TblMax)
REDIM TblPSaves(TblMax)
'League-leader name arrays
REDIM TblP1N(TblMax) AS SortStrType
REDIM TblP2N(TblMax) AS SortStrType
REDIM TblP3N(TblMax) AS SortStrType
REDIM TblP4N(TblMax) AS SortStrType
REDIM TblP5N(TblMax) AS SortStrType
REDIM TblP6N(TblMax) AS SortStrType
REDIM TblPAvgN(TblMax) AS SortStrType
REDIM TblPRunsN(TblMax) AS SortStrType
REDIM TblPHitsN(TblMax) AS SortStrType
REDIM TblP2BN(TblMax) AS SortStrType
REDIM TblP3BN(TblMax) AS SortStrType
REDIM TblPHRN(TblMax) AS SortStrType
REDIM TblPRBIN(TblMax) AS SortStrType
REDIM TblPBBN(TblMax) AS SortStrType
REDIM TblPSBN(TblMax) AS SortStrType
REDIM TblPInnN(TblMax) AS SortStrType
REDIM TblPERAN(TblMax) AS SortStrType
REDIM TblPSON(TblMax) AS SortStrType
REDIM TblPWinsN(TblMax) AS SortStrType
REDIM TblPSavesN(TblMax) AS SortStrType
FOR i = 1 TO TblMax: TblPERA!(i) = 99999.99: NEXT
FOR i = 1 TO TblMax: TblP6!(i) = 99999.99: NEXT
LegBGames = 0
LegBAB = 0
LegBRuns = 0
LegBHits = 0
LegB2B = 0
LegB3B = 0
LegBHR = 0
LegBRBI = 0
LegBBB = 0
LegBSO = 0
LegBSB = 0
LegBCS = 0
LegBERRs = 0
LegBHB = 0
LegBGDP = 0
LegBSacF = 0
LegBSacB = 0
LegPCG = 0
LegPShO = 0
LegPInn = 0
LegP3rds = 0
LegPRuns = 0
LegPERuns = 0
LegPHits = 0
LegPHR = 0
LegPBB = 0
LegPSO = 0
LegPHB = 0
LegPBF = 0
LegFErr = 0
LegFAss = 0
LegFPOs = 0
tdx = 0
DO WHILE BR.BLeague = SaveLeague$ AND NOT EndOfFile
TmGames = 0
TmAB = 0
TmRuns = 0
TmHits = 0
Tm2B = 0
Tm3B = 0
TmHR = 0
TmRBI = 0
TmBB = 0
TmSO = 0
TmSB = 0
TmCS = 0
TmERRs = 0
TmHB = 0
TmGDP = 0
TmSacF = 0
TmSacB = 0
octr = 0
SaveTeam = BR.BTmNam
IF PrtMain THEN
PRINT #OUTHdl,
PRINT #OUTHdl,
xS$ = RTRIM$(UCASE$(BR.BTmNam)) + " "
PRINT #OUTHdl, xS$ + STRING$(181 - LEN(xS$), "-")
PRINT #OUTHdl,
PRINT #OUTHdl, "Batting"
PRINT #OUTHdl,
PRINT #OUTHdl, "Name Avg G AB Runs Hits TB 2B 3B HR RBI SH SF HB BB SO SB CS SB% GIDP ERR OB Slg HR OPS TAvg RC/27"
END IF
DO WHILE SaveTeam = BR.BTmNam AND SaveLeague$ = BR.BLeague AND NOT EndOfFile
IF rec = 32767 THEN
EndOfFile = -1
EXIT DO
END IF
IF BR.BABs >= OtherAB THEN
GOSUB PrintDetail
ELSE
INCR octr
SaveOther(octr) = BR 'save record in array
END IF
'Throw stuff into the "Leader Lists"
IF PAvg! > TblPAvg!(TblMax) AND BR.BABs + BR.BBBs + BR.BHB >= QualPlate THEN
TblPAvg!(TblMax) = PAvg!
TblPAvgN(TblMax).SSItem = SaveTeam + " " + BR.BNam
CALL BubbleSortFlt(TblPAvg!(), TblPAvgN(), "D")
END IF
IF BR.BRuns > TblPRuns(TblMax) THEN
TblPRuns(TblMax) = BR.BRuns
TblPRunsN(TblMax).SSItem = SaveTeam + " " + BR.BNam
CALL BubbleSortInt(TblPRuns(), TblPRunsN())
END IF
IF BR.BHits > TblPHits(TblMax) THEN
TblPHits(TblMax) = BR.BHits
TblPHitsN(TblMax).SSItem = SaveTeam + " " + BR.BNam
CALL BubbleSortInt(TblPHits(), TblPHitsN())
END IF
IF BR.B2Bs > TblP2B(TblMax) THEN
TblP2B(TblMax) = BR.B2Bs
TblP2BN(TblMax).SSItem = SaveTeam + " " + BR.BNam
CALL BubbleSortInt(TblP2B(), TblP2BN())
END IF
IF BR.B3Bs > TblP3B(TblMax) THEN
TblP3B(TblMax) = BR.B3Bs
TblP3BN(TblMax).SSItem = SaveTeam + " " + BR.BNam
CALL BubbleSortInt(TblP3B(), TblP3BN())
END IF
IF BR.BHRs > TblPHR(TblMax) THEN
TblPHR(TblMax) = BR.BHRs
TblPHRN(TblMax).SSItem = SaveTeam + " " + BR.BNam
CALL BubbleSortInt(TblPHR(), TblPHRN())
END IF
IF BR.BRBIs > TblPRBI(TblMax) THEN
TblPRBI(TblMax) = BR.BRBIs
TblPRBIN(TblMax).SSItem = SaveTeam + " " + BR.BNam
CALL BubbleSortInt(TblPRBI(), TblPRBIN())
END IF
IF BR.BBBs > TblPBB(TblMax) THEN
TblPBB(TblMax) = BR.BBBs
TblPBBN(TblMax).SSItem = SaveTeam + " " + BR.BNam
CALL BubbleSortInt(TblPBB(), TblPBBN())
END IF
IF BR.BSBs > TblPSB(TblMax) THEN
TblPSB(TblMax) = BR.BSBs
TblPSBN(TblMax).SSItem = SaveTeam + " " + BR.BNam
CALL BubbleSortInt(TblPSB(), TblPSBN())
END IF
IF rc27! > TblP1!(TblMax) AND BR.BABs + BR.BBBs + BR.BHB >= QualPlate THEN
TblP1!(TblMax) = rc27!
TblP1N(TblMax).SSItem = SaveTeam + " " + BR.BNam
CALL BubbleSortFlt(TblP1!(), TblP1N(), "D")
END IF
IF OnBase! > TblP2!(TblMax) AND BR.BABs + BR.BBBs + BR.BHB >= QualPlate THEN
TblP2!(TblMax) = OnBase!
TblP2N(TblMax).SSItem = SaveTeam + " " + BR.BNam
CALL BubbleSortFlt(TblP2!(), TblP2N(), "D")
END IF
IF slug! > TblP3!(TblMax) AND BR.BABs + BR.BBBs + BR.BHB >= QualPlate THEN
TblP3!(TblMax) = slug!
TblP3N(TblMax).SSItem = SaveTeam + " " + BR.BNam
CALL BubbleSortFlt(TblP3!(), TblP3N(), "D")
END IF
TmAB = TmAB + BR.BABs
TmRuns = TmRuns + BR.BRuns
TmHits = TmHits + BR.BHits
Tm2B = Tm2B + BR.B2Bs
Tm3B = Tm3B + BR.B3Bs
TmHR = TmHR + BR.BHRs
TmRBI = TmRBI + BR.BRBIs
TmBB = TmBB + BR.BBBs
TmSO = TmSO + BR.BKs
TmSB = TmSB + BR.BSBs
TmCS = TmCS + BR.BCSs
TmERRs = TmERRs + BR.BERRs
TmHB = TmHB + BR.BHB
TmGDP = TmGDP + BR.BGDP
TmSacF = TmSacF + BR.BSacF
TmSacB = TmSacB + BR.BSacB
INCR rec
IF rec > BatRecs THEN
EndOfFile = -1
ELSE
GET #STBHdl, , BR
'IF CollapseYY THEN BR.BTmNam = "XX" + MID$(BR.BTmNam, 3, 10)
END IF
IF INKEY$ = CHR$(27) THEN
PRINT
PRINT "Report Aborted!"
EndOfFile = -1
END IF
LOOP
'Team changed
'Sum the "Other" array
OABs = 0
OGames = 0
ORuns = 0
OHits = 0
ORBIs = 0
O2Bs = 0
O3Bs = 0
OHRs = 0
OSBs = 0
OCSs = 0
OBBs = 0
OKs = 0
OErrs = 0
OHB = 0
OGDP = 0
OSacF = 0
OSacB = 0
FOR i = 1 TO octr
OABs = OABs + SaveOther(i).BABs
OGames = OGames + SaveOther(i).BGames
ORuns = ORuns + SaveOther(i).BRuns
OHits = OHits + SaveOther(i).BHits
ORBIs = ORBIs + SaveOther(i).BRBIs
O2Bs = O2Bs + SaveOther(i).B2Bs
O3Bs = O3Bs + SaveOther(i).B3Bs
OHRs = OHRs + SaveOther(i).BHRs
OSBs = OSBs + SaveOther(i).BSBs
OCSs = OCSs + SaveOther(i).BCSs
OBBs = OBBs + SaveOther(i).BBBs
OKs = OKs + SaveOther(i).BKs
OErrs = OErrs + SaveOther(i).BErrs
OHB = OHB + SaveOther(i).BHB
OGDP = OGDP + SaveOther(i).BGDP
OSacF = OSacF + SaveOther(i).BSacF
OSacB = OSacB + SaveOther(i).BSacB
NEXT
IF octr > 0 THEN
SaveBR = BR
BR.BNam = "[Other]"
BR.BTmNam = ""
BR.BLeague = ""
BR.BABs = OABs
BR.BGames = 0
BR.BRuns = ORuns
BR.BHits = OHits
BR.BRBIs = ORBIs
BR.B2Bs = O2Bs
BR.B3Bs = O3Bs
BR.BHRs = OHRs
BR.BSBs = OSBs
BR.BCSs = OCSs
BR.BBBs = OBBs
BR.BKs = OKs
BR.BErrs = OErrs
BR.BHB = OHB
BR.BGDP = OGDP
BR.BSacF = OSacF
BR.BSacB = OSacB
GOSUB PrintDetail
BR = SaveBR
END IF
'Print TEAM BATTING TOTALS
IF TmAB <> 0 THEN TmAvg! = TmHits / TmAB ELSE TmAvg! = 0
'Expanded team batting statistics
TB = TmHits + Tm2B + 2 * Tm3B + 3 * TmHR
IF TmAB > 0 THEN
Slug! = TB / TmAB
ELSE
Slug! = 0.
END IF
IF TmAB > 0 THEN
HRPct! = TmHR / TmAB * 100
ELSE
HRPct! = 0.
END IF
IF TmAB > 0 THEN
OnBase! = (TmBB + TmHB + TmHits) / (TmBB + TmHB + TmAB)
ELSE
OnBase! = 0.
END IF
Prod! = OnBase! + Slug!
IF TmSB <> 0 THEN
Rate! = TmSB / (TmSB + TmCS) * 100
ELSE
Rate! = 0.
END IF
IF (TmCS + TmAB - TmHits) > 0 THEN
TotAvg! = (TB + TmSB + TmBB + TmHB) / (TmCS + TmAB - TmHits)
ELSE
TotAvg! = 0.
END IF
rc27! = RunsCreated27!(TmAB, TmHits, Tm2B, Tm3B, TmHR, TmBB, TmHB, TmSacB, TmSacF, TmSB, TmCS, TmGDP)
IF PrtMain THEN
'Name Avg AB Runs Hits TB 2B 3B HR RBI SH SF HB BB SO SB CS SB% GIDP ERR OB Slg HR OPS TAvg RC/27
' .#### ###### ###### ###### ###### ##### ##### ###### ###### ##### ##### ##### ###### ###### ##### ##### ###.# ##### ##### #.### #.### ##.# #.### #.### ##.##
a$ = SPACE$(185)
MID$(a$, 1, 15) = "TEAM TOTALS:"
MID$(a$, 20, 5) = FFORMAT$(TmAvg!, ".####")
MID$(a$, 31, 7) = LFORMAT$(TmAB, "#######")
MID$(a$, 38, 7) = LFORMAT$(TmRuns, "#######")
MID$(a$, 45, 7) = LFORMAT$(TmHits, "#######")
MID$(a$, 52, 7) = LFORMAT$(TB, "#######")
MID$(a$, 59, 6) = LFORMAT$(Tm2B, "######")
MID$(a$, 65, 6) = LFORMAT$(Tm3B, "######")
MID$(a$, 71, 7) = LFORMAT$(TmHR, "#######")
MID$(a$, 78, 7) = LFORMAT$(TmRBI, "#######")
MID$(a$, 85, 6) = LFORMAT$(TmSacB, "######")
MID$(a$, 91, 6) = LFORMAT$(TmSacF, "######")
MID$(a$, 97, 6) = LFORMAT$(TmHB, "######")
MID$(a$,103, 7) = LFORMAT$(TmBB, "#######")
MID$(a$,110, 7) = LFORMAT$(TmSO, "#######")
MID$(a$,117, 6) = LFORMAT$(TmSB, "######")
MID$(a$,123, 6) = LFORMAT$(TmCS, "######")
MID$(a$,130, 5) = FFORMAT$(Rate!, "##0.#")
MID$(a$,135, 6) = LFORMAT$(TmGDP, "######")
MID$(a$,141, 6) = LFORMAT$(TmERRs, "######")
MID$(a$,148, 5) = FFORMAT$(Onbase!, "#.###")
MID$(a$,154, 5) = FFORMAT$(Slug!, "#.###")
MID$(a$,160, 4) = FFORMAT$(HRPct!, "#0.#")
MID$(a$,165, 5) = FFORMAT$(Prod!, "#.###")
MID$(a$,171, 5) = FFORMAT$(TotAvg!, "#.###")
MID$(a$,177, 5) = FFORMAT$(rc27!, "#0.##")
GOSUB StripNulls
PRINT #OUTHdl, a$
IF tdx < TeamsInLeagueLim THEN
INCR tdx
MID$(a$, 1, 15) = SaveTeam
TeamBatSum(tdx) = a$
END IF
END IF
LegBAB = LegBAB + TmAB
LegBRuns = LegBRuns + TmRuns
LegBHits = LegBHits + TmHits
LegB2B = LegB2B + Tm2B
LegB3B = LegB3B + Tm3B
LegBHR = LegBHR + TmHR
LegBRBI = LegBRBI + TmRBI
LegBBB = LegBBB + TmBB
LegBSO = LegBSO + TmSO
LegBSB = LegBSB + TmSB
LegBCS = LegBCS + TmCS
LegBERRs = LegBERRs + TmERRs
LegBHB = LegBHB + TmHB
LegBGDP = LegBGDP + TmGDP
LegBSacF = LegBSacF + TmSacF
LegBSacB = LegBSacB + TmSacB
'Print TEAM PITCHING -----------------------------------
'Goto first record for this team in the pitching file
GET #STPHdl, PRpointer, PR
IF PR.PTmNam <> SaveTeam OR PR.PLeague <> SaveLeague$ THEN
PRINT #OUTHdl, "File Synchronization Problem"
END IF
TmCG = 0
TmShO = 0
TmInn = 0
Tm3rds = 0
TmRuns = 0
TmERuns = 0
TmHits = 0
Tm2b = 0
Tm3b = 0
TmHR = 0
TmBB = 0
TmSO = 0
TmWin = 0
TmLoss = 0
TmSave = 0
TmBSave = 0
TmPHB = 0
TmPBF = 0
IF PrtMain THEN
PRINT #OUTHdl,
PRINT #OUTHdl, "Pitching"
PRINT #OUTHdl, " Opp Opp Opp Opp"
PRINT #OUTHdl, "Name W L S BS ERA G GS CG ShO Inns Hits Runs ERun HR HB BB SO SO/9 Avg Slg OB OPS"
END IF
SaveTeam = PR.PTmNam
DO WHILE PR.PTmNam = SaveTeam AND SaveLeague$ = PR.PLeague AND NOT PREndOfFile
Inns! = PR.PInns + PR.P3rds / 3
IF Inns! < .1 THEN Inns! = .1
PERA! = PR.PERuns / Inns! * 9!
IF PERA! > 99.99 THEN PERA! = 99.99
'Expanded individual pitching statistics
TB = PR.PHits + PR.P2Bs + 2 * PR.P3Bs + 3 * PR.PHRs
IF (PR.PBF - PR.PBBs - PR.PHB) > 0 THEN
Avg! = PR.PHits / (PR.PBF - PR.PBBs - PR.PHB)
Slug! = TB / (PR.PBF - PR.PBBs - PR.PHB)
ELSE
Avg! = 0.
Slug! = 0.
END IF
IF PR.PBF > 0 THEN
OnBase! = (PR.PBBs + PR.PHB + PR.PHits) / PR.PBF
ELSE
OnBase! = 0.
END IF
Prod! = OnBase! + Slug!
SO9! = PR.PSOs / (Inns! / 9.)
xS$ = LEFT$(PR.PNam, 15)
i = INSTR(PR.PNam, ",")
IF i > 0 THEN yS$ = MID$(PR.PNam, 1, i - 1) ELSE yS$ = xS$
IF PrtMain THEN
'ame W L S BS ERA G GS CG ShO Inns Hits Runs ERun HR HB BB SO SO/9 Avg Slg OB OPS
' \ ##### ##### ##### #### ##.### ##### ##### ##### #### ######.# ###### ###### ###### ###### ##### ###### ###### ##.## #.### #.### #.### #.### \ \
a$ = SPACE$(175)
MID$(a$, 1, 15) = xS$
MID$(a$, 17, 1) = PR.PThrows
MID$(a$, 18, 5) = LFORMAT$(PR.PWin, "#####")
MID$(a$, 24, 5) = LFORMAT$(PR.PLoss, "#####")
MID$(a$, 30, 5) = LFORMAT$(PR.PSave, "#####")
MID$(a$, 36, 4) = LFORMAT$(PR.PBS, "####")
MID$(a$, 41, 6) = FFORMAT$(PERA!, "#0.###")
MID$(a$, 48, 5) = LFORMAT$(PR.PGames, "#####")
MID$(a$, 54, 5) = LFORMAT$(PR.PStarts,"#####")
MID$(a$, 60, 5) = LFORMAT$(PR.PCGs, "#####")
MID$(a$, 66, 4) = LFORMAT$(PR.PShOs, "####")
IF Inns! < .3 THEN InnsX! = 0.0 ELSE InnsX! = Inns!
MID$(a$, 71, 8) = FFORMAT$(InnsX!, "######.#")
MID$(a$, 80, 6) = LFORMAT$(PR.PHits, "######")
MID$(a$, 87, 6) = LFORMAT$(PR.PRuns, "######")
MID$(a$, 94, 6) = LFORMAT$(PR.PERuns, "######")
MID$(a$,101, 6) = LFORMAT$(PR.PHRs, "######")
MID$(a$,108, 5) = LFORMAT$(PR.PHB, "#####")
MID$(a$,114, 6) = LFORMAT$(PR.PBBs, "######")
MID$(a$,121, 6) = LFORMAT$(PR.PSOs, "######")
MID$(a$,128, 5) = FFORMAT$(SO9!, "#0.##")
MID$(a$,134, 5) = FFORMAT$(Avg!, "#.###")
MID$(a$,140, 5) = FFORMAT$(Slug!, "#.###")
MID$(a$,146, 5) = FFORMAT$(Onbase!, "#.###")
MID$(a$,152, 5) = FFORMAT$(Prod!, "#.###")
MID$(a$,158, 15) = yS$
GOSUB StripNulls
PRINT #OUTHdl, a$
END IF
'Throw stuff into the Pitcher "Leader Lists"
IF PERA! < TblPERA!(TblMax) AND Inns! >= CSNG(QualInn) THEN
TblPERA!(TblMax) = PERA!
TblPERAN(TblMax).SSItem = SaveTeam + " " + PR.PNam
CALL BubbleSortFlt(TblPERA!(), TblPERAN(), "A")
END IF
IF Inns! > TblPInn!(TblMax) THEN
TblPInn!(TblMax) = Inns!
TblPInnN(TblMax).SSItem = SaveTeam + " " + PR.PNam
CALL BubbleSortFlt(TblPInn!(), TblPInnN(), "D")
END IF
IF PR.PWin > TblPWins(TblMax) THEN
TblPWins(TblMax) = PR.PWin
TblPWinsN(TblMax).SSItem = SaveTeam + " " + PR.PNam
CALL BubbleSortInt(TblPWins(), TblPWinsN())
END IF
IF PR.PSave > TblPSaves(TblMax) THEN
TblPSaves(TblMax) = PR.PSave
TblPSavesN(TblMax).SSItem = SaveTeam + " " + PR.PNam
CALL BubbleSortInt(TblPSaves(), TblPSavesN())
END IF
IF PR.PSOs > TblPSO(TblMax) THEN
TblPSO(TblMax) = PR.PSOs
TblPSON(TblMax).SSItem = SaveTeam + " " + PR.PNam
CALL BubbleSortInt(TblPSO(), TblPSON())
END IF
IF PR.PCGs > TblP4(TblMax) THEN
TblP4(TblMax) = PR.PCGs
TblP4N(TblMax).SSItem = SaveTeam + " " + PR.PNam
CALL BubbleSortInt(TblP4(), TblP4N())
END IF
IF PR.PShOs > TblP5(TblMax) THEN
TblP5(TblMax) = PR.PShOs
TblP5N(TblMax).SSItem = SaveTeam + " " + PR.PNam
CALL BubbleSortInt(TblP5(), TblP5N())
END IF
IF Prod! < TblP6!(TblMax) AND Inns! >= CSNG(QualInn) THEN
TblP6!(TblMax) = Prod!
TblP6N(TblMax).SSItem = SaveTeam + " " + PR.PNam
CALL BubbleSortFlt(TblP6!(), TblP6N(), "A")
END IF
TmCG = TmCG + PR.PCGs
TmShO = TmShO + PR.PShOs
TmInn = TmInn + PR.PInns
Tm3rds = Tm3rds + PR.P3rds
TmRuns = TmRuns + PR.PRuns
TmERuns = TmERuns + PR.PERuns
TmHits = TmHits + PR.PHits
Tm2B = Tm2B + PR.P2Bs
Tm3B = Tm3B + PR.P3Bs
TmHR = TmHR + PR.PHRs
TmBB = TmBB + PR.PBBs
TmSO = TmSO + PR.PSOs
TmWin = TmWin + PR.PWin
TmLoss = TmLoss + PR.PLoss
TmSave = TmSave + PR.PSave
TmBSave = TmBSave + PR.PBS
TmPHB = TmPHB + PR.PHB
TmPBF = TmPBF + PR.PBF
PRPointer = PRPointer + 1
IF PRPointer > PitRecs THEN
PREndOfFile = -1
ELSE
GET #STPHdl, PRPointer, PR
END IF
LOOP
'Print TEAM PITCHING TOTALS
Inns! = TmInn + Tm3rds / 3
IF Inns! = 0 THEN Inns! = .33
PERA! = TmERuns / Inns! * 9!
IF PERA! > 99.99 THEN PERA! = 99.99
'Expanded team pitching statistics
'Old Way
'Avg! = TmHits / (.955 * (Inns! * 3 + TmHits))
'Slug! = TB / (.955 * (Inns! * 3 + TmHits))
'OnBase! = (TmBB + TmPHB + TmHits) / (.955 * (TmBB + TmPHB + Inns! * 3 + TmHits))
TB = TmHits + Tm2b + 2 * Tm3b + 3 * TmHR
IF (TmPBF - TmBB - TmPHB) > 0 THEN
Avg! = TmHits / (TmPBF - TmBB - TmPHB)
Slug! = TB / (TmPBF - TmBB - TmPHB)
ELSE
Avg! = 0.
Slug! = 0.
END IF
IF TmPBF > 0 THEN
OnBase! = (TmBB + TmPHB + TmHits) / TmPBF
ELSE
OnBase! = 0.
END IF
Prod! = OnBase! + Slug!
SO9! = TmSO / (Inns! / 9.)
IF PrtMain THEN
'ame W L S BS ERA G GS CG ShO Inns Hits Runs ERun HR HB BB SO SO/9 Avg Slg OB OPS
' \ ##### ##### ##### #### ##.### ##### ##### ##### #### ######.# ###### ###### ###### ###### ##### ###### ###### ##.## #.### #.### #.### #.###
a$ = SPACE$(175)
MID$(a$, 1, 15) = "TEAM TOTALS:"
MID$(a$, 17, 6) = LFORMAT$(TmWin, "######")
MID$(a$, 23, 6) = LFORMAT$(TmLoss, "######")
MID$(a$, 29, 6) = LFORMAT$(TmSave, "######")
MID$(a$, 35, 5) = LFORMAT$(TmBSave, "#####")
MID$(a$, 41, 6) = FFORMAT$(PERA!, "#0.###")
MID$(a$, 59, 6) = LFORMAT$(TmCG, "######")
MID$(a$, 65, 5) = LFORMAT$(TmShO, "#####")
MID$(a$, 70, 9) = FFORMAT$(Inns!, "#######.#")
MID$(a$, 79, 7) = LFORMAT$(TmHits, "#######")
MID$(a$, 86, 7) = LFORMAT$(TmRuns, "#######")
MID$(a$, 93, 7) = LFORMAT$(TmERuns, "#######")
MID$(a$,100, 7) = LFORMAT$(TmHR, "#######")
MID$(a$,107, 6) = LFORMAT$(TmPHB, "######")
MID$(a$,113, 7) = LFORMAT$(TmBB, "#######")
MID$(a$,120, 7) = LFORMAT$(TmSO, "#######")
MID$(a$,128, 5) = FFORMAT$(SO9!, "#0.##")
MID$(a$,134, 5) = FFORMAT$(Avg!, "#.###")
MID$(a$,140, 5) = FFORMAT$(Slug!, "#.###")
MID$(a$,146, 5) = FFORMAT$(Onbase!, "#.###")
MID$(a$,152, 5) = FFORMAT$(Prod!, "#.###")
GOSUB StripNulls
PRINT #OUTHdl, a$
IF tdx < TeamsInLeagueLim THEN
MID$(a$, 1, 15) = SaveTeam
TeamPitSum(tdx) = a$
END IF
END IF
LegPCG = LegPCG + TmCG
LegPShO = LegPShO + TmShO
LegPInn = LegPInn + TmInn
LegP3rds = LegP3rds + Tm3rds
LegPRuns = LegPRuns + TmRuns
LegPERuns = LegPERuns + TmERuns
LegPHits = LegPHits + TmHits
LegP2B = LegP2B + Tm2b
LegP3B = LegP3B + Tm3b
LegPHR = LegPHR + TmHR
LegPBB = LegPBB + TmBB
LegPSO = LegPSO + TmSO
LegPHB = LegPHB + TmPHB
LegPBF = LegPBF + TmPBF
'Print TEAM FIELDING -------------------------------------
'Goto first record for this team in the fielding file
GET #STFHdl, FRpointer, FR
IF FR.FTmNam <> SaveTeam OR FR.FLeague <> SaveLeague$ THEN
PRINT #OUTHdl, "File Synchronization Problem"
END IF
TmFErr = 0
TmFAss = 0
TmFPOs = 0
IF PrtMain AND PrtFielding THEN
PRINT #OUTHdl,
PRINT #OUTHdl, "Fielding"
PRINT #OUTHdl,
PRINT #OUTHdl, " Games-By-Position"
'old PRINT #OUTHdl, "Name Tot P C 1B 2B 3B SS LF CF RF DH Errs Assts POs Pct%"
PRINT #OUTHdl, "Name Tot P C 1B 2B 3B SS LF CF RF DH Errors Assts POs Pct%"
END IF
SaveTeam = FR.FTmNam
DO WHILE FR.FTmNam = SaveTeam AND SaveLeague$ = FR.FLeague AND NOT FREndOfFile
xS$ = LEFT$(FR.FNam, 15)
i = INSTR(FR.FNam, ",")
IF i > 0 THEN yS$ = MID$(FR.FNam, 1, i - 1) ELSE yS$ = xS$
IF PrtMain AND PrtFielding THEN
'ame Tot P C 1B 2B 3B SS LF CF RF DH Errors Assts POs Pct%"
' \ ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ####### ####### ####### #.###
a$ = SPACE$(143)
MID$(a$, 1, 15) = xS$
MID$(a$, 17, 6) = LFORMAT$(FR.FCount, "######")
ee = 0
ai = 0
po = 0
FOR i = 1 TO 10
IF FR.FGamesByPos(i) > 0 THEN
MID$(a$, (7*i + 17), 6) = LFORMAT$(FR.FGamesByPos(i), "######")
ELSE
MID$(a$, (7*i + 22), 1) = "-"
END IF
ee = ee + FR.FErrsByPos(i)
ai = ai + FR.FAssistsByPos(i)
po = po + FR.FPutOutsByPos(i)
NEXT
MID$(a$, 96, 7) = LFORMAT$(ee, "#######")
MID$(a$,104, 7) = LFORMAT$(ai, "#######")
MID$(a$,112, 7) = LFORMAT$(po, "#######")
IF ee + ai + po > 0 THEN
dpct! = (ai + po) / (ee + ai + po)
ELSE
dpct! = 1.000
END IF
MID$(a$,120, 6) = FFORMAT$(dpct!, "#.####")
MID$(a$,128, 15) = yS$
PRINT #OUTHdl, a$
'Add to team totals
TmFErr = TmFErr + ee
TmFAss = TmFAss + ai
TmFPOs = TmFPOs + po
IF FieldBD THEN
'Count how many positions were played (pp) and
'store what the were - ignore DH
REDIM plist(9) AS INTEGER
pp = 0
FOR p = 1 TO 9
IF FR.FGamesByPos(p) > 0 THEN
INCR pp
plist(pp) = p
END IF
NEXT
'Break out individual positions
IF pp > 1 THEN
FOR i = 1 TO pp
p = plist(i)
' a$ = SPACE$(115)
' MID$(a$, 4, 3) = Pos(p)
' MID$(a$, (5*p + 17), 4) = LFORMAT$(FR.FGamesByPos(p), "####")
' MID$(a$, 74, 5) = LFORMAT$(FR.FErrsByPos(p), "#####")
' MID$(a$, 80, 5) = LFORMAT$(FR.FAssistsByPos(p),"#####")
' MID$(a$, 86, 5) = LFORMAT$(FR.FPutOutsByPos(p),"#####")
a$ = SPACE$(126)
MID$(a$, 4, 3) = Pos(p)
MID$(a$, (7*p + 17), 6) = LFORMAT$(FR.FGamesByPos(p), "######")
MID$(a$, 96, 7) = LFORMAT$(FR.FErrsByPos(p), "#######")
MID$(a$,104, 7) = LFORMAT$(FR.FAssistsByPos(p),"#######")
MID$(a$,112, 7) = LFORMAT$(FR.FPutOutsByPos(p),"#######")
ee = FR.FErrsByPos(p)
ai = FR.FAssistsByPos(p)
po = FR.FPutOutsByPos(p)
IF ee + ai + po > 0 THEN
dpct! = (ai + po) / (ee + ai + po)
ELSE
dpct! = 1.000
END IF
' MID$(a$, 92, 5) = FFORMAT$(dpct!, "#.###")
MID$(a$,120, 6) = FFORMAT$(dpct!, "#.####")
PRINT #OUTHdl, a$
NEXT
END IF
END IF
END IF
'Throw stuff into the Fielding "Leader Lists"
FRPointer = FRPointer + 1
IF FRPointer > FldRecs THEN
FREndOfFile = -1
ELSE
GET #STFHdl, FRPointer, FR
END IF
LOOP
'Print TEAM FIELDING TOTALS
IF PrtMain AND PrtFielding THEN
a$ = SPACE$(143)
MID$(a$, 1, 15) = "TEAM TOTALS:"
' MID$(a$, 74, 5) = LFORMAT$(TmFErr, "#####")
' MID$(a$, 80, 5) = LFORMAT$(TmFAss, "#####")
' MID$(a$, 86, 5) = LFORMAT$(TmFPOs, "#####")
MID$(a$, 96, 7) = LFORMAT$(TmFErr, "#######")
MID$(a$,104, 7) = LFORMAT$(TmFAss, "#######")
MID$(a$,112, 7) = LFORMAT$(TmFPOs, "#######")
ee = TmFErr
ai = TmFAss
po = TmFPOs
IF ee + ai + po > 0 THEN
dpct! = (ai + po) / (ee + ai + po)
ELSE
dpct! = 1.000
END IF
' MID$(a$, 92, 6) = FFORMAT$(dpct!, "#.####")
MID$(a$,120, 6) = FFORMAT$(dpct!, "#.####")
PRINT #OUTHdl, a$
IF tdx < TeamsInLeagueLim THEN
z$ = SPACE$(46)
MID$(z$, 1, 15) = SaveTeam
' MID$(z$, 17, 24) = MID$(a$, 74, 24)
MID$(z$, 17, 30) = MID$(a$, 96, 30)
TeamFldSum(tdx) = z$
END IF
END IF
LegFErr = LegFErr + TmFErr
LegFAss = LegFAss + TmFAss
LegFPOs = LegFPOs + TmFPOs
LOOP
'League Changed
'Print League BATTING Totals
PRINT #OUTHdl,
PRINT #OUTHdl,
PRINT #OUTHdl,
PRINT #OUTHdl, "LEAGUE BATTING SUMMARY BY TEAM"
PRINT #OUTHdl,
'oldPRINT #OUTHdl, "Team Avg AB Runs Hits TB 2B 3B HR RBI SH SF HB BB SO SB CS SB% GIDP ERR OB Slg HR% OPS TAvg RC/27"
PRINT #OUTHdl, "Team Avg AB Runs Hits TB 2B 3B HR RBI SH SF HB BB SO SB CS SB% GIDP ERR OB Slg HR OPS TAvg RC/27"
ARRAY SORT TeamBatSum() FOR tdx, FROM 39 TO 44, DESCEND
FOR i = 1 TO tdx
x$ = TeamBatSum(i)
PRINT #OUTHdl, x$
NEXT
IF LegBAB <> 0 THEN LegAvg! = LegBHits / LegBAB ELSE LegAvg! = 0
'Expanded league BATTING statistics
TB = LegBHits + LegB2B + 2 * LegB3B + 3 * LegBHR
IF LegBAB > 0 THEN
Slug! = TB / LegBAB
ELSE
Slug! = 0.
END IF
IF LegBAB > 0 THEN
HRPct! = LegBHR / LegBAB * 100
ELSE
HRPct! = 0.
END IF
IF LegBAB > 0 THEN
OnBase! = (LegBBB + LegBHB + LegBHits) / (LegBBB + LegBHB + LegBAB)
ELSE
OnBase! = 0.
END IF
Prod! = OnBase! + Slug!
IF LegBSB <> 0 THEN
Rate! = LegBSB / (LegBSB + LegBCS) * 100
ELSE
Rate! = 0.
END IF
IF (LegBCS + LegBAB - LegBHits) > 0 THEN
TotAvg! = (TB + LegBSB + LegBBB + LegBHB) / (LegBCS + LegBAB - LegBHits)
ELSE
TotAvg! = 0.
END IF
rc27! = RunsCreated27!(LegBAB, LegBHits, LegB2B, LegB3B, LegBHR, LegBBB, LegBHB, LegBSacB, LegBSacF, LegBSB, LegBCS, LegBGDP)
IF PrtMain THEN
PRINT #OUTHdl,
a$ = SPACE$(185)
MID$(a$, 1, 12) = "LEAGUE BAT.:"
MID$(a$, 14, 1) = SaveLeague$
MID$(a$, 20, 5) = FFORMAT$(LegAvg!, ".####")
MID$(a$, 30, 8) = LFORMAT$(LegBAB, "########")
MID$(a$, 38, 7) = LFORMAT$(LegBRuns,"#######")
MID$(a$, 45, 7) = LFORMAT$(LegBHits,"#######")
MID$(a$, 52, 7) = LFORMAT$(TB, "#######")
MID$(a$, 59, 6) = LFORMAT$(LegB2B, "######")
MID$(a$, 65, 6) = LFORMAT$(LegB3B, "######")
MID$(a$, 71, 7) = LFORMAT$(LegBHR, "#######")
MID$(a$, 78, 7) = LFORMAT$(LegBRBI, "#######")
MID$(a$, 85, 6) = LFORMAT$(LegBSacB, "######")
MID$(a$, 91, 6) = LFORMAT$(LegBSacF, "######")
MID$(a$, 97, 6) = LFORMAT$(LegBHB, "######")
MID$(a$, 103, 7) = LFORMAT$(LegBBB, "#######")
MID$(a$, 110, 7) = LFORMAT$(LegBSO, "#######")
MID$(a$, 117, 6) = LFORMAT$(LegBSB, "######")
MID$(a$, 123, 6) = LFORMAT$(LegBCS, "######")
MID$(a$, 130, 5) = FFORMAT$(Rate!, "##0.#")
MID$(a$, 135, 6) = LFORMAT$(LegBGDP, "######")
MID$(a$, 141, 6) = LFORMAT$(LegBERRs, "######")
MID$(a$, 148, 5) = FFORMAT$(Onbase!, "#.###")
MID$(a$, 154, 5) = FFORMAT$(Slug!, "#.###")
MID$(a$, 160, 4) = FFORMAT$(HRPct!, "#0.#")
MID$(a$, 165, 5) = FFORMAT$(Prod!, "#.###")
MID$(a$, 171, 5) = FFORMAT$(TotAvg!, "#.###")
MID$(a$, 177, 5) = FFORMAT$(rc27!, "#0.##")
GOSUB StripNulls
PRINT #OUTHdl, a$
END IF
'Print League PITCHING Totals
PRINT #OUTHdl,
PRINT #OUTHdl,
PRINT #OUTHdl,
PRINT #OUTHdl, "LEAGUE PITCHING SUMMARY BY TEAM"
PRINT #OUTHdl,
'oldPRINT #OUTHdl, "Team W L S BS ERA CG ShO Inns Hits Runs ERun HR HB BB SO SO/9 Avg Slg OB OPS"
PRINT #OUTHdl, " Opp Opp Opp Opp"
PRINT #OUTHdl, "Name W L S BS ERA CG ShO Inns Hits Runs ERun HR HB BB SO SO/9 Avg Slg OB OPS"
ARRAY SORT TeamPitSum() FOR tdx, FROM 87 TO 92, ASCEND
FOR i = 1 TO tdx
x$ = TeamPitSum(i)
PRINT #OUTHdl, x$
NEXT
Inns! = LegPInn + LegP3rds / 3
IF Inns! = 0 THEN Inns! = .33
PERA! = LegPERuns / Inns! * 9!
IF PERA! > 99.99 THEN PERA! = 99.99
'Expanded League PITCHING Statistics
TB = LegPHits + LegP2B + 2 * LegP3B + 3 * LegPHR
IF (LegPBF - LegPBB - LegPHB) > 0 THEN
Avg! = LegPHits / (LegPBF - LegPBB - LegPHB)
Slug! = TB / (LegPBF - LegPBB - LegPHB)
ELSE
Avg! = 0.
Slug! = 0.
END IF
IF LegPBF > 0 THEN
OnBase! = (LegPBB + LegPHB + LegPHits) / LegPBF
ELSE
OnBase! = 0.
END IF
Prod! = OnBase! + Slug!
SO9! = LegPSO / (Inns! / 9.)
IF PrtMain THEN
PRINT #OUTHdl,
a$ = SPACE$(175)
MID$(a$, 1, 12) = "LEAGUE PIT.:"
MID$(a$, 14, 1) = SaveLeague$
MID$(a$, 41, 6) = FFORMAT$(PERA!, "#0.###")
MID$(a$, 60, 5) = LFORMAT$(LegPCG, "#####")
MID$(a$, 65, 5) = LFORMAT$(LegPShO, "#####")
MID$(a$, 70, 9) = FFORMAT$(Inns!, "#######.#")
MID$(a$, 79, 7) = LFORMAT$(LegPHits, "#######")
MID$(a$, 86, 7) = LFORMAT$(LegPRuns, "#######")
MID$(a$, 93, 7) = LFORMAT$(LegPERuns, "#######")
MID$(a$, 100, 7) = LFORMAT$(LegPHR, "#######")
MID$(a$, 107, 6) = LFORMAT$(LegPHB, "######")
MID$(a$, 113, 7) = LFORMAT$(LegPBB, "#######")
MID$(a$, 120, 7) = LFORMAT$(LegPSO, "#######")
MID$(a$, 128, 5) = FFORMAT$(SO9!, "#0.##")
MID$(a$, 134, 5) = FFORMAT$(Avg!, "#.###")
MID$(a$, 140, 5) = FFORMAT$(Slug!, "#.###")
MID$(a$, 146, 5) = FFORMAT$(Onbase!, "#.###")
MID$(a$, 152, 5) = FFORMAT$(Prod!, "#.###")
GOSUB StripNulls
PRINT #OUTHdl, a$
END IF
'Print League FIELDING Totals
PRINT #OUTHdl,
PRINT #OUTHdl,
PRINT #OUTHdl,
PRINT #OUTHdl, "LEAGUE FIELDING SUMMARY BY TEAM"
PRINT #OUTHdl,
ARRAY SORT TeamFldSum() FOR tdx, FROM 41 TO 46, DESCEND
PRINT #OUTHdl, "Team Errs Assts POs Pct%"
ee = 0: ai = 0: po = 0
FOR i = 1 TO tdx
x$ = TeamFldSum(i)
ee = ee + VAL(MID$(x$, 17, 7))
ai = ai + VAL(MID$(x$, 25, 7))
po = po + VAL(MID$(x$, 33, 7))
PRINT #OUTHdl, x$
NEXT
a$ = SPACE$(46)
MID$(a$, 17, 7) = LFORMAT$(ee, "#######")
MID$(a$, 25, 7) = LFORMAT$(ai, "#######")
MID$(a$, 33, 7) = LFORMAT$(po, "#######")
IF ee + ai + po > 0 THEN
dpct! = (ai + po) / (ee + ai + po)
ELSE
dpct! = 1.000
END IF
MID$(a$, 41, 6) = FFORMAT$(dpct!, "#.####")
PRINT #OUTHdl, a$
'Print Individual League Batting Leaders
IF PrtLeaders = 0 THEN GOTO EscLeaders
PRINT #OUTHdl,
PRINT #OUTHdl,
PRINT #OUTHdl,
PRINT #OUTHdl, "============================="
PRINT #OUTHdl, "League Batting Leaders - "; LeagueName$
PRINT #OUTHdl, "============================="
PRINT #OUTHdl,
PRINT #OUTHdl, "Batting Avg (Based on"; QualPA; " PA) ====== Runs ================================"
' 1 \ .### \ \ ####"
' 2 \ .### "
' 3 \ \ ####"
FOR i = 1 TO TblMax
IF TblPAvg!(i) < .001 AND TblPRuns(i) > 0 THEN
a$ = SPACE$(80)
MID$(a$, 41, 29) = TblPRunsN(i).SSItem
MID$(a$, 72, 6) = LFORMAT$(TblPRuns(i), "######")
PRINT #OUTHdl, a$
ELSEIF TblPAvg!(i) > .001 AND TblPRuns(i) = 0 THEN
a$ = SPACE$(80)
MID$(a$, 1, 29) = TblPAvgN(i).SSItem
MID$(a$, 33, 4) = FFORMAT$(TblPAvg!(i), ".###")
PRINT #OUTHdl, a$
ELSEIF TblPAvg!(i) > .001 AND TblPRuns(i) > 0 THEN
a$ = SPACE$(80)
MID$(a$, 1, 29) = TblPAvgN(i).SSItem
MID$(a$, 33, 4) = FFORMAT$(TblPAvg!(i), ".###")
MID$(a$, 41, 29) = TblPRunsN(i).SSItem
MID$(a$, 72, 6) = LFORMAT$(TblPRuns(i), "######")
PRINT #OUTHdl, a$
END IF
NEXT
PRINT #OUTHdl,
PRINT #OUTHdl, "Hits =============================== Home Runs ==========================="
' 1 \ #### \ \ ####"
' 2 \ #### "
' 3 \ \ ####"
FOR i = 1 TO TblMax
IF TblPHits(i) = 0 AND TblPHR(i) > 0 THEN
a$ = SPACE$(80)
MID$(a$, 41, 29) = TblPHRN(i).SSItem
MID$(a$, 72, 6) = LFORMAT$(TblPHR(i), "######")
PRINT #OUTHdl, a$
ELSEIF TblPHits(i) > 0 AND TblPHR(i) = 0 THEN
a$ = SPACE$(80)
MID$(a$, 1, 29) = TblPHitsN(i).SSItem
MID$(a$, 31, 6) = LFORMAT$(TblPHits(i), "######")
PRINT #OUTHdl, a$
ELSEIF TblPHits(i) > 0 AND TblPHR(i) > 0 THEN
a$ = SPACE$(80)
MID$(a$, 1, 29) = TblPHitsN(i).SSItem
MID$(a$, 31, 6) = LFORMAT$(TblPHits(i), "######")
MID$(a$, 41, 29) = TblPHRN(i).SSItem
MID$(a$, 72, 6) = LFORMAT$(TblPHR(i), "######")
PRINT #OUTHdl, a$
END IF
NEXT
PRINT #OUTHdl,
PRINT #OUTHdl, "Doubles ============================ Triples ============================="
FOR i = 1 TO TblMax
IF TblP2B(i) = 0 AND TblP3B(i) > 0 THEN
a$ = SPACE$(80)
MID$(a$, 41, 29) = TblP3BN(i).SSItem
MID$(a$, 72, 6) = LFORMAT$(TblP3B(i), "######")
PRINT #OUTHdl, a$
ELSEIF TblP2B(i) > 0 AND TblP3B(i) = 0 THEN
a$ = SPACE$(80)
MID$(a$, 1, 29) = TblP2BN(i).SSItem
MID$(a$, 31, 6) = LFORMAT$(TblP2B(i), "######")
PRINT #OUTHdl, a$
ELSEIF TblP2B(i) > 0 AND TblP3B(i) > 0 THEN
a$ = SPACE$(80)
MID$(a$, 1, 29) = TblP2BN(i).SSItem
MID$(a$, 31, 6) = LFORMAT$(TblP2B(i), "######")
MID$(a$, 41, 29) = TblP3BN(i).SSItem
MID$(a$, 72, 6) = LFORMAT$(TblP3B(i), "######")
PRINT #OUTHdl, a$
END IF
NEXT
PRINT #OUTHdl,
PRINT #OUTHdl, "RBI ================================ Walks ==============================="
FOR i = 1 TO TblMax
IF TblPRBI(i) = 0 AND TblPBB(i) > 0 THEN
a$ = SPACE$(80)
MID$(a$, 41, 29) = TblPBBN(i).SSItem
MID$(a$, 72, 6) = LFORMAT$(TblPBB(i), "######")
PRINT #OUTHdl, a$
ELSEIF TblPRBI(i) > 0 AND TblPBB(i) = 0 THEN
a$ = SPACE$(80)
MID$(a$, 1, 29) = TblPRBIN(i).SSItem
MID$(a$, 31, 6) = LFORMAT$(TblPRBI(i), "######")
PRINT #OUTHdl, a$
ELSEIF TblPRBI(i) > 0 AND TblPBB(i) > 0 THEN
a$ = SPACE$(80)
MID$(a$, 1, 29) = TblPRBIN(i).SSItem
MID$(a$, 31, 6) = LFORMAT$(TblPRBI(i), "######")
MID$(a$, 41, 29) = TblPBBN(i).SSItem
MID$(a$, 72, 6) = LFORMAT$(TblPBB(i), "######")
PRINT #OUTHdl, a$
END IF
NEXT
PRINT #OUTHdl,
PRINT #OUTHdl, "Stolen Bases ======================= On-Base Pct. ========================"
FOR i = 1 TO TblMax
IF TblPSB(i) = 0 AND TblP2!(i) > 0 THEN
a$ = SPACE$(80)
MID$(a$, 41, 29) = TblP2N(i).SSItem
MID$(a$, 74, 4) = FFORMAT$(TblP2!(i), ".###")
PRINT #OUTHdl, a$
ELSEIF TblPSB(i) > 0 AND TblP2!(i) = 0 THEN
a$ = SPACE$(80)
MID$(a$, 1, 29) = TblPSBN(i).SSItem
MID$(a$, 31, 6) = LFORMAT$(TblPSB(i), "######")
PRINT #OUTHdl, a$
ELSEIF TblPSB(i) > 0 AND TblP2!(i) > 0 THEN
a$ = SPACE$(80)
MID$(a$, 1, 29) = TblPSBN(i).SSItem
MID$(a$, 31, 6) = LFORMAT$(TblPSB(i), "######")
MID$(a$, 41, 29) = TblP2N(i).SSItem
MID$(a$, 74, 4) = FFORMAT$(TblP2!(i), ".###")
PRINT #OUTHdl, a$
END IF
NEXT
PRINT #OUTHdl,
PRINT #OUTHdl, "Slugging =========================== Runs Created Per 27 Outs ============"
FOR i = 1 TO TblMax
IF TblP3!(i) = 0 AND TblP1!(i) > 0 THEN
a$ = SPACE$(80)
MID$(a$, 41, 29) = TblP1N(i).SSItem
MID$(a$, 73, 5) = FFORMAT$(TblP1!(i), "#0.##")
PRINT #OUTHdl, a$
ELSEIF TblP3!(i) > 0 AND TblP1!(i) = 0 THEN
a$ = SPACE$(80)
MID$(a$, 1, 29) = TblP3N(i).SSItem
MID$(a$, 32, 5) = FFORMAT$(TblP3!(i), "#.###")
PRINT #OUTHdl, a$
ELSEIF TblP3!(i) > 0 AND TblP1!(i) > 0 THEN
a$ = SPACE$(80)
MID$(a$, 1, 29) = TblP3N(i).SSItem
MID$(a$, 32, 5) = FFORMAT$(TblP3!(i), "#.###")
MID$(a$, 41, 29) = TblP1N(i).SSItem
MID$(a$, 73, 5) = FFORMAT$(TblP1!(i), "#0.##")
PRINT #OUTHdl, a$
END IF
NEXT
'Print League Pitching Leaders
PRINT #OUTHdl,
PRINT #OUTHdl,
PRINT #OUTHdl,
PRINT #OUTHdl, "=============================="
PRINT #OUTHdl, "League Pitching Leaders - "; LeagueName$
PRINT #OUTHdl, "=============================="
PRINT #OUTHdl,
PRINT #OUTHdl, "Innings ============================ Wins ================================"
' 1 \####.# \ \ ####"
' 2 \####.# "
' 3 \ \ ####"
FOR i = 1 TO TblMax
IF TblPInn!(i) < .001 AND TblPWins(i) > 0 THEN
a$ = SPACE$(80)
MID$(a$, 41, 29) = TblPWinsN(i).SSItem
MID$(a$, 72, 6) = LFORMAT$(TblPWins(i), "######")
PRINT #OUTHdl, a$
ELSEIF TblPInn!(i) > .001 AND TblPWins(i) = 0 THEN
a$ = SPACE$(80)
MID$(a$, 1, 29) = TblPInnN(i).SSItem
MID$(a$, 29, 8) = FFORMAT$(TblPInn!(i), "######.#")
PRINT #OUTHdl, a$
ELSEIF TblPInn!(i) > .001 AND TblPWins(i) > 0 THEN
a$ = SPACE$(80)
MID$(a$, 1, 29) = TblPInnN(i).SSItem
MID$(a$, 29, 8) = FFORMAT$(TblPInn!(i), "######.#")
MID$(a$, 41, 29) = TblPWinsN(i).SSItem
MID$(a$, 72, 6) = LFORMAT$(TblPWins(i), "######")
PRINT #OUTHdl, a$
END IF
NEXT
PRINT #OUTHdl,
PRINT #OUTHdl, "ERA (Based on"; QualIP; " Inn) ============= Strike Outs ========================="
' 1 \##.### \ \ ####"
' 2 \##.### "
' 3 \ \ ####"
FOR i = 1 TO TblMax
IF TblPERA!(i) > 99.999 THEN TblPERA!(i) = 99.999
IF TblPERAN(i).SSItem < "!" AND TblPSO(i) > 0 THEN
a$ = SPACE$(80)
MID$(a$, 41, 29) = TblPSON(i).SSItem
MID$(a$, 72, 6) = LFORMAT$(TblPSO(i), "######")
PRINT #OUTHdl, a$
ELSEIF TblPERAN(i).SSItem > "!" AND TblPSO(i) = 0 THEN
a$ = SPACE$(80)
MID$(a$, 1, 29) = TblPERAN(i).SSItem
MID$(a$, 32, 5) = FFORMAT$(TblPERA!(i), "#0.##")
PRINT #OUTHdl, a$
ELSEIF TblPERAN(i).SSItem > "!" AND TblPSO(i) > 0 THEN
a$ = SPACE$(80)
MID$(a$, 1, 29) = TblPERAN(i).SSItem
MID$(a$, 32, 5) = FFORMAT$(TblPERA!(i), "#0.##")
MID$(a$, 41, 29) = TblPSON(i).SSItem
MID$(a$, 72, 6) = LFORMAT$(TblPSO(i), "######")
PRINT #OUTHdl, a$
END IF
NEXT
PRINT #OUTHdl,
PRINT #OUTHdl, "Saves ============================== Complete Games ======================"
' \ ####"
FOR i = 1 TO TblMax
IF TblPSaves(i) = 0 AND TblP4(i) > 0 THEN
a$ = SPACE$(80)
MID$(a$, 41, 29) = TblP4N(i).SSItem
MID$(a$, 72, 6) = LFORMAT$(TblP4(i), "######")
PRINT #OUTHdl, a$
ELSEIF TblPSaves(i) > 0 AND TblP4(i) = 0 THEN
a$ = SPACE$(80)
MID$(a$, 1, 29) = TblPSavesN(i).SSItem
MID$(a$, 31, 6) = LFORMAT$(TblPSaves(i), "######")
PRINT #OUTHdl, a$
ELSEIF TblPSaves(i) > 0 AND TblP4(i) > 0 THEN
a$ = SPACE$(80)
MID$(a$, 1, 29) = TblPSavesN(i).SSItem
MID$(a$, 31, 6) = LFORMAT$(TblPSaves(i), "######")
MID$(a$, 41, 29) = TblP4N(i).SSItem
MID$(a$, 72, 6) = LFORMAT$(TblP4(i), "######")
PRINT #OUTHdl, a$
END IF
NEXT
PRINT #OUTHdl,
PRINT #OUTHdl, "ShutOuts =========================== OPS (OBP + Slug.) ==================="
' \ ####"
FOR i = 1 TO TblMax
IF TblP5(i) = 0 AND TblP6!(i) < 99999. THEN
a$ = SPACE$(80)
MID$(a$, 41, 29) = TblP6N(i).SSItem
MID$(a$, 73, 5) = FFORMAT$(TblP6!(i), "#.###")
PRINT #OUTHdl, a$
ELSEIF TblP5(i) > 0 AND TblP6!(i) > 99999. THEN
a$ = SPACE$(80)
MID$(a$, 1, 29) = TblP5N(i).SSItem
MID$(a$, 31, 6) = LFORMAT$(TblP5(i), "######")
PRINT #OUTHdl, a$
ELSEIF TblP5(i) > 0 AND TblP6!(i) < 99999. THEN
a$ = SPACE$(80)
MID$(a$, 1, 29) = TblP5N(i).SSItem
MID$(a$, 31, 6) = LFORMAT$(TblP5(i), "######")
MID$(a$, 41, 29) = TblP6N(i).SSItem
MID$(a$, 73, 5) = FFORMAT$(TblP6!(i), "#.###")
PRINT #OUTHdl, a$
END IF
NEXT
EscLeaders:
LOOP
'End of File
CLOSE #STBHdl
CLOSE #STPHdl
CLOSE #STFHdl
CLOSE #OUTHdl
QuickExit:
OutFile$ = OutDevice$
COLOR deffor, defbac
LOCATE 1, 1
EXIT SUB
PrintDetail:
IF BR.BABs <> 0 THEN PAvg! = BR.BHits / BR.BABs ELSE PAvg! = 0
'Expanded individual batting statistics
TB = BR.BHits + BR.B2Bs + 2 * BR.B3Bs + 3 * BR.BHRs
IF BR.BABs > 0 THEN
Slug! = TB / BR.BABs
ELSE
Slug! = 0.0
END IF
IF BR.BABs > 0 THEN
HRPct! = BR.BHRs / BR.BABs * 100
ELSE
HRPct! = 0.0
END IF
IF BR.BABs > 0 THEN
OnBase! = (BR.BBBs + BR.BHB + BR.BHits) / (BR.BBBs + BR.BHB + BR.BABs)
ELSE
OnBase! = 0.0
END IF
Prod! = OnBase! + Slug!
IF BR.BSBs <> 0 THEN
Rate! = BR.BSBs / (BR.BSBs + BR.BCSs) * 100
ELSE
Rate! = 0.0
END IF
IF (BR.BCSs + BR.BABs - BR.BHits) > 0 THEN
TotAvg! = (TB + BR.BSBs + BR.BBBs + BR.BHB) / (BR.BCSs + BR.BABs - BR.BHits)
ELSE
TotAvg! = 0.0
END IF
rc27! = RunsCreated27!((BR.BABs), (BR.BHits), (BR.B2Bs), (BR.B3Bs), (BR.BHRs), (BR.BBBs), (BR.BHB), (BR.BSacB), (BR.BSacF), (BR.BSBs), (BR.BCSs), (BR.BGDP))
xS$ = LEFT$(BR.BNam, 15)
i = INSTR(BR.BNam, ",")
IF i > 0 THEN yS$ = MID$(BR.BNam, 1, i - 1) ELSE yS$ = xS$
IF PrtMain THEN
'old:
' Avg G AB Runs Hits TB 2B 3B HR RBI SH SF HB BB SO SB CS SB% GIDP ERR OB Slg HR OPS TAvg RC/27
' \ X #.### #### #### #### ##### ##### #### ### #### #### #### #### ### ##### ##### #### ### ###.# #### #### #.### #.### ##.# #.### #.### ##.## \ \
'new:
' Avg G AB Runs Hits TB 2B 3B HR RBI SH SF HB BB SO SB CS SB% GIDP ERR OB Slg HR OPS TAvg RC/27
' #.### ###### ###### ###### ###### ###### ##### ##### ###### ###### ##### ##### ##### ###### ###### ##### ##### ###.# ##### ##### #.### #.### ##.# #.### #.### ##.## \ \"
a$ = SPACE$(195)
MID$(a$, 1, 15) = xS$
MID$(a$, 17, 1) = BR.BBats
IF BR.BABs > 0 THEN
MID$(a$, 19, 5) = FFORMAT$(PAvg!, "#.###")
END IF
MID$(a$, 25, 6) = LFORMAT$(BR.BGames, "######")
MID$(a$, 32, 6) = LFORMAT$(BR.BABs, "######")
MID$(a$, 39, 6) = LFORMAT$(BR.BRuns, "######")
MID$(a$, 46, 6) = LFORMAT$(BR.BHits, "######")
MID$(a$, 53, 6) = LFORMAT$(TB, "######")
MID$(a$, 60, 5) = LFORMAT$(BR.B2Bs, "#####")
MID$(a$, 66, 5) = LFORMAT$(BR.B3Bs, "#####")
MID$(a$, 72, 6) = LFORMAT$(BR.BHRs, "######")
MID$(a$, 79, 6) = LFORMAT$(BR.BRBIs, "######")
MID$(a$, 86, 5) = LFORMAT$(BR.BSacB, "#####")
MID$(a$, 92, 5) = LFORMAT$(BR.BSacF, "#####")
MID$(a$, 98, 5) = LFORMAT$(BR.BHB, "#####")
MID$(a$,104, 6) = LFORMAT$(BR.BBBs, "######")
MID$(a$,111, 6) = LFORMAT$(BR.BKs, "######")
MID$(a$,118, 5) = LFORMAT$(BR.BSBs, "#####")
MID$(a$,124, 5) = LFORMAT$(BR.BCSs, "#####")
MID$(a$,130, 5) = FFORMAT$(Rate!, "##0.#")
MID$(a$,136, 5) = LFORMAT$(BR.BGDP, "#####")
MID$(a$,142, 5) = LFORMAT$(BR.BERRs, "#####")
MID$(a$,148, 5) = FFORMAT$(Onbase!, "#.###")
MID$(a$,154, 5) = FFORMAT$(Slug!, "#.###")
MID$(a$,160, 4) = FFORMAT$(HRPct!, "#0.#")
MID$(a$,165, 5) = FFORMAT$(Prod!, "#.###")
MID$(a$,171, 5) = FFORMAT$(TotAvg!, "#.###")
MID$(a$,177, 5) = FFORMAT$(rc27!, "#0.##")
MID$(a$,183, 12) = yS$
GOSUB StripNulls
PRINT #OUTHdl, a$
IF RL THEN
'vs RHP
a$ = SPACE$(170)
IF BR.BABsRHP <> 0 THEN SAvg! = BR.BHitsRHP / BR.BABsRHP ELSE SAvg! = 0
MID$(a$, 1, 15) = " .vs RHP"
IF SAvg! > 0 THEN
MID$(a$, 19, 5) = FFORMAT$(SAvg!, "#.###")
END IF
MID$(a$, 32, 6) = LFORMAT$(BR.BABsRHP, "######")
MID$(a$, 46, 6) = LFORMAT$(BR.BHitsRHP, "######")
MID$(a$, 60, 5) = LFORMAT$(BR.B2BsRHP, "#####")
MID$(a$, 66, 5) = LFORMAT$(BR.B3BsRHP, "#####")
MID$(a$, 72, 6) = LFORMAT$(BR.BHRsRHP, "######")
MID$(a$,104, 6) = LFORMAT$(BR.BBBsRHP, "######")
MID$(a$,111, 6) = LFORMAT$(BR.BKsRHP, "######")
'Expanded individual batting statistics
TB = BR.BHitsRHP + BR.B2BsRHP + 2 * BR.B3BsRHP + 3 * BR.BHRsRHP
MID$(a$, 53, 6) = LFORMAT$(TB, "######")
IF BR.BABsRHP > 0 THEN
Slugx! = TB / BR.BABsRHP
ELSE
Slugx! = 0.0
END IF
IF BR.BABsRHP > 0 THEN
HRPctx! = BR.BHRsRHP / BR.BABsRHP * 100
ELSE
HRPctx! = 0.0
END IF
IF BR.BHB > 0 AND BR.BABs > 0 THEN
BHBRHP = (BR.BABsRHP / BR.BABs) * BR.BHB
ELSE
BHBRHP = 0
END IF
IF BR.BABs > 0 THEN
OnBasex! = (BR.BBBsRHP + BHBRHP + BR.BHitsRHP) / _
(BR.BBBsRHP + BHBRHP + BR.BABsRHP)
ELSE
OnBasex! = 0.0
END IF
MID$(a$,148, 5) = FFORMAT$(Onbasex!, "#.###")
MID$(a$,154, 5) = FFORMAT$(Slugx!, "#.###")
MID$(a$,160, 4) = FFORMAT$(HRPctx!, "#0.#")
Prodx! = OnBasex! + Slugx!
MID$(a$,165, 5) = FFORMAT$(Prodx!, "#.###")
PRINT #OUTHdl, a$
'vs LHP
a$ = SPACE$(170)
IF BR.BABsLHP <> 0 THEN SAvg! = BR.BHitsLHP / BR.BABsLHP ELSE SAvg! = 0
MID$(a$, 1, 15) = " .vs LHP"
IF SAvg! > 0 THEN
MID$(a$, 19, 5) = FFORMAT$(SAvg!, "#.###")
END IF
MID$(a$, 32, 6) = LFORMAT$(BR.BABsLHP, "######")
MID$(a$, 46, 6) = LFORMAT$(BR.BHitsLHP, "######")
MID$(a$, 60, 5) = LFORMAT$(BR.B2BsLHP, "#####")
MID$(a$, 66, 5) = LFORMAT$(BR.B3BsLHP, "#####")
MID$(a$, 72, 6) = LFORMAT$(BR.BHRsLHP, "######")
MID$(a$,104, 6) = LFORMAT$(BR.BBBsLHP, "######")
MID$(a$,111, 6) = LFORMAT$(BR.BKsLHP, "######")
'Expanded individual batting statistics
TB = BR.BHitsLHP + BR.B2BsLHP + 2 * BR.B3BsLHP + 3 * BR.BHRsLHP
MID$(a$, 53, 6) = LFORMAT$(TB, "######")
IF BR.BABsLHP > 0 THEN
Slugx! = TB / BR.BABsLHP
ELSE
Slugx! = 0.0
END IF
IF BR.BABsLHP > 0 THEN
HRPctx! = BR.BHRsLHP / BR.BABsLHP * 100
ELSE
HRPctx! = 0.0
END IF
IF BR.BHB > 0 AND BR.BABs > 0 THEN
BHBLHP = (BR.BABsLHP / BR.BABs) * BR.BHB
ELSE
BHBLHP = 0
END IF
IF BR.BABs > 0 THEN
OnBasex! = (BR.BBBsLHP + BHBLHP + BR.BHitsLHP) / _
(BR.BBBsLHP + BHBLHP + BR.BABsLHP)
ELSE
OnBasex! = 0.0
END IF
MID$(a$,148, 5) = FFORMAT$(Onbasex!, "#.###")
MID$(a$,154, 5) = FFORMAT$(Slugx!, "#.###")
MID$(a$,160, 4) = FFORMAT$(HRPctx!, "#0.#")
Prodx! = OnBasex! + Slugx!
MID$(a$,165, 5) = FFORMAT$(Prodx!, "#.###")
PRINT #OUTHdl, a$
END IF
END IF
RETURN
StripNulls:
FOR ix = 1 TO LEN(a$)
IF MID$(a$, ix, 1) = CHR$(0) THEN MID$(a$, ix, 1) = " "
NEXT
RETURN
NewPage:
PRINT #OUTHdl,
PRINT #OUTHdl,
PageNo = PageNo + 1
PRINT #OUTHdl, "SBS 4.9.3"; TAB(35); "Strategic Baseball Statistics"
PRINT #OUTHdl,
LineCtr = 3
RETURN
SearchTable:
i = 1
DO
IF i > TblEnd THEN
IF TblEnd < STATTEAMLIMIT THEN
INCR TblEnd
SA(TblEnd).ALeague = LeagueArg
SA(TblEnd).ANam = NameArg
ELSE
PRINT " Team Limit Exceeded! "
PauseIt
END IF
ndx = TblEnd
EXIT DO
END IF
IF SA(i).ALeague = LeagueArg AND SA(i).ANam = NameArg THEN
ndx = i
EXIT DO
END IF
INCR i
LOOP
RETURN
GetLeagueName:
SELECT CASE UCASE$(SaveLeague$)
CASE "A"
LeagueName$ = "A.L."
CASE "N"
LeagueName$ = "N.L."
CASE "F"
LeagueName$ = "Federal"
CASE ELSE
LeagueName$ = SaveLeague$
END SELECT
RETURN
END SUB
SUB StatRecordSetup (Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
CALL Drawfrm(2+rowO, 7+colO, 23+rowO, 73+colO, defattr, "Statistics Recording", "ESC (or close window) to Continue", 1, 0, 1)
QPRINTs rowO+3,colO+22, "Specify Files to Save Statistical Data", defattr
QPRINTs rowO+5,colO+9, "Note: These entries are all optional, but if you want to record ", dimattr
QPRINTs rowO+6,colO+9, "basic statistics in order to generate a stat report, you must ", dimattr
QPRINTs rowO+7,colO+9, "at least enter a filename for 'Statistics File'. To select an ", dimattr
QPRINTs rowO+8,colO+9, "existing Statistics file press .", dimattr
QPRINTs rowO+8,colO+40,"[F4]", defattr
DATA 9,52," Clear", 0,0,0,"X "
DATA 10,52,"Existing?",0,0,0,"X "
DATA 11,15,"Statistics File: ",11,32,16,"X "
DATA 0,00,"", 11,55,01,"XR"
DATA 13,15,"Line Score File: ",13,32,18,"X "
DATA 0,00,"", 13,55,01,"XR"
DATA 15,15,"Box Score File: ",15,32,18,"X "
DATA 0,00,"", 15,55,01,"XR"
DATA 17,15,"Score Card File: ",17,32,18,"X "
DATA 0,00,"", 17,55,01,"XR"
DATA 19,15,"StarBox File: ",19,32,18,"X "
DATA 0,00,"", 19,55,01,"XR"
QPRINTs rowO+21, colO+9, "The STARBOX file contains box scores of outstanding individual ", dimattr
QPRINTs rowO+22, colO+9, "performances. Leave fields BLANK where data is not desired. ", dimattr
QPRINTs rowO+11, colO+49, "+", revattr
QPRINTs rowO+11, colO+58, "Caution: ", dimattr
QPRINTs rowO+12, colO+58, "[Y] will erase ", dimattr
QPRINTs rowO+13, colO+58, "all data in ", dimattr
QPRINTs rowO+14, colO+58, "specified file.", dimattr
c = 1
FOR i = 1 TO 12
Flitrow(i) = VAL(READ$(c))
IF Flitrow(i) > 0 THEN Flitrow(i) = Flitrow(i) + rowO
Flitcol(i) = VAL(READ$(c+1))
IF Flitcol(i) > 0 THEN Flitcol(i) = Flitcol(i) + colO
Flit$(i) = READ$(c+2)
Frow(i) = VAL(READ$(c+3))
IF Frow(i) > 0 THEN Frow(i) = Frow(i) + rowO
Fcol(i) = VAL(READ$(c+4))
IF Fcol(i) > 0 THEN Fcol(i) = Fcol(i) + colO
Flen(i) = VAL(READ$(c+5))
Fed$(i) = READ$(c+6)
c = c + 7
NEXT
Flds = 12
'Set Defaults
REDIM FContents$(13)
FContents$(3) = CmdStat$ 'May not be defined yet
FContents$(4) = "N"
FContents$(5) = CmdLinF$
FContents$(6) = "N"
FContents$(7) = CmdBoxF$
FContents$(8) = "N"
FContents$(9) = CmdScrF$
FContents$(10) = "N"
FContents$(11) = CmdStar$
FContents$(12) = "N"
END SUB
SUB StatRecordIO (RetKey, Flds, CursorPtr, Plen(), Prow(), Pcol(), Ped$(), Plit$(), Plitrow(), Plitcol(), PContents$())
DO
StatRecordLoop:
CustomEscKey = -62 'F4
TakeFromAnywhere = 2
CALL ScreenIO(Keyed, KeyF3, CustomEscKey, KeyEsc, Flds, CursorPtr, Plen(), Prow(), Pcol(), Ped$(), Plit$(), Plitrow(), Plitcol(), PContents$())
TakeFromAnywhere = 0
IF Keyed = KeyF3 THEN
RetKey = Keyed
EXIT SUB
END IF
IF Keyed = CustomEscKey THEN 'F4 - Browse/Select .STS files
CALL GetScreen(Scr3$, 3+rowO, 62+colO, 21+rowO, 76+colO)
FileLimit = 500
REDIM List1(1 TO FileLimit) AS List1Type
x$ = MenuOpt$
MenuOpt$ = "1"
Fil$ = CmdWritePath$ + "*.STS"
CALL PickAFile (Fil$, FileLimit, List1(), RetKey, Pick, mous, 0)
MenuOpt$ = x$
IF Pick > 0 THEN
x$ = RTRIM$(List1(Pick).ListItem)
L = LEN(x$)
PContents$(3) = LEFT$(x$, L - 4)
END IF
ERASE List1
CALL PutScreen(Scr3$, 3+rowO, 62+colO, 21+rowO, 76+colO)
GOTO StatRecordLoop
END IF
' Edit Field Contents
Error1$ = "N"
i = 4
DO
IF PContents$(i) <> "Y" AND PContents$(i) <> "N" THEN
Error1$ = "Y": CursorPtr = i: CALL MyBeep: GOTO StatRecordLoop
END IF
i = i + 2
LOOP UNTIL i > 12
IF PContents$(3) > "!" THEN
IF PContents$(3) = PContents$(5) OR PContents$(3) = PContents$(7) OR PContents$(3) = PContents$(9) OR PContents$(3) = PContents$(11) THEN
CALL PopMsg(18+rowO, 26+colO, " File names must be different! ", errattr, 2, kc)
Error1$ = "Y"
CursorPtr = 3
GOTO StatRecordLoop
END IF
END IF
IF PContents$(7) > "!" AND LEFT$(PContents$(7), 3) <> "LPT" THEN
IF PContents$(7) = PContents$(9) THEN
CALL PopMsg(18+rowO, 26+colO, " File names must be different! ", errattr, 2, kc)
Error1$ = "Y"
CursorPtr = 8
GOTO StatRecordLoop
END IF
END IF
IF PContents$(3) > "!" THEN
zS$ = CmdWritePath$ + RTRIM$(PContents$(3)) + ".RES"
IF CmdSCH$ > "!" THEN
IF LEN(DIR$(zS$)) THEN
OPEN zS$ FOR RANDOM AS #5 LEN = LEN(RestartRec)
GET #5, 1, RestartRec
CLOSE #5
IF UCASE$(RTRIM$(RestartRec.ResSCHName)) <> UCASE$(RTRIM$(CmdSCH$)) THEN
QPush
CALL Drawfrm(9, 14, 22, 64, linattr, "*** ERROR ***", nulls$, 0, 0, 0)
QPRINTs 10, 16, " SBS believes this Stat File is currently ", errattr
QPRINTs 11, 16, " being used by another Schedule file. ", errattr
QPRINTs 13, 16, " Selected SCH Name: " + RTRIM$(CmdSCH$), errattr
QPRINTs 14, 16, " Restart File : " + zS$, errattr
QPRINTs 15, 16, " Restart SCH Name : " + RTRIM$(RestartRec.ResSCHName), errattr
QPRINTs 16, 16, " Restart Date : " + RestartRec.ResSCHDate, errattr
QPRINTs 17, 16, " Restart Slot : " + STR$(RestartRec.ResSCHSlotPtr), errattr
QPRINTs 18, 16, " Slot Game : " + STR$(RestartRec.ResSlotGameCtr), errattr
QPRINTs 19, 16, " of : " + STR$(RestartRec.ResSlotGames), errattr
QPRINTs 20, 16, " Restart Sch Game : " + STR$(RestartRec.ResSimGameCtr), errattr
QPRINTs 21, 16, " (The SCH names must match)", errattr
PauseIt
QPop
Error1$ = "Y"
CursorPtr = 3
GOTO StatRecordLoop
END IF
END IF
ELSE 'NOT in SCH mode
IF LEN(DIR$(zS$)) THEN 'but a .RES exists
QPush
CALL Drawfrm(9, 14, 14, 64, linattr, "*** WARNING ***", nulls$, 0, 0, 0)
QPRINTs 10, 16, " SBS believes this Stat File may be currently ", errattr
QPRINTs 11, 16, " in use by a Schedule file. ", errattr
QPRINTs 12, 16, " Do you want to use it anyway? [y/N]:", errattr
LOCATE 12, 54
xS$ = YESorNO$(revfor, revbac, deffor, defbac, "N")
QPop
IF xS$ <> "Y" THEN
Error1$ = "Y"
CursorPtr = 3
GOTO StatRecordLoop
END IF
END IF
END IF
END IF
LOOP WHILE Error1$ = "Y"
IF PContents$(3) > "!" THEN
CmdStat$ = PContents$(3)
i = INSTR(CmdStat$, ".")
IF i > 0 THEN CmdStat$ = LEFT$(CmdStat$, i - 1) ELSE CmdStat$ = RTRIM$(CmdStat$)
CmdStat$ = TRUNCFILENAME$(CmdStat$)
IF PContents$(4) = "Y" THEN
xS$ = CmdStat$ + ".STS"
GOSUB SIOchkkill
xS$ = CmdStat$ + ".STB"
GOSUB SIOchkkill
xS$ = CmdStat$ + ".STP"
GOSUB SIOchkkill
xS$ = CmdStat$ + ".STF"
GOSUB SIOchkkill
xS$ = CmdStat$ + ".STH"
GOSUB SIOchkkill
xS$ = CmdStat$ + ".RES"
GOSUB SIOchkkill
xS$ = CmdStat$ + ".ROT"
GOSUB SIOchkkill
xS$ = CmdStat$ + ".STD"
GOSUB SIOchkkill
END IF
ELSE
CmdStat$ = nulls$
END IF
IF PContents$(5) > "!" THEN
CmdLinF$ = RTRIM$(PContents$(5))
IF LEFT$(CmdLinF$, 3) <> "LPT" THEN
IF LEN(DIR$(CmdWritePath$ + CmdLinF$)) THEN
IF PContents$(6) = "Y" THEN KILL CmdWritePath$ + CmdLinF$
END IF
END IF
ELSE
CmdLinF$ = nulls$
END IF
IF PContents$(7) > "!" THEN
CmdBoxF$ = RTRIM$(PContents$(7))
IF LEFT$(CmdBoxF$, 3) <> "LPT" THEN
IF LEN(DIR$(CmdWritePath$ + CmdBoxF$)) THEN
IF PContents$(8) = "Y" THEN KILL CmdWritePath$ + CmdBoxF$
END IF
END IF
ELSE
CmdBoxF$ = nulls$
END IF
IF PContents$(9) > "!" THEN
CmdScrF$ = RTRIM$(PContents$(9))
IF LEFT$(CmdScrF$, 3) <> "LPT" THEN
IF LEN(DIR$(CmdWritePath$ + CmdScrF$)) THEN
IF PContents$(10) = "Y" THEN KILL CmdWritePath$ + CmdScrF$
END IF
END IF
ELSE
CmdScrF$ = nulls$
END IF
IF PContents$(11) > "!" THEN
CmdStar$ = RTRIM$(PContents$(11))
IF LEFT$(CmdStar$, 3) <> "LPT" THEN
IF LEN(DIR$(CmdWritePath$ + CmdStar$)) THEN
IF PContents$(12) = "Y" THEN KILL CmdWritePath$ + CmdStar$
END IF
END IF
ELSE
CmdStar$ = nulls$
END IF
RetKey = Keyed
EXIT SUB
SIOchkkill:
IF LEN(DIR$(CmdWritePath$ + xS$)) THEN KILL CmdWritePath$ + xS$
RETURN
END SUB
SUB STEALRoutine
ON ERROR GOTO ERRORTRAP
IF ir1 = 0 AND ir2 = 0 AND ir3 = 0 THEN
CALL PopMsg(18+rowO, 26+colO, " There are no baserunners! ", errattr, 2, 0)
GOTO 17900
END IF
DoubleSteal = FALSE
J1 = 0
J2 = 0
xF! = RND
'Who is the lead runner?
IF ir3 THEN 'runner on third
yF! = DataSpeed(ir3, it) / 10
IF POut THEN yF! = yF! * .50 'Cut chances (speed) by 50% if pitch-out
GOTO 17500
END IF
'No runner on third
IF ir2 = 0 THEN
'Only runner is on first
IL = ir1
J1 = 1
ELSE
'Runner on 2nd (maybe 1st too)
IL = ir2
J2 = 1
END IF
'Steal or H&Run
IF HitAndRun THEN t$ = "02" ELSE t$ = "01"
IF DelFac THEN CALL Msg ("25", "0", "0", t$, IL, it, man2, team2)
'Runners on 1st or 2nd or both; (and nobody on third)
17020 :
IF ir1 AND ir2 THEN
IF amgr(it) = 0 THEN
'Player is calling the shots
x$ = " Attempt double steal? [y/N]"
CALL PopMsg(10+rowO, 30+colO, x$, errattr, 0, kc)
IF UCASE$(CHR$(kc)) = "Y" THEN DoubleSteal = TRUE
ELSE
'Computer is in control
IF RND < .75 THEN DoubleSteal = TRUE
END IF
END IF
'Calculate probability of being safe
'Examine CS column
IF StBSw(it) <> 0 THEN 'Header indicates SB as opposed to Speed-Rating
s = 0 'Sum CS for non-pitchers
FOR i = 1 TO 9
IF DataPos(i, it) > 1 THEN
s = s + DataCS(i, it)
END IF
NEXT
END IF
'Using old "speed rating"
IF StBSw(it) = 0 THEN
yF! = DataSpeed(IL, it) / 10
ELSE
'Calculate raw success rate (yF!)
IF s = 0 THEN
n = DataSB(IL, it) * 0.27 '.40
ELSE
n = DataCS(IL, it)
END IF
'We have SB and CS data
IF DataSB(IL, it) + n > 10 THEN 'Plenty of data
yF! = DataSB(IL, it) / (DataSB(IL, it) + n)
ELSEIF DataSB(IL, it) + n > 0 THEN 'Limited data
yF! = DataSB(IL, it) / (DataSB(IL, it) + n)
'set limits for low-data situations
IF yF! < .2 THEN yF! = .2
IF yF! > .7 THEN yF! = .7
IF DataPos(IL, it) = 1 THEN yF! = .6
ELSE 'No data
yF! = .6
END IF
END IF
'Cut success rate for pitchouts and lefties
Adj! = 1.0
'No Pitchout
IF POut = FALSE THEN
INCR zzzNoPO
IF J1 = 1 THEN 'Lead runner is on 1st
IF UCASE$(DataHand(ip, id)) = "L" THEN
Adj! = Adj! - .16
ELSE
Adj! = Adj! + .02
END IF
ELSE 'Lead runner is on 2nd
IF UCASE$(DataHand(ip, id)) = "R" THEN
Adj! = Adj! - .16
ELSE
Adj! = Adj! + .02
END IF
END IF
ELSE
'Pitchout
' 4.7
' yF! Succ w/PO Cut
'.50 .16 68
'.60 .22 63
'.70 .32 54
'.80 .46 43
'.90 .70 22
'.99 .90 9
IF yF! < .50 THEN
Adj! = Adj! - .68
ELSE
zF! = .567 - (1.987 * yF!) + (2.340 * yF! * yF!) 'Success rate w/PO
cutit! = 1 - (zF! / yF!)
Adj! = Adj! - cutit!
END IF
IF yF! < .40 THEN
INCR zz0
ELSEIF yF! < .5 THEN
INCR zz1
ELSEIF yF! < .6 THEN
INCR zz2
ELSEIF yF! < .7 THEN
INCR zz3
ELSEIF yF! < .8 THEN
INCR zz4
ELSEIF yF! < .9 THEN
INCR zz5
ELSE
INCR zz6
END IF
INCR zzzPO
END IF
yF! = yF! * Adj!
IF yF! < .02 THEN yF! = .02
IF yF! > .98 THEN yF! = .98
wag = WHOATGUY(2)
IF DelFac THEN CALL Msg ("25", "0", "0", "07", wag, id, man2, team2) '*'s throw
IF xF! < yF! THEN 'Safe!
IF DataPos(IL, it) = 1 THEN INCR zzssbp
IF DelFac THEN
CALL Msg ("25", "0", "0", "03", IL, it, man2, team2) 'in there
CALL Msg ("25", "0", "0", "04", IL, it, man2, team2) 'SB!
END IF
'Credit Lead Runner with Stolen Base
GOSUB CreditSB
IF ir2 AND DoubleSteal = FALSE THEN
CALL Advanc(0, 1, 0)
ELSE
CALL Advanc(1, 1, 0)
END IF
CALL AddToScoreCrd(it, DataRef(IL, it), "6", "SB")
IF ITrail THEN CALL AddToScoreCrd(it, DataRef(ITrail, it), "6", "SB")
zzzsb = zzzsb + 1
ELSE 'Out! or Catcher throws it away!
f! = 4.7 - (TeamSpeed(it) / 2.)
IF f! < 2. THEN f! = 2.
defp! = DEFPCT!(wag)
zF! = 1.0 - (f! * (1.0 - defp!))
IF zF! < .7 THEN zF! = .7
IF RND > zF! THEN
'Catcher throwing error
INCR iterrs(id)
INCR inne
INCR innadverr
i = DataRef(wag, id)
INCR GpPos(i, id, 2)
INCR merr(i, id)
INCR SumErrors(2)
IF DelFac THEN
CALL Msg ("30", "0", "0", "02", 0, id, man2, team2) 'W.Throw
CALL Msg ("30", "0", "0", "09", wag, id, man2, team2) 'E-2
END IF
'Credit Runner with Stolen base
GOSUB CreditSB
Errorx = TRUE
CALL Advanc(2, 2, 1) 'Everybody advances
Errorx = FALSE
CALL AddToScoreCrd(it, DataRef(IL, it), "6", "SB/E-2")
IF ITrail THEN CALL AddToScoreCrd(it, DataRef(ITrail, it), "6", "SB")
zzzcer = zzzcer + 1
ELSE
'Out!
IF DelFac THEN CALL Msg ("25", "0", "0", "05", IL, it, man2, team2) 'OUT
INCR mcs(DataRef(IL, it), it)
IF DelFac THEN CALL Msg ("25", "0", "0", "06", wag, id, man2, team2) 'Nails him
IF J2 = 1 THEN ir2 = 0
IF J1 = 1 THEN ir1 = 0
ir2 = ir1
ir1 = 0
INCR Assists(DataRef(WHOATGUY(2), id), id, 2)
IF J2 = 1 THEN 'out at 3rd
Oat$ = "3"
n = 5
ELSE 'out at 2nd
Oat$ = "2"
IF DataHand(ib, it) = "R" THEN n = 4 ELSE n = 6
END IF
INCR PutOuts(DataRef(WHOATGUY(n), id), id, n)
INCR iout
INCR mpo(ip, id)
CALL AddToScoreCrd(it, DataRef(IL, it), Oat$, "CS 2-" + LTRIM$(STR$(n)) )
fr7 = 90 'signals runner thrown out
zzzcs = zzzcs + 1
END IF
END IF
GOTO 17900
'Trying to steal home - OR - 1st & 3rd and trying to steal 2nd
17500 :
IF ir2 = 0 AND ir1 <> 0 THEN '1st & 3rd
DoubleSteal = FALSE
IF amgr(it) = 0 THEN
'Player is calling the shots
x$ = " Attempt double steal? [y/N]"
CALL PopMsg(10+rowO, 30+colO, x$, errattr, 0, kc)
IF UCASE$(CHR$(kc)) = "Y" THEN DoubleSteal = TRUE
ELSE
'Computer is in control
IF RND < .10 THEN DoubleSteal = TRUE
END IF
IF NOT DoubleSteal THEN 'Just trying to steal 2nd
IL = ir1: J1 = 1
IF DelFac THEN
'There goes *!
CALL Msg ("25", "0", "0", "08", ir1, it, man2, team2)
END IF
GOTO 17020
ELSE 'Double Steal
wF! = .28
END IF
ELSE 'Lone runner on 3rd or bases-loaded
wF! = .48
END IF
IF DelFac THEN
AddToAnnouncer it, "The 'Steal' is on!!"
CALL Msg ("24", "0", "0", "10", ir3, it, man2, team2) 'here he comes
END IF
'Runner on 3rd (maybe 1st and/or 2nd too) trying to steal home
' xF! is a RND
' wF! is either .28 or .48
' yF! is Speed / 10 of guy on third
IF (xF! + wF!) < yF! THEN 'Safe (not too often)
'4:0% 5: 2% 6:12% 7:22% 8:32% 9:42% 'for wF! = .48 (naked steal of home)
'4:12% 5:22% 6:32% 7:42% 8:52% 9:62% 'for wF! = .28 (double steal)
'Safe at home!
IF DelFac THEN
CALL Msg ("15", "0", "0", "04", ir3, it, man2, team2) 'safe
AddToAnnouncer it, "He stole home!!!"
CALL Msg ("40", "0", "0", "00", 0, it, man2, team2) '!!!
END IF
'Credit guy who's about to score with SB
IL = ir3
INCR msb(DataRef(ir3, it), it)
DPsw = TRUE 'to fool Advanc into not awarding an RBI
CALL Advanc(1, 1, 1)
DPsw = FALSE
CALL AddToScoreCrd(it, DataRef(IL, it), "6", "SB")
'to zero out score reference on additional score card lines:
RunsBeforePlay = itruns(it)
'Credit guy now on third with a SB
IF ir3 THEN
INCR msb(DataRef(ir3, it), it)
CALL AddToScoreCrd(it, DataRef(ir3, it), "6", "SB")
END IF
'Credit guy now on second with a SB
IF ir2 THEN
INCR msb(DataRef(ir2, it), it)
CALL AddToScoreCrd(it, DataRef(ir2, it), "6", "SB")
END IF
ELSE
'Out at home
INCR mcs(DataRef(ir3, it), it)
IF DelFac THEN
CALL Msg ("14", "0", "0", "04", ir3, it, man2, team2) 'OUT
CALL Msg ("40", "0", "0", "00", 0, it, man2, team2) '!!!
END IF
IL = ir3
ir3 = ir2
ir2 = ir1
ir1 = 0
IF ir2 THEN INCR msb(DataRef(ir2, it), it)
IF ir3 THEN INCR msb(DataRef(ir3, it), it)
INCR PutOuts(DataRef(WHOATGUY(2), id), id, 2)
IF DataHand(ib, it) = "R" THEN n = 4 ELSE n = 6
INCR Assists(DataRef(WHOATGUY(n), id), id, n)
INCR iout
INCR mpo(ip, id)
fr7 = 90 'signals runner thrown out
' CALL AddToScoreCrd(it, DataRef(IL, it), "1", "X-CS")
CALL AddToScoreCrd(it, DataRef(IL, it), "4", "CS " + LTRIM$(STR$(n)) + "-2")
END IF
17900 : 'Reset batter pointer and ABs
CALL ResetBatter
EXIT SUB
CreditSB:
'Credit lead runner with Stolen Base
'We have not called ADVANC yet
INCR msb(DataRef(IL, it), it)
'Credit trailing runner with SB also
ITrail = 0
IF IL = ir2 THEN
IF ir1 AND DoubleSteal THEN
INCR msb(DataRef(ir1, it), it)
ITrail = ir1
END IF
END IF
RETURN
ErrorTrap:
LOCATE 10, 30
PRINT "STEAL_Error"; ERRCLEAR
x$ = WAITKEY$
END SUB
SUB StrikeOutRoutine
INCR iout
INCR mso(ref, it) 'credit hitter
IF UCASE$(DataHand(ip, id)) = "L" THEN
INCR msoLHP(ref, it)
ELSE
INCR msoRHP(ref, it)
END IF
INCR mpo(ip, id) 'credit pitcher
INCR mpk(ip, id) ' " " " " "
INCR PutOuts(DataRef(WHOATGUY(2), id), id, 2) 'give catcher a PutOut
'Struck him out!
IF DelFac THEN
IF HitAndRun THEN
AddtoAnnouncer it, "Swing and a miss!"
AddtoAnnouncer it, "Struck him out!"
CALL WavWhiff
ELSE
t$ = PADZEROS$( LTRIM$(STR$(RND(1, 2))) , 2)
CALL Msg ("19", "0", "1", t$, ib, it, man2, team2)
CALL Msg ("19", "0", "2", t$, ib, it, man2, team2)
IF t$ = "01" THEN CALL WavWhiff ELSE CALL WavPopMitt
END IF
END IF
Result$ = "K"
'
' DTS - Dropped Third Strike
'
'Not sure about the rule
IF ir1 = 0 AND ir2 = 0 AND ir3 = 0 THEN 'nobody on
'Wild Pitch or Passed Ball on third strike?
pbal = 0
wpit = 0
xF! = RND
yF! = DataBB(ip,id) / BattersFacedByPit! (DataAB(ip,id), DataHits(ip,id), DataBB(ip,id), DataSO(ip,id))
wp! = .017 * (yF! / pwbaseF(id)) / 9
IF xF! < wp! THEN
WildPit(id) = WildPit(id) + PADZEROS$(LTRIM$(STR$(ip)), 2)
Result$ = Result$ + "-DTS WP"
wpit = -1
ELSE
nn = WHOATGUY(2)
defperF! = DEFPCT!(nn)
zF! = (1.0 - defperF!) * .03
IF xF! < wp! + zF! THEN
PassedB(id) = PassedB(id) + PADZEROS$(LTRIM$(STR$(DataRef(nn, id))), 2)
Result$ = Result$ + "-DTS PB"
pbal = -1
ELSE
EXIT SUB
END IF
END IF
'Back out of some of the stats
DECR iout
DECR mpo(ip, id)
DECR PutOuts(DataRef(WHOATGUY(2), id), id, 2)
'Announcer
IF DelFac THEN
AddToAnnouncer id, "The ball gets away!"
AddToAnnouncer it, "And the batter is going to be safe at first!"
IF wpit THEN AddToAnnouncer id, "Score that one a 'wild pitch'"
IF pbal THEN AddToAnnouncer id, "Score that one a 'passed ball'"
END IF
'Put Batter on
ir1 = ib
mpp(ib) = ip
mpp(ib) = -mpp(ib)
END IF
END SUB
SUB Switch (p1, p2, team)
IF p1 < 1 OR p1 > MAXPLAYERS THEN
x$ = "Bad call to player switch: P1=" + STR$(p1)
CALL ErrorBox (x$)
GOTO SwEsc
END IF
IF p2 < 1 OR p2 > MAXPLAYERS THEN
x$ = "Bad call to player switch: P2=" + STR$(p2)
CALL ErrorBox (x$)
GOTO SwEsc
END IF
IF team < 1 OR team > 2 THEN
x$ = "Bad call to player switch: team=" + STR$(team)
CALL ErrorBox (x$)
GOTO SwEsc
END IF
SWAP iused(p1, team), iused(p2, team)
SWAP DataName(p1, team), DataName(p2, team)
SWAP DataPlat(p1, team), DataPlat(p2, team)
SWAP DataHand(p1, team), DataHand(p2, team)
SWAP DataCode(p1, team), DataCode(p2, team)
SWAP DataRef(p1, team), DataRef(p2, team)
SWAP DataPos(p1, team), DataPos(p2, team)
SWAP DataAB(p1, team), DataAB(p2, team)
SWAP DataHits(p1, team), DataHits(p2, team)
SWAP Data2B(p1, team), Data2B(p2, team)
SWAP Data3B(p1, team), Data3B(p2, team)
SWAP DataHR(p1, team), DataHR(p2, team)
SWAP DataBB(p1, team), DataBB(p2, team)
SWAP DataHP(p1, team), DataHP(p2, team)
SWAP DataSO(p1, team), DataSO(p2, team)
SWAP DataRBI(p1, team), DataRBI(p2, team)
SWAP DataDef(p1, team), DataDef(p2, team)
SWAP DataSB(p1, team), DataSB(p2, team)
SWAP DataCS(p1, team), DataCS(p2, team)
SWAP DataGames(p1, team), DataGames(p2, team)
FOR i = 1 TO 4
SWAP DataPosi(p1, team, i), DataPosi(p2, team, i)
SWAP DataGByP(p1, team, i), DataGByP(p2, team, i)
NEXT
SWAP DataSpeed(p1, team), DataSpeed(p2, team)
'SWAP DataPBatAB(p1, team), DataPBatAB(p2, team)
'SWAP DataPBatHi(p1, team), DataPBatHi(p2, team)
'SWAP DataPBatHR(p1, team), DataPBatHR(p2, team)
'SWAP DataPBatBB(p1, team), DataPBatBB(p2, team)
'SWAP DataPBatSO(p1, team), DataPBatSO(p2, team)
SwEsc:
END SUB
SUB SwitchToDH (tm)
FOR i = 1 TO 9
IF DataPos(i, tm) = 10 AND DataName(i, tm) > "A" THEN EXIT SUB
NEXT
' Create a hole for the DH and bring 1st player on bench into it
CALL Switch(8, 9, tm)
CALL Switch(7, 8, tm)
CALL Switch(6, 7, tm)
CALL Switch(5, 6, tm)
'Normally the pitcher will now be in slot 5, but that is not the case if
'in the .DAT file he bats something other than 9
'So, find the pitcher:
ps = 0
FOR i = 1 TO 9
IF DataPos(i, tm) = 1 THEN ps = i : EXIT FOR
NEXT
IF ps > 0 THEN
CALL Switch(ps, LastPiAd(tm) + 1, tm)
DataPos(ps, tm) = 10
ELSE
x$ = "No Pitcher Found in .DAT"
CALL ErrorBox (x$)
END IF
'Rotate the garbage in slot LastPiAd + 1 down to slot MAXPLAYERS
i = LastPiAd(tm) + 1
DO
CALL Switch(i, i + 1, tm)
INCR i
LOOP UNTIL i > MAXPLAYERS - 1
DataPos(MAXPLAYERS, tm) = 0
DataName(MAXPLAYERS, tm) = SPACE$(18)
FOR i = 1 TO 4
DataPosi(MAXPLAYERS, tm, i) = 0
DataGByP(MAXPLAYERS, tm, i) = 0
NEXT
END SUB
SUB SwitchToNoDH (tm)
'Look for DH already in lineup
s = 0
PitSlot = 0
FOR i = 1 TO 9
IF DataPos(i, tm) = 10 AND DataName(i, tm) > "A" THEN s = i
IF DataPos(i, tm) = 1 THEN PitSlot = i
NEXT
IF s = 0 THEN
IF PitSlot = 0 THEN PitSlot = 9
GOTO SwitchToNoDHX
END IF
' DH is in slot "s" -- get rid of it
' we assume no pitcher is in the lineup
' Push down bench - clear spot in LastPiAd + 1
i = MAXPLAYERS
DO
CALL Switch(i - 1, i, tm)
DECR i
LOOP UNTIL i = LastPiAd(tm) + 1
' Put former DH on the bench, position left field
CALL Switch(s, LastPiAd(tm) + 1, tm)
DataPos(LastPiAd(tm) + 1, tm) = 7
' Collapse starting lineup around where DH used to be
i = s
DO UNTIL i > 8
CALL Switch(i + 1, i, tm)
INCR i
LOOP
PitSlot = 9
SwitchToNoDHX:
' Move Pitcher's hitting stats to PitSlot
CALL MovePitHitStats (PitSlot, tm)
END SUB
SUB ThrowOutCheck (B1, B2, ThrowOutChance1, ThrowOutChance2, ThrowToThird, ConcedeRun) STATIC
ON ERROR GOTO ERRORTRAP
'Possibly throw out a baserunner:
'In: B1, B2 [number of bases to attempt to advance for 1st & 2nd, resp.]
'call this routine BEFORE Advanc
'We can't handle 2 people being thrown out on the same play, so as soon
'as someone gets nailed, return.
IF HitAndRun THEN xF! = .999 ELSE xF! = RND
IF HitType = 1 THEN
'Nobody gets thrown out if winning run will score from third
IF inn >= RegInns AND it = 2 THEN
IF ir3 > 0 THEN
IF itruns(2) + 1 > itruns(1) THEN
EXIT SUB
END IF
END IF
END IF
IF ir2 > 0 THEN
IF B2 = 2 THEN 'On a single can R/2nd score?
IF DelFac THEN
IF ThrowToThird THEN
' * scores as the throw goes to third...
CALL Msg ("31", "0", "0", "12", ir2, it, man2, team2)
ELSE
IF ConcedeRun = TRUE THEN
'* will score without a throw...
CALL Msg ("31", "0", "0", "15", ir2, it, man2, team2)
ELSE
'Rounds third and heads for home...
CALL Msg ("31", "0", "0", "01", ir2, it, man2, team2)
AddToAnnouncer it, "He is...."
END IF
END IF
END IF
yF! = ThrowOutChance1 / 100.0
IF xF! < yF! THEN
INCR mpo(ip, id)
IF DelFac THEN CALL Msg ("14", "0", "0", "07", ir2, it, man2, team2) 'OUT
ref2 = DataRef(ir2, it)
' "X-@Home"
Result2$ = LTRIM$(STR$(WhoAtPos)) + "-2"
Code2$ = "4"
INCR Assists(DataRef(WHOATGUY(WhoAtPos), id), id, WhoAtPos)
INCR PutOuts(DataRef(WHOATGUY(2), id), id, 2)
ir2 = 0
EXIT SUB
ELSE
IF DelFac THEN
IF ThrowToThird = FALSE AND ConcedeRun = FALSE THEN CALL Msg ("15", "0", "0", "09", ir2, it, man2, team2) 'SAFE
END IF
RunAnnounced = TRUE
END IF
ELSE
'slams on the brakes at third..."
IF DelFac THEN CALL Msg ("16", "0", "0", "03", ir2, it, man2, team2)
EXIT SUB
END IF
END IF
IF ir1 > 0 THEN
IF B1 = 2 THEN 'On a single can R/1st goto 3rd?
'* heads for third
IF DelFac THEN CALL Msg ("31", "0", "0", "02", ir1, it, man2, team2)
yF! = ThrowOutChance2 / 100.0
IF xF! < yF! + .15 THEN
IF DelFac THEN
'They've got a shot at him...
CALL Msg ("31", "0", "0", "13", ir1, it, man2, team2)
AddToAnnouncer it, "He is..."
END IF
END IF
IF xF! < yF! THEN
INCR mpo(ip, id)
IF DelFac THEN CALL Msg ("14", "0", "0", "03", ir1, it, man2, team2) 'OUT
ref2 = DataRef(ir1, it)
' Result2$ = "X-@3rd"
Result2$ = LTRIM$(STR$(WhoAtPos)) + "-5"
Code2$ = "3"
INCR Assists(DataRef(WHOATGUY(WhoAtPos), id), id, WhoAtPos)
INCR PutOuts(DataRef(WHOATGUY(5), id), id, 5)
ir1 = 0
EXIT SUB
ELSE
IF ANx > 2 THEN t$ = "09" ELSE t$ = "06"
IF DelFac THEN CALL Msg ("15", "0", "0", t$, ir1, it, man2, team2) 'SAFE
'He's in there...
'error possibility:
END IF
ELSE
'* stops at 2nd
IF DelFac THEN CALL Msg ("16", "0", "0", "02", ir1, it, man2, team2) 'HOLD
END IF
END IF
END IF
IF HitType = 2 AND ir1 > 0 THEN
'Nobody gets thrown out if winning run will score from 2nd or 3rd
IF inn >= RegInns AND it = 2 THEN
LeadRunners = 0
IF ir3 > 0 THEN INCR LeadRunners
IF ir2 > 0 THEN INCR LeadRunners
IF itruns(2) + LeadRunners > itruns(1) THEN
EXIT SUB
END IF
END IF
IF B1 = 3 THEN 'taking 3 bases on a double
'* rounds third
IF DelFac THEN
CALL Msg ("31", "0", "0", "01", ir1, it, man2, team2)
AddToAnnouncer it, "He is...."
END IF
yF! = ThrowOutChance1 / 100.0
IF xF! < yF! THEN
INCR mpo(ip, id)
'OUT at the plate!
IF DelFac THEN CALL Msg ("14", "0", "0", "07", ir1, it, man2, team2) 'OUT
ref2 = DataRef(ir1, it)
' Result2$ = "X-@Home"
Result2$ = LTRIM$(STR$(WhoAtPos)) + "-2"
Code2$ = "4"
INCR Assists(DataRef(WHOATGUY(WhoAtPos), id), id, WhoAtPos)
INCR PutOuts(DataRef(WHOATGUY(2), id), id, 2)
ir1 = 0
ELSE
IF DelFac THEN 'SAFE
AddToAnnouncer it, "SAFE!"
RunAnnounced = TRUE
END IF
END IF
ELSE
'* holds on at third
IF DelFac THEN CALL Msg ("16", "0", "0", "03", ir1, it, man2, team2) 'HOLD
END IF
END IF
EXIT SUB
ErrorTrap:
LOCATE 10, 30
PRINT "THROWOUT_Error"; ERRCLEAR
x$ = WAITKEY$
END SUB
SUB TripleDialog (wag)
x! = RND
IF WhoAtPos = 8 THEN
i = RND(1, 3)
ELSEIF WhoAtPos = 7 THEN
IF x! < .33 THEN
i = 1
ELSEIF x! < .67 THEN
i = 3
ELSE
i = 4
END IF
ELSE '9
IF x! < .33 THEN
i = 1
ELSEIF x! < .67 THEN
i = 2
ELSE
i = 4
END IF
END IF
t$ = LTRIM$(STR$(i))
t$ = PADZEROS$(t$, 2)
CALL Msg ("10", "0", "1", t$, 0, it, man2, team2) 'long drive
IF t$ <> "04" THEN m = wag: n = id ELSE m = ib: n = it
CALL Msg ("10", "0", "2", t$, m, n, man2, team2) '* going back
IF t$ = "01" THEN m = wag: n = id ELSE m = ib: n = it
CALL Msg ("10", "0", "3", t$, m, n, man2, team2) 'over his head
IF ir3 > 0 THEN CALL AnnScoring(ir3)
IF ir2 > 0 THEN CALL AnnScoring(ir2)
IF ir1 > 0 THEN CALL AnnScoring(ir1)
END SUB
SUB TripleRoutine
ppF! = FindPP!
WhoAtPos = OUTFIELDWHOAT (ppF!)
wag = WHOATGUY (WhoAtPos)
IF DelFac THEN CALL TripleDialog (wag)
CALL Advanc(3, 2, 1)
IF DelFac THEN
IF SoundOn THEN CALL WavRegularHit
CALL Msg ("10", "0", "4", "00", ib, it, man2, team2) 'he's not stopping
CALL Msg ("10", "0", "5", "00", ib, it, man2, team2) 'triple
END IF
ir3 = ib
mpp(ib) = ip
CALL CreditHit
INCR m3b(ref, it)
IF UCASE$(DataHand(ip, id)) = "L" THEN
INCR m3bLHP(ref, it)
ELSE
INCR m3bRHP(ref, it)
END IF
INCR mp3b(ip, id)
Result$ = "3B"
END SUB
SUB TwoTeamSetup (row, Flds, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
CALL Drawfrm(row+rowO, 12+colO, row+rowO+16, 69+colO, defattr, "Simulation Options", "ESC (or close window) to continue", 1, 0, 1)
COLOR 7, defbac
DATA 02,14,"How many games do you want to simulate?",02,54,6,"N "
DATA 04,14,"Auto-Lineup (Visitor) [y/N] ",04,53,01,"XR"
DATA 06,14," (Home) [y/N] ",06,53,01,"XR"
DATA 08,14,"Adjust Batting Order(Visitor)[y/N/c/f] ",08,53,01,"XR"
DATA 10,14," (Home) [y/N/c/f] ",10,53,01,"XR"
DATA 12,14,"Use Designated-Hitter? [Y/N] ",12,53,01,"XR"
DATA 14,14,"Use Spot Starters? [y/N] ",14,53,01,"XR"
Flds = 7
c = 1
FOR i = 1 TO Flds
Flitrow(i) = VAL(READ$(c)) + row + rowO
Flitcol(i) = VAL(READ$(c+1)) + colO
Flit$(i) = READ$(c+2)
Frow(i) = VAL(READ$(c+3)) + row + rowO
Fcol(i) = VAL(READ$(c+4)) + colO
Flen(i) = VAL(READ$(c+5))
Fed$(i) = READ$(c+6)
c = c + 7
NEXT
'Set Defaults
REDIM FContents$(13)
FContents$(2) = "N"
FContents$(3) = "N"
FContents$(4) = "N"
FContents$(5) = "N"
FContents$(6) = DefaultDHResponse$
FContents$(7) = "N"
END SUB
SUB TwoTeamIO (RetKey, Flds, CursorPtr, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
DO
TopOfTTLoop:
CALL ScreenIO(Keyed, KeyEsc, 0, KeyEsc, Flds, CursorPtr, Flen(), Frow(), Fcol(), Fed$(), Flit$(), Flitrow(), Flitcol(), FContents$())
'Edit Field Contents
Error1$ = "N"
i = 1
DO
IF i = 1 THEN
n = VAL(FContents$(i))
IF n < 1 THEN
Error1$ = "Y": CursorPtr = i: CALL MyBeep: GOTO TopOfTTLoop
END IF
ELSEIF i = 4 OR i = 5 THEN
IF FContents$(i) <> "Y" AND FContents$(i) <> "N" AND FContents$(i) <> "C" AND FContents$(i) <> "F" THEN
Error1$ = "Y": CursorPtr = i: CALL MyBeep: GOTO TopOfTTLoop
END IF
ELSE
IF FContents$(i) <> "Y" AND FContents$(i) <> "N" THEN
Error1$ = "Y": CursorPtr = i: CALL MyBeep: GOTO TopOfTTLoop
END IF
END IF
INCR i
LOOP UNTIL i > 7
LOOP WHILE Error1$ = "Y"
CURSOR OFF 'turn off cursor
END SUB
SUB TwoTeamStarters(tm, N)
'[in: tm out: N]
ResetList:
REDIM SelectedPit$(5)
REDIM SelectedRef(5)
SelX = 0
DO
CALL Drawfrm(18+rowO, 30+colO, 24+rowO, 50+colO, defattr, "Selected", nulls$, 0, 0, 0)
FOR i = 1 TO SelX
QPRINTs 18+rowO+i, 32+colO, SelectedPit$(i), dimattr
NEXT
r = 3
CALL PickTheStarter(tm, r, N) '[ENTER or [ESC] gets out of here
IF N > 0 THEN '[ENTER]
IF SelX < 5 THEN
INCR SelX
SelectedPit$(SelX) = DataName(N, tm)
SelectedRef(SelX) = N
END IF
END IF
IF N = 0 THEN '[ESC] '17,58 24,71 1,33 8,46
attr = (3 * 16) + 15
CALL GetScreen(Scr1$, 1+rowO, 33+colO, 8+rowO, 46+colO)
CALL Drawfrm(1+rowO, 33+colO, 8+rowO, 46+colO, attr, nulls$, nulls$, 0, 0, 0)
CALL Button( 2+rowO, 35+colO, errattr, " [O]K ", 1)
CALL Button( 4+rowO, 35+colO, errattr, " C[L]ear ", 1)
CALL Button( 6+rowO, 35+colO, errattr, " [C]ancel ", 1)
xS$ = WAITKEY$
IF LEN(xS$) = 4 THEN
msy = MOUSEY
msx = MOUSEX
xS$ = UCASE$(CHR$(SCREEN(msy, msx)))
CALL FlashField (msy, msx, 1, 2, 100, 0)
ELSE
xS$ = UCASE$(xS$)
END IF
IF xS$ = "O" OR xS$ = CHR$(13) THEN 'OK
EXIT DO
ELSEIF xS$ = "C" THEN 'Cancel
EXIT SUB
ELSE 'Clear
CALL PutScreen(Scr1$, 1+rowO, 33+colO, 8+rowO, 46+colO)
GOTO ResetList
END IF
END IF
LOOP
'Copy to rotation record [OK]
i = ROTATIONLIST (DataFil(tm)) 'Find Rot record for this team
IF i = 0 THEN
IF RTx < 1500 THEN
INCR RTx
i = RTx
END IF
END IF
CmdSP$ = "S" + LTRIM$(STR$(SelX))
RotRec(i).RotTeam = DataFil(tm) 'Update this Rot record
RotRec(i).RotMeth = CmdSP$
IF (tm = 1 AND CmdVSpot$ = "Y") OR _
(tm = 2 AND CmdHSpot$ = "Y") OR _
CmdSpot$ = "Y" THEN
RotRec(i).RotSpot = "Y"
ELSE
RotRec(i).RotSpot = " "
END IF
RotRec(i).RotIndex = 1
FOR j = 1 TO 5
RotRec(i).RotList(j) = 0
NEXT
FOR j = 1 TO SelX
RotRec(i).RotList(j) = SelectedRef(j)
NEXT
N = RotRec(i).RotList(1)
END SUB
SUB UpdSCHRecord1 (a$)
IF ProtectSCH THEN EXIT SUB
'Find CmdSTAT$ in the 1st record of the SCH file - or stop at 1st blank slot
GET #2, 1, SchBuffer$
i = 3
DO
i = i + 8
xS$ = MID$(SchBuffer$, i, 8)
IF UCASE$(RTRIM$(xS$)) = UCASE$(RTRIM$(CmdStat$)) THEN EXIT DO
LOOP UNTIL xS$ = SPACE$(8)
'Either found the current STAT file: i points to it OR
'Didn't find it: i points to first available slot OR
'There wasn't a STAT file: i = 11
IF a$ = "DEL" THEN
'Remove and collapse if found a STAT file
IF xS$ > "!" THEN
L = 91 - (i + 8)
MID$(SchBuffer$, i, L) = MID$(SchBuffer$, i + 8, L)
MID$(SchBuffer$, 83, 8) = SPACE$(8)
END IF
ELSE
'Update SCH w/current STAT file
IF CmdStat$ > "!" THEN
MID$(SchBuffer$, i, 8) = CmdStat$
END IF
END IF
PUT #2, 1, SchBuffer$
END SUB
SUB VisitorOptions (Pick)
REDIM List1(1 TO 10) AS List1Type
IF it = 1 THEN
List1(1).ListItem = " Pinch Hit "
List1(2).ListItem = " Pinch Run "
List1(3).ListItem = " View Lineup "
List1(4).ListItem = " View Opponent "
List1(5).ListItem = " Call Bullpen "
IF WarmUpRule = FALSE THEN List1(5).ListItem = "%" + List1(5).ListItem
List1(6).ListItem = STRING$(27,CHR$(196))
List1(7).ListItem = " Steal "
List1(8).ListItem = " Bunt/Squeeze "
List1(9).ListItem = " Hit and Run "
CALL Drawfrm(10+rowO, 8+colO, 20+rowO, 38+colO, defattr, RTRIM$(Names(1)), "", 0, 0, 2)
CALL PickFromList(List1(), 9, 9, 1, 27, 10+rowO, 8+colO, 20+rowO, 38+colO, dimattr, revattr, Pick, RetKey, nulls$, mous, ms$)
SELECT CASE Pick
CASE 1
PH = TRUE
CASE 2
PRun = TRUE
CASE 3
ViewVisi = TRUE
CASE 4
ViewHome = TRUE
CASE 5
BullO = TRUE
CASE 7
Steal = TRUE
CASE 8
Bunt = TRUE
CASE 9
HitAndRun = TRUE
CASE ELSE
END SELECT
ELSE
List1(1).ListItem = " Visit Mound "
List1(2).ListItem = " Player Substitution "
List1(3).ListItem = " Swap Positions "
List1(4).ListItem = " View Line-up "
List1(5).ListItem = " View Opponent "
List1(6).ListItem = STRING$(27, CHR$(196))
List1(7).ListItem = " Intentional Walk "
List1(8).ListItem = " Infield Tight "
List1(9).ListItem = " Pitch-Out "
List1(10).ListItem =" Pitch-Around "
CALL Drawfrm(10+rowO, 8+colO, 21+rowO, 38+colO, defattr, RTRIM$(Names(1)), "", 0, 0, 2)
CALL PickFromList(List1(), 10, 10, 1, 27, 10+rowO, 8+colO, 21+rowO, 38+colO, dimattr, revattr, Pick, RetKey, nulls$, mous, ms$)
SELECT CASE Pick
CASE 1
BullD = TRUE
CASE 2
SubX = TRUE
CASE 3
SwPos = TRUE
CASE 4
ViewVisi = TRUE
CASE 5
ViewHome = TRUE
CASE 7
IWalk = TRUE
CASE 8
Tight = TRUE
CASE 9
POut = TRUE
CASE 10
PAround = TRUE
CASE ELSE
END SELECT
END IF
ERASE List1
END SUB
SUB WalkRoutine
IF DelFac THEN
IF SoundOn THEN CALL WavPopMitt
IF IWalk THEN
CALL Msg ("18", "0", "0", "02", ib, it, man2, team2)
ELSE
CALL Msg ("18", "0", "0", "01", ib, it, man2, team2)
END IF
END IF
IF ir3 <> 0 AND ir2 <> 0 AND ir1 <> 0 THEN 'Bases Loaded
CALL Advanc(1, 1, 1)
ELSEIF ir1 THEN 'Runner on First
IF ir2 THEN 'Also on Second
CALL Advanc(1, 1, 0)
ELSE 'Nobody on Second
CALL Advanc(1, 0, 0)
END IF
END IF
' ** PUT BATTER ON 1ST **
ir1 = ib
mpp(ib) = ip
DECR mab(ref, it)
IF UCASE$(DataHand(ip, id)) = "L" THEN
DECR mabLHP(ref, it)
INCR mbbLHP(ref, it)
ELSE
DECR mabRHP(ref, it)
INCR mbbRHP(ref, it)
END IF
INCR mbb(ref, it)
INCR mpw(ip, id)
IF IWalk THEN
Result$ = "Int BB"
ELSE
Result$ = "BB"
END IF
END SUB
SUB WavBunt
IF NOT SoundOn THEN EXIT SUB
DIM WavList$(2)
WavList$(1) = "57435.wav"
WavList$(2) = "57435.wav"
i = FRND(2)
L = PlayWav(WavList$(i))
SLEEP 400
END SUB
SUB WavPopUp
IF NOT SoundOn THEN EXIT SUB
DIM WavList$(2)
WavList$(1) = "3017.wav"
WavList$(2) = "37979.wav"
i = FRND(2)
L = PlayWav(WavList$(i))
SLEEP 400
END SUB
SUB WavShortFly
IF NOT SoundOn THEN EXIT SUB
DIM WavList$(2)
WavList$(1) = "37880.wav"
WavList$(2) = "3017.wav"
i = FRND(2)
L = PlayWav(WavList$(i))
SLEEP 400
END SUB
SUB WavRegularFly
IF NOT SoundOn THEN EXIT SUB
DIM WavList$(4)
WavList$(1) = "3017.wav"
WavList$(2) = "57430.wav"
WavList$(3) = "37979.wav"
WavList$(4) = "hit.wav"
i = FRND(4)
L = PlayWav(WavList$(i))
SLEEP 400
END SUB
SUB WavBigFly
IF NOT SoundOn THEN EXIT SUB
DIM WavList$(4)
WavList$(1) = "37830.wav"
WavList$(2) = "37830.wav"
WavList$(3) = "57430.wav"
WavList$(4) = "hit.wav"
i = FRND(4)
L = PlayWav(WavList$(i))
SLEEP 400
IF IGone AND CmdHRWav$ > "!" THEN
L = PlayWav(CmdHRWav$)
END IF
END SUB
SUB WavLineDrive
IF NOT SoundOn THEN EXIT SUB
DIM WavList$(2)
WavList$(1) = "57430.wav"
WavList$(2) = "hit.wav"
i = FRND(2)
L = PlayWav(WavList$(i))
SLEEP 400
END SUB
SUB WavRegularHit
IF NOT SoundOn THEN EXIT SUB
DIM WavList$(4)
WavList$(1) = "57430.wav"
WavList$(2) = "57430.wav"
WavList$(3) = "3017.wav"
WavList$(4) = "hit.wav"
i = FRND(4)
L = PlayWav(WavList$(i))
SLEEP 400
END SUB
SUB WavSoftGrounder
IF NOT SoundOn THEN EXIT SUB
DIM WavList$(2)
WavList$(1) = "57435.wav"
WavList$(2) = "37906.wav"
i = FRND(2)
L = PlayWav(WavList$(i))
SLEEP 400
END SUB
SUB WavRegularGrounder
IF NOT SoundOn THEN EXIT SUB
DIM WavList$(3)
WavList$(1) = "61400.wav"
WavList$(2) = "61714.wav"
WavList$(3) = "hit.wav"
i = FRND(3)
L = PlayWav(WavList$(i))
SLEEP 400
END SUB
SUB WavWhiff
IF NOT SoundOn THEN EXIT SUB
DIM WavList$(2)
WavList$(1) = "21904.wav"
WavList$(2) = "61817.wav"
i = FRND(2)
L = PlayWav(WavList$(i))
SLEEP 400
END SUB
SUB WavPopMitt
IF NOT SoundOn THEN EXIT SUB
DIM WavList$(4)
WavList$(1) = "37909.wav"
WavList$(2) = "37910.wav"
WavList$(3) = "37910.wav"
WavList$(4) = "60290.wav"
i = FRND(4)
L = PlayWav(WavList$(i))
SLEEP 400
END SUB
'************* MISC GRAPHICS SUBROUTINES *****************
SUB HideGfx
GfxWindow %GFX_HIDE
END SUB
SUB ShowGfx
GfxWindow %GFX_SHOW
END SUB
SUB UnfreezeAndRefresh
GfxWindow NOT %GFX_FREEZE
GfxRefresh 0
GfxWindow %GFX_FREEZE
END SUB
SUB GraphHole (hole, row1, col1, row2, col2)
IF NOT Gfx THEN EXIT SUB
IF HoleStatus(hole) = -1 THEN EXIT SUB
'Could eliminate this nonsense if I passed the parameters "by value" I think
trow1 = row1
tcol1 = col1
trow2 = row2
tcol2 = col2
IF tcol1 < 1 THEN tcol1 = 1
IF tcol2 < 1 THEN tcol2 = 1
IF tcol1 > ConsCols THEN tcol1 = ConsCols
IF tcol2 > ConsCols THEN tcol2 = ConsCols
IF tcol2 < tcol1 THEN EXIT SUB
IF trow1 < 6 THEN trow1 = 6
IF trow2 < 6 THEN trow2 = 6
IF trow1 > ConsRows-1 THEN trow1 = ConsRows-1
IF trow2 > ConsRows-1 THEN trow2 = ConsRows-1
IF trow2 < trow1 THEN EXIT SUB
res = GfxTextHole (hole, tcol1, trow1, tcol2, trow2)
IF res = 0 THEN
HoleStatus(hole) = -1
ELSE
HoleStatus(hole) = 0
LOCATE 2, 50: PRINT " Bad Hole:" + STR$(hole) + " ": zz$ = WAITKEY$
END IF
END SUB
SUB EliminateHole (hole)
IF NOT Gfx THEN EXIT SUB
IF HoleStatus(hole) = 0 THEN EXIT SUB
res = FillHole (hole)
IF res = 0 THEN
HoleStatus(hole) = 0
ELSE
LOCATE 2, 50: PRINT " Bad fill:" + STR$(hole) + " ": zz$ = WAITKEY$
END IF
END SUB
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment