Chris@19: (*
Chris@19:  * Copyright (c) 1997-1999 Massachusetts Institute of Technology
Chris@19:  * Copyright (c) 2003, 2007-14 Matteo Frigo
Chris@19:  * Copyright (c) 2003, 2007-14 Massachusetts Institute of Technology
Chris@19:  *
Chris@19:  * This program is free software; you can redistribute it and/or modify
Chris@19:  * it under the terms of the GNU General Public License as published by
Chris@19:  * the Free Software Foundation; either version 2 of the License, or
Chris@19:  * (at your option) any later version.
Chris@19:  *
Chris@19:  * This program is distributed in the hope that it will be useful,
Chris@19:  * but WITHOUT ANY WARRANTY; without even the implied warranty of
Chris@19:  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
Chris@19:  * GNU General Public License for more details.
Chris@19:  *
Chris@19:  * You should have received a copy of the GNU General Public License
Chris@19:  * along with this program; if not, write to the Free Software
Chris@19:  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
Chris@19:  *
Chris@19:  *)
Chris@19: 
Chris@19: (*
Chris@19:  * the oracle decrees whether the sign of an expression should
Chris@19:  * be changed.
Chris@19:  *
Chris@19:  * Say the expression (A - B) appears somewhere.  Elsewhere in the
Chris@19:  * expression dag the expression (B - A) may appear.
Chris@19:  * The oracle determines which of the two forms is canonical.
Chris@19:  *
Chris@19:  * Algorithm: evaluate the expression at a random input, and
Chris@19:  * keep the expression with the positive sign.
Chris@19:  *)
Chris@19: 
Chris@19: let make_memoizer hash equal =
Chris@19:   let table = ref Assoctable.empty 
Chris@19:   in 
Chris@19:   (fun f k ->
Chris@19:     match Assoctable.lookup hash equal k !table with
Chris@19:       Some value -> value
Chris@19:     | None ->
Chris@19:         let value = f k in
Chris@19:         begin	
Chris@19:           table := Assoctable.insert hash k value !table;
Chris@19:           value
Chris@19:         end)
Chris@19: 
Chris@19: let almost_equal x y = 
Chris@19:   let epsilon = 1.0E-8 in
Chris@19:   (abs_float (x -. y) < epsilon) ||
Chris@19:   (abs_float (x -. y) < epsilon *. (abs_float x +. abs_float y)) 
Chris@19: 
Chris@19: let absid = make_memoizer
Chris@19:     (fun x -> Expr.hash_float (abs_float x))
Chris@19:     (fun a b -> almost_equal a b || almost_equal (-. a) b)
Chris@19:     (fun x -> x)
Chris@19: 
Chris@19: let make_random_oracle () = make_memoizer 
Chris@19:     Variable.hash 
Chris@19:     Variable.same
Chris@19:     (fun _ -> (float (Random.bits())) /. 1073741824.0)
Chris@19: 
Chris@19: let the_random_oracle = make_random_oracle ()
Chris@19: 
Chris@19: let sum_list l = List.fold_right (+.) l 0.0
Chris@19: 
Chris@19: let eval_aux random_oracle =
Chris@19:   let memoizing = make_memoizer Expr.hash (==) in
Chris@19:   let rec eval x = 
Chris@19:     memoizing
Chris@19:       (function
Chris@19: 	| Expr.Num x -> Number.to_float x
Chris@19: 	| Expr.NaN x -> Expr.transcendent_to_float x
Chris@19: 	| Expr.Load v -> random_oracle v
Chris@19: 	| Expr.Store (v, x) -> eval x
Chris@19: 	| Expr.Plus l -> sum_list (List.map eval l)
Chris@19: 	| Expr.Times (a, b) -> (eval a) *. (eval b)
Chris@19: 	| Expr.CTimes (a, b) -> 
Chris@19: 	    1.098612288668109691395245236 +. 
Chris@19: 	       1.609437912434100374600759333 *. (eval a) *. (eval b)
Chris@19: 	| Expr.CTimesJ (a, b) -> 
Chris@19: 	    0.9102392266268373936142401657 +. 
Chris@19: 	      0.6213349345596118107071993881 *. (eval a) *. (eval b)
Chris@19: 	| Expr.Uminus x -> -. (eval x))
Chris@19:       x
Chris@19:   in eval
Chris@19: 
Chris@19: let eval = eval_aux the_random_oracle
Chris@19: 
Chris@19: let should_flip_sign node = 
Chris@19:   let v = eval node in
Chris@19:   let v' = absid v in
Chris@19:   not (almost_equal v v')
Chris@19: 
Chris@19: (*
Chris@19:  * determine with high probability if two expressions are equal.
Chris@19:  *
Chris@19:  * The test is randomized: if the two expressions have the
Chris@19:  * same value for NTESTS random inputs, then they are proclaimed
Chris@19:  * equal.  (Note that two distinct linear functions L1(x0, x1, ..., xn)
Chris@19:  * and L2(x0, x1, ..., xn) have the same value with probability
Chris@19:  * 0 for random x's, and thus this test is way more paranoid than
Chris@19:  * necessary.)
Chris@19:  *)
Chris@19: let likely_equal a b =
Chris@19:   let tolerance = 1.0e-8
Chris@19:   and ntests = 20
Chris@19:   in
Chris@19:   let rec loop n =
Chris@19:     if n = 0 then 
Chris@19:       true
Chris@19:     else
Chris@19:       let r = make_random_oracle () in
Chris@19:       let va = eval_aux r a
Chris@19:       and vb = eval_aux r b
Chris@19:       in
Chris@19:       if (abs_float (va -. vb)) > 
Chris@19: 	   tolerance *. (abs_float va +. abs_float vb +. 0.0001)
Chris@19:       then
Chris@19: 	false
Chris@19:       else
Chris@19: 	loop (n - 1)
Chris@19:   in
Chris@19:   match (a, b) with
Chris@19: 
Chris@19:     (* 
Chris@19:      * Because of the way eval is constructed, we have
Chris@19:      *     eval (Store (v, x)) == eval x
Chris@19:      * However, we never consider the two expressions equal
Chris@19:      *)
Chris@19:   | (Expr.Store _, _) -> false
Chris@19:   | (_, Expr.Store _) -> false
Chris@19: 
Chris@19:     (*
Chris@19:      * Expressions of the form ``Uminus (Store _)''
Chris@19:      * are artifacts of algsimp
Chris@19:      *)
Chris@19:   | ((Expr.Uminus (Expr.Store _)), _) -> false
Chris@19:   | (_, Expr.Uminus (Expr.Store _)) -> false
Chris@19: 
Chris@19:   | _ -> loop ntests
Chris@19: 
Chris@19: let hash x =
Chris@19:   let f = eval x in
Chris@19:   truncate (f *. 65536.0)