SCA Chess
If there is a winner (not a draw):
If the winner's rating is 375 or less more than the loser's rating:
Winner's rating changes by:
16 added to it
and also
1/25 of the difference subtracted from it.
Loser's rating changes by:
16 subtracted from it
and also
1/25 of the difference added to it.
If the winner's rating is 376 or more greater than the loser's rating:
Winner's rating changes by:
1 added to it
Loser's rating changes by:
1 subtracted from it
If the winner's rating is 375 or less below the loser's rating:
Winner's rating changes by:
16 added to it
and also
1/25 of the difference added to it.
Loser's rating changes by:
16 subtracted from it
and also
1/25 of the difference subtracted from it.
If the winner's rating is 376 or more below the loser's rating:
Winner's rating changes by:
31 added to it
Loser's rating changes by:
31 subtracted from it
If it is a draw:
If the higher rated player's rating is 375 or less more than the opponent's rating:
Player's rating changes by:
1/25 of the difference subtracted from it.
Opponent's rating changes by:
1/25 of the difference added to it.
If the higher rated player's rating is 376 or more greater than the opponent's rating:
Player's rating changes by:
15 subtracted from it
Opponent's rating changes by:
15 added to it
Following is the Visual Basic for Application (VBA) code. The rating of interest is the Weekly Rating. The Permanent Rating is only used for internal comparison purposes. It is not the posted rating.
Public Sub Recalc_Ratings()
Dim Count As Integer ' Players left to process
Dim Games As Integer ' Games left to process
Dim WPRating As Integer ' Weekly Player Rating
Dim WORating As Integer ' Weekly Opponent Rating
Dim PPRating As Integer ' Permanent Player Rating
Dim PORating As Integer ' Permanent Opponent Rating
Dim DefaultRating As Integer ' Rating based on Group
Dim sqlCommand As String
Dim Group As String
Dim Outcome As String
Dim myDB As Object
Dim trs As Object
Dim grs As Object
Dim Dbug As Boolean
DoCmd.Hourglass True
Dbug = False
Set myDB = CurrentDb
Set trs = myDB.OpenRecordset("Ladder Players")
trs.MoveFirst
DoCmd.SetWarnings False
Do While Not trs.EOF
'''First reset all campers' ratings back to their start-of-week ratings based on group
If trs.Active Then
Group = trs.Group
DefaultRating = DLookup("[Initial Ladder Rating]", "Camp Groups", "Group = '" & Group & "'")
trs.Edit
trs!Rating = DefaultRating
trs.Update
End If
trs.MoveNext
trs.Close
'''Then reset all campers' permanent ratings back to their start-of-week permantent ratings
DoCmd.RunSQL ("Update [Ladder Players] SET [Permanent Rating] = [StWkPerm] " & _
"WHERE ACTIVE = YES")
''' Get next game from the [Ladder Games] table and process it
'''grs = Games Record Set
Set grs = myDB.OpenRecordset("Ladder Games")
Games = grs.RecordCount
If Games = 0 Then
'Nothing to calculate.
DoCmd.Hourglass False
DoCmd.SetWarnings True
Exit Sub
End If
grs.MoveFirst
Do While Not grs.EOF
WPRating = Nz(DLookup("[Rating]", "[Ladder Players]", "[ID] = " & grs.White))
WORating = Nz(DLookup("[Rating]", "[Ladder Players]", "[ID] = " & grs.Black))
PPRating = Nz(DLookup("[Permanent Rating]", "[Ladder Players]", "[ID] = " & grs.White))
PORating = Nz(DLookup("[Permanent Rating]", "[Ladder Players]", "[ID] = " & grs.Black))
Outcome = grs.Result
If Dbug Then MsgBox ("Before: Player = " & WPRating & " Opponent = " & WORating)
If Dbug Then MsgBox ("Result =[" & Outcome & "]")
If Outcome = "(1-0)" Then
'''Update the Permanent Rating for the player (winner)
sqlCommand = "UPDATE [Ladder Players] SET [Permanent Rating] = " & PPRating + 16 - _
IIf(Abs(PPRating - PORating) > 375, 15 * Sgn(PPRating - PORating), _
Int((Abs(PPRating - PORating)) / 25) * Sgn(PPRating - PORating)) _
& " WHERE [ID] = " & grs.White
If Dbug Then MsgBox (sqlCommand)
DoCmd.RunSQL (sqlCommand)
'''Update the Permanent Rating for the opponent (loser)
sqlCommand = "UPDATE [Ladder Players] SET [Permanent Rating] = " & PORating - 16 - _
IIf(Abs(PPRating - PORating) > 375, 15 * Sgn(PORating - PPRating), _
Int((Abs(PORating - PPRating)) / 25) * Sgn(PORating - PPRating)) _
& " WHERE [ID] = " & grs.Black
If Dbug Then MsgBox (sqlCommand)
DoCmd.RunSQL (sqlCommand)
'''Update the Weekly Rating for the player (winner)
sqlCommand = "UPDATE [Ladder Players] SET [Rating] = " & WPRating + 16 - _
IIf(Abs(WPRating - WORating) > 375, 15 * Sgn(WPRating - WORating), _
Int((Abs(WPRating - WORating)) / 25) * Sgn(WPRating - WORating)) _
& " WHERE [ID] = " & grs.White
If Dbug Then MsgBox (sqlCommand)
DoCmd.RunSQL (sqlCommand)
'''Update the Weekly Rating for the opponent (loser)
sqlCommand = "UPDATE [Ladder Players] SET [Rating] = " & WORating - 16 - _
IIf(Abs(WPRating - WORating) > 375, 15 * Sgn(WORating - WPRating), _
Int((Abs(WORating - WPRating)) / 25) * Sgn(WORating - WPRating)) _
& " WHERE [ID] = " & grs.Black
If Dbug Then MsgBox (sqlCommand)
DoCmd.RunSQL (sqlCommand)
Else ' must have been a draw
'''Update the Permanent Rating for the player
sqlCommand = "UPDATE [Ladder Players] SET [Permanent Rating] = " & PPRating - _
IIf(Abs(PPRating - PORating) > 375, 15 * Sgn(PPRating - PORating), _
Int((Abs(PPRating - PORating)) / 25) * Sgn(PPRating - PORating)) _
& " WHERE [ID] = " & grs.White
If Dbug Then MsgBox (sqlCommand)
DoCmd.RunSQL (sqlCommand)
'''Update the Permanent Rating for the opponent
sqlCommand = "UPDATE [Ladder Players] SET [Permanent Rating] = " & PORating - _
IIf(Abs(PPRating - PORating) > 375, 15 * Sgn(PORating - PPRating), _
Int((Abs(PORating - PPRating)) / 25) * Sgn(PORating - PPRating)) _
& " WHERE [ID] = " & grs.Black
DoCmd.RunSQL (sqlCommand)
'''Update the Weekly Rating for the player
sqlCommand = "UPDATE [Ladder Players] SET [Rating] = " & WPRating - _
IIf(Abs(WPRating - WORating) > 375, 15 * Sgn(WPRating - WORating), _
Int((Abs(WPRating - WORating)) / 25) * Sgn(WPRating - WORating)) _
& " WHERE [ID] = " & grs.White
DoCmd.RunSQL (sqlCommand)
'''Update the Weekly Rating for the opponent
sqlCommand = "UPDATE [Ladder Players] SET [Rating] = " & WORating - _
IIf(Abs(WPRating - WORating) > 375, 15 * Sgn(WORating - WPRating), _
Int((Abs(WORating - WPRating)) / 25) * Sgn(WORating - WPRating)) _
& " WHERE [ID] = " & grs.Black
DoCmd.RunSQL (sqlCommand)
End If
If Dbug Then MsgBox ("After: Player = " & Nz(DLookup("[Rating]", "[Ladder Players]", _
"[ID] = " & grs.White)) & _
"Opponent = " & Nz(DLookup("[Rating]", "[Ladder Players]", "[ID] = " & grs.Black)))
grs.MoveNext
DoCmd.SetWarnings True
grs.Close
DoCmd.Hourglass False
MsgBox ("Recalc Ratings Done")
End Sub