1  ! Copyright (C) 2024 Aleksander "olus2000" Sabak.
  2  ! See https://factorcode.org/license.txt for BSD license.
  3  USING: accessors arrays db db.sqlite db.tuples db.types
  4  io.backend io.directories kernel literals math math.functions
  5  math.parser namespaces sets sequences sequences.extras splitting
  6  strings ;
  7  IN: esolang_games.botc
  8  
  9  
 10  ! Model
 11  
 12  PREDICATE: alignment < string { "good" "evil" } in? ;
 13  
 14  
 15  TUPLE: player player-id elo ;
 16  
 17  : <player> ( player-id elo -- player ) player boa ;
 18  
 19  
 20  TUPLE: player-game
 21    player-id
 22    game-id
 23    { alignment maybe{ alignment } } ;
 24  
 25  : <player-game> ( player-id game-id alignment -- player-game )
 26    player-game boa ;
 27  
 28  
 29  TUPLE: game game-id { winning-side maybe{ alignment } } ;
 30  
 31  : <game> ( game-id winning-side -- game ) game boa ;
 32  
 33  
 34  ! Tables
 35  
 36  CONSTANT: botc-db-path
 37    $[ "vocab:esolang_games/botc/db.sqlite" normalize-path ]
 38  
 39  
 40  player "player"
 41  { { "player-id" "playerid" VARCHAR +user-assigned-id+ }
 42    { "elo" "elo" INTEGER } } define-persistent
 43  
 44  
 45  player-game "playergame"
 46  { { "player-id" "playerid" VARCHAR +user-assigned-id+
 47      { +foreign-id+ player "playerid" } }
 48    { "game-id" "gameid" INTEGER +user-assigned-id+
 49      { +foreign-id+ game "gameid" } }
 50    { "alignment" "alignment" VARCHAR } } define-persistent
 51  
 52  
 53  game "game"
 54  { { "game-id" "gameid" INTEGER +user-assigned-id+ }
 55    { "winning-side" "winningside" VARCHAR } } define-persistent
 56  
 57  
 58  CONSTANT: botc-tables { player game player-game }
 59  
 60  
 61  : with-botc-db ( ..a quot: ( ..a -- ..b ) -- ..b )
 62    botc-db-path <sqlite-db> swap with-db ; inline
 63  
 64  
 65  : ensure-botc-db ( -- )
 66    botc-db-path touch-file
 67    [ botc-tables ensure-tables ] with-botc-db ;
 68  
 69  
 70  : recreate-botc-db ( -- )
 71    [ botc-tables [ recreate-table ] each ] with-botc-db ;
 72  
 73  
 74  ! Quick inserting game
 75  
 76  ! Syntax:
 77  ! <game-nr> <winning-alignment>
 78  ! <player-name>;<player-alignment>
 79  ! <player-name>;<player-alignment>
 80  ! ...
 81  
 82  SYMBOL: current-game
 83  
 84  
 85  : parse-player ( player-string -- player-game )
 86    ";" split first2 current-game get swap <player-game> ;
 87  
 88  
 89  : parse-game ( game-string -- {player-game} game )
 90    split-lines unclip " " split first2
 91    [ string>number dup ] dip <game>
 92    [ current-game [ [ parse-player ] map ] with-variable ] dip ;
 93  
 94  
 95  : insert-game ( game-string -- )
 96    parse-game [ insert-tuple [ insert-tuple ] each ]
 97    with-botc-db ;
 98  
 99  
100  ! Stats
101  
102  : data-table ( {selectors} -- table )
103    [ T{ player } select-tuples swap
104      '[ _ [ call( player -- datum ) ] with map ] map ]
105    with-botc-db ;
106  
107  
108  : pretty-table ( {selectors} colnum -- ) 2drop ; ! TODO
109  
110  
111  : player-games ( player -- player-games )
112    f f <player-game> select-tuples ;
113  
114  
115  : player-alignment-games ( player alignment -- player-games )
116    f swap <player-game> select-tuples ;
117  
118  
119  : player-games>wins ( player-games -- games )
120    [ [ game-id>> ] [ alignment>> ] bi <game> select-tuples ]
121    map-concat ;
122  
123  
124  : win-rate ( player -- win-rate )
125    player-id>> player-games [ player-games>wins ] keep
126    [ length ] bi@ / ;
127    
128  
129  : score ( player -- score )
130    player-id>> player-games [ player-games>wins ] keep
131    [ length 1 + ] bi@ 1 + / ;
132  
133  ! Elo calculation
134  
135  
136  CONSTANT: starting-elo 1500
137  
138  
139  : add-player ( name -- )
140    starting-elo <player> [ insert-tuple ] with-botc-db ;
141  
142  
143  : game-id>player-games ( game-id -- {player-game} )
144    f swap f <player-game> select-tuples ;
145  
146  
147  : player-game>player ( player-game -- player )
148    player-id>> f <player> select-tuple ;
149  
150  
151  : game-id>game ( game-id -- game ) f <game> select-tuple ;
152  
153  
154  : predict-pairing ( good-elo evil-elo -- winrate )
155    - 10 400 / swap ^ 1 + 1 swap / ;
156  
157  
158  : predict-game ( good-players evil-players -- winrate )
159      [ [ elo>> ] map ] bi@
160      [ predict-pairing ] cartesian-map concat
161      [ sum ] [ length ] bi / ;
162  
163  
164  : update-player-elo ( player win-rate -- )
165    32 * round >integer '[ _ + ] change-elo update-tuple ;
166  
167  
168  : update-elo ( game-id -- )
169    [ [ game-id>player-games [ alignment>> "good" = ] partition
170      [ [ player-game>player ] map ] bi@ 2dup predict-game ] keep
171      game-id>game winning-side>> "evil" = [ 1 - ] when tuck -1 *
172      [ '[ _ update-player-elo ] each ] 2bi@ ] with-botc-db ;
173