DnD5e hit and damage calculation using a monad to simulate dice

dnd5e_damage.ml

module type POSSIBLES = sig
   (* A monad to simulate all possible outcomes of a non-deterministic
    * operation with discrete outcomes such as dice rolling. *)

   type 'a t

   (** [return x] is the possible outcomes for an operation where [x] is the
    * only possible outcome. *)
   val return: 'a -> 'a t

   (** [bind os f] is the combined outcomes for all of the operations [f o]
    * where [o] spans over the outcomes [os]. *)
   val bind: 'a t -> ('a -> 'b t) -> 'b t
   val ( >>= ): 'a t -> ('a -> 'b t) -> 'b t

   (** [join os1 os2] is the combined outcomes from [os1] and [os2]. *)
   val join: 'a t -> 'a t -> 'a t

   val map: 'a t -> ('a -> 'b) -> 'b t
   val ( >|= ): 'a t -> ('a -> 'b) -> 'b t
   val lift: ('a -> 'b) -> 'a t -> 'b t
   val lift2: ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t

   (* The possibilities for a die of given sidedness*)
   val die: int -> int t

   (* interaction with the rest of the world *)
   val to_list: 'a t -> 'a list
   val of_list: 'a list -> 'a t
   val fold: ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b

end

module Possibles : POSSIBLES = struct
   type 'a t = 'a list
   let return x = [ x ]
   let bind x f = List.flatten (List.map f x)
   let ( >>= ) = bind
   let join = ( @ )
   let map x f = List.map f x
   let ( >|= ) = map
   let lift f x =
      x >>= fun xo ->
      return (f xo)
   let lift2 f x y =
      x >>= fun xo ->
      y >>= fun yo ->
      return (f xo yo)

   let die sidedness =
      let rec loop res i =
         if i <= 0 then
            res
         else
            loop (i :: res) (pred i)
      in
      loop [] sidedness

   let to_list t = t
   let of_list t = t
   let fold = List.fold_left
end

(*Managing advantage *)
type advantage =
   | Advantage
   | Disadvantage
let d ?advantage sidedness =
   let open Possibles in
   match advantage with
   | None -> die sidedness
   | Some Advantage -> lift2 max (die sidedness) (die sidedness)
   | Some Disadvantage -> lift2 min (die sidedness) (die sidedness)

(* Specialised 20-sided die *)
let d20 = d 20
let d20_advantage = d ~advantage:Advantage 20
let d20_disadvantage = d ~advantage:Disadvantage 20

(* Possible outcomes of an attack roll *)
type hit_result =
   | Crit_fail
   | Fail
   | Success
   | Crit_success
(* Determining the outcome of an attack roll *)
let hit_result ac roll bonus =
   if roll = 1 then
      Crit_fail
   else if roll = 20 then
      Crit_success
   else if roll + bonus < ac then
      Fail
   else if roll + bonus >= ac then
      Success
   else
      assert false

(* All possible outcomes of an attack roll *)
let hit ?advantage ~bonus ~ac () =
   Possibles.map
      (d ?advantage 20)
      (fun roll -> hit_result ac roll bonus)

(* Analysing the possible outcomes of an attack roll *)
let rates results =
   let total = float_of_int (List.length results) in
   let rate results kind =
      let kl = List.length (List.filter ((=) kind) results) in
      (float_of_int kl) /. total
   in
   (rate results Crit_fail,
    rate results Fail,
    rate results Success,
    rate results Crit_success
   )

(* Rolling for damage *)
let damage ddice bonus =
   List.fold_left
      (* For each die, add all the possible outcomes *)
      (fun res ddie -> (Possibles.lift2 (+)) res (d ddie))
      (* Start with the bonus *)
      (Possibles.return bonus)
      (* Iterate over all dice *)
      ddice

(* roll for attack and determine damage based on outcome *)
let attack ?advantage ~ac ~hit_bonus ~damage_dice ~damage_bonus () =
   let open Possibles in
   hit ?advantage ~ac ~bonus:hit_bonus () >>= function
   | Crit_fail | Fail -> return 0
   | Success -> damage damage_dice damage_bonus
   | Crit_success -> damage (damage_dice @ damage_dice) damage_bonus

(* Compact representation *)
let length_encode l =
   match l with
   | [] -> []
   | h::t ->
      let (v, c, l) =
         List.fold_left
            (fun (value, count, l) new_value ->
               if value = new_value then
                  (value, count + 1, l)
               else
                  (new_value, 1, (value, count) :: l)
            )
            (h, 1, [])
            t
      in
      (v, c) :: l

let rates_of_len_encode l =
   let total = float_of_int (List.fold_left (+) 0 (List.map snd l)) in
   List.map (fun (v,c) -> (v, (float_of_int c) /. total)) l
let average l =
   let q = List.length l in
   let t = List.fold_left (+) 0 l in
   (float_of_int t) /. (float_of_int q)
let median_sorted l =
   let ll = List.rev l in
   let d = List.map2 (fun x y -> (x,y)) l ll in
   let rec loop = function
      | (x, y) :: t when x < y -> loop t
      | (x, y) :: _ when x = y -> x
      | (x, y) :: _ when x > y -> (x+y) / 2
      | _ -> assert false
   in
   loop d

let process_attack_result res =
   let res = Possibles.to_list res in
   let sorted_res = List.sort compare res in
   let len_encoded_res = length_encode sorted_res in
   let rates = rates_of_len_encode len_encoded_res in
   (average res, median_sorted sorted_res, rates)