Online ranking algorithm in clojure

ranking.clj

(ns gaming.online.ranking
  "Synopsis:
       (bradley-terry-full 5
         (list (create-team 1 45 (list (create-player 101 (create-ability-with-stddev 25 8))))
               (create-team 2 32 (list (create-player 102 (create-ability-with-stddev 25 8))))))

   Updates players' ability compared with how they were expected to perform")

; defn- means a private function
(defn- sum [f xs]
  (apply + (map f xs)))

(defn- plus-pair [[a1 a2] [b1 b2]]
 [(+ a1 b1) (+ a2 b2)])

(defn split-with-similar
  "Where split-with is like [(take-while pred xs) (drop-while pred xs)], this method is like
   recursive calls to split-with on the drop-while'd portion
   
   The predicate takes two arguments: the head of the current list, and the element to compare it
   against"
  [pred xs]
  (when xs
   ; loop/recur is how to do tail recursion in clojure
   ; 'let', 'do', 'for', 'loop' and function params can destructure collections like this next line 
   (loop [[head & tail] xs
          acc (vector)]
     (let [[like-head not-like-head] (split-with #(pred head %) tail)
           updated-acc (conj acc (cons head like-head))] ; conj is like cons, but works with vectors too
       (if (empty? not-like-head)
         acc
         (recur not-like-head updated-acc))))))



; defining a class called Ability with these fields. It acts much like a clojure map 
(defrecord Ability [mean stddev variance])

; keywords are also functions accepting a map
; maps are also functions accepting a key
; vectors are also functions accepting an index
(defn mean [ability] (:mean ability))
(defn stddev [ability] (:stddev ability))
(defn variance [ability] (:variance ability))

(defn create-ability-with-stddev [mean stddev]
  "Create ability from stddev"
  (Ability. mean stddev (* stddev stddev)))  ; how to call a java constructor

(defn create-ability-with-variance [mean variance]
  "Create ability from variance"
  (Ability. mean (Math/sqrt variance) variance)) ; call java static function




(defprotocol HasAbility
  "Both Player and Team have these methods. A protocol
   actually compiles down to a Java interface
   Another approach would be to use multi-methods." 
  (id [this])
  (ability [this]))

(defn skill
  "A single number representative of the player(s)'s true ability.
   For ranking purposes, this is chosen as a lower bound (with 95% confidence)
   on the player's true ability: it only goes up from here!
   With 95% confidence, the number is below the players true ability"
  [has-ability]
  (let [ability (ability has-ability)]
   (- (mean ability) (* 3 (stddev ability)))))


; shows how to implement a protocol/interface
(defrecord Player [id ability]
  HasAbility
  (id [this] (:id this))
  (ability [this] (:ability this)))

(defn create-player [id ability]
  (Player. id ability))
(defn copy-player [player ability]
  (create-player (:id player) ability))



(defrecord Team [id score ability players]
  HasAbility
  (id [this] (:id this))
  (ability [this] (:ability this)))

(defn create-team [id score players]
  (let [abilities (map ability players)
        mean (sum mean abilities)
        variance (sum variance abilities)]
    (Team. id score (create-ability-with-variance mean variance) players)))

(defn team-players [team] (:players team))
(defn team-size [team] (count (team-players team)))
(defn score [team] (:score team))





(def by-score-and-skill
  (reify java.util.Comparator ; implement a java comparator in place
    (compare [this a b]
      (or
        (first (drop-while zero?
          [(compare (score b) (score a))
           (compare (team-size b) (team-size a))
           (compare (skill b) (skill a))
           (compare (id a) (id b))]))
        0))))



(defn- score-within-allowance? [allowance]
  (fn [a b]           ; defining a lambda is done via 'fn'
   (<= (- (score a) allowance) (score b))))

(defn- calculate-ranks [rank-allowance teams]
  (loop [current-rank 0
         ranks {}
         [similar-head & similar-rest] (split-with-similar (score-within-allowance? rank-allowance) teams)]
    (let [updated-ranks (apply assoc ranks (flatten (map #(vector % current-rank) similar-head)))]
      (if (empty? similar-rest)
        updated-ranks
        (recur (+ current-rank (count similar-head))
               updated-ranks
               similar-rest)))))


(defn- update-player-abilities [player team-ability Omega Delta]
  (let [ability (ability player)
        variance-to-team-variance (/ (variance ability) (variance  team-ability))]
    (copy-player player
      (create-ability-with-stddev
        (+ (mean ability) (* Omega variance-to-team-variance))
        (* (stddev ability)
           (Math/sqrt (max (- 1 (* Delta variance-to-team-variance)) 0.0001)))))))
        


(defn- full-update
  "calc is a function expecting 2 params: team and opponent" 
  [teams calc]
 (concat
  (for [team teams ; map,for,reduce are "chunked lazy" so don't do side effects!
        :let [scores (for [opponent teams :when (not= opponent team)] (calc team opponent))
              [omega delta] (reduce plus-pair [0.0 0.0] scores)
               team-ability (ability team)]
        player (team-players team)]
    (update-player-abilities player team-ability omega delta))))

(defn bradley-terry-full [rank-allowance _teams]
  (when _teams ; nil is an empty list
   (let [mu 25.0
         sigma (/ mu 3.0)
         beta (* sigma 0.5)
         beta**2 (* beta beta)
         teams (sort by-score-and-skill _teams)
         ranks (calculate-ranks rank-allowance teams)
         gamma (/ 1.0 (count teams))]
      (full-update teams
        (fn [team opponent-team]
         (let [team-ability (ability team)
               rank (ranks team)
               opponent (ability opponent-team)
               c (Math/sqrt (+ (variance team-ability) (variance opponent) (* 2 beta**2)))
               p (/ 1.0 (+ 1 (Math/exp (/ (- (mean opponent) (mean team-ability)) c))))
               variance-to-c (/ (variance team-ability) c)
                  
               cmp-opponent-rank (compare rank (ranks opponent-team))
               s (cond (pos? cmp-opponent-rank) 1.0
                       (neg? cmp-opponent-rank) 0.0
                       :default 0.5)]
              [(* variance-to-c (- s p))
               (* gamma (/ variance-to-c c) p (- 1 p))]))))))





(defn- join [sep coll]
  (if (empty? coll)
    ""
    (loop [[head & tail] coll
           acc ""]
      (let [pretty-head (pr-str head)]
        (if (empty? tail)
          (str acc pretty-head)
          (recur tail (str acc pretty-head sep)))))))
         
(let [team1 (create-team 1 500 
              (list (create-player 1 (create-ability-with-stddev 25 8))
                    (create-player 2 (create-ability-with-stddev 27 5))
                    (create-player 3 (create-ability-with-stddev 22 3))))
      team2 (create-team 2 400
              (list (create-player 4 (create-ability-with-stddev 25 8))
                    (create-player 5 (create-ability-with-stddev 27 5))
                    (create-player 6 (create-ability-with-stddev 22 3))))
      team3 (create-team 3 395
              (list (create-player 7 (create-ability-with-stddev 25 8))
                    (create-player 8 (create-ability-with-stddev 27 5))
                    (create-player 9 (create-ability-with-stddev 22 3))))
      updated-players (bradley-terry-full 10 (list team1 team2 team3))]
  (println (join "\n" updated-players)))