(* JudyBenjaminEntropy . nb  :  
                  See Grove  & Halpern 1997 *)

(* Relative entropy of q with respect to p *)
relEntropy[ q_, p_] :=  
        Plus  @@  ( q Log[ (q/p)])

(* Prior Probability p= { Pr[Blue2nd],  Pr[BlueHQ],  Pr[Red2nd],  
              Pr[RedHQ] } *) 
p =  {1/4,  1/4,  1/4,  
            1/4} ;

(* Set of possible probabilities consistent with new evidence:
Odds are a : 
                  1 that if she is in Red then she is in RedHQ *)
q[a_, x_, y_] :=  {x,  
            y,  (1/(1 + a)) (1 - x - y),  (a/(1 + a)) (1 - 
                  x - y) } ;

(* 
      Function of (x, 
          y) to be minimized (parametrized by odds a) *) 
f[a_, x_, y_] :=  
If[ 
          x  >  0   &&   y  >  0   &&   x + y  <  
              1, 
relEntropy[ q[a, x, y],  
            p], 
-1 ] ;

(* The x, 
          y that give the "best" revised probability q[x, 
              y] should be at the minimum  of this surface *)
ContourPlot[ 
          f[3,  x, y],  {x, 0, 1},  {y, 0, 
            1},  
PlotPoints -> 200,  
          Contours -> 30,  
          ContourShading -> False] ;

(* Look at a diagonal cross section *)
Plot[ 
          f[3, x, x],  {x, 0, 0.5}];

(* Take the derivative *)
dgdx[a_, x_] := 
          Simplify[ 
            D[ relEntropy[ q[a, u, u],  p],  u]   /.  
              u -> x  ];

dgdx[3, x]

(* Get the minimum by setting the derivative to zero *)
xmin =  
        Simplify[  Solve[ dgdx[3, x] == 0,  x ] ]

xmin //  N

(*In general: *)
dgdx[ a, x]  //  Simplify

(* As a increases,  xmin goes from 1/4 to 1/3 *)
Table[ {a,  
            NSolve[dgdx[a, x] == 0, x]},  {a, 1, 10}]  //  
        MatrixForm

NSolve[dgdx[100, x] == 0, x]

Plot[ 
      Evaluate[Table[ f[a, x, x],  {a, 1, 10}]],  {x, 0, 0.5}]

Limit[ dgdx[a, x],  a -> ∞]

Solve[ -2 Log[1 - 2 x] + 2 Log[x]  == 0,  
      x ]

arxx =  
        Table[ NSolve[dgdx[a, x] == 0, 
                  x][[1]][[1]][[2]],  {a, 1, 
            50}] ;

(* 
      Show revised probability of Blue2nd vs odds a *) 
ListPlot[ arxx,  
      PlotRange -> {1/4. ,  1/3. },  
      AxesOrigin -> {0, 0.25} ]