← Back to branch summary

~ubuntu-branches/ubuntu/maverick/blender/maverick

« back to all changes in this revision

Viewing changes to extern/fftw/genfft/oracle.ml

  • Committer: Bazaar Package Importer
  • Author(s): Khashayar Naderehvandi, Khashayar Naderehvandi, Alessio Treglia
  • Date: 2009-01-22 16:53:59 UTC
  • mfrom: (14.1.1 experimental)
  • Revision ID: james.westby@ubuntu.com-20090122165359-v0996tn7fbit64ni
Tags: 2.48a+dfsg-1ubuntu1
https://launchpad.net/bugs/320045
[ Khashayar Naderehvandi ]
* Merge from debian experimental (LP: #320045), Ubuntu remaining changes:
  - Add patch correcting header file locations.
  - Add libvorbis-dev and libgsm1-dev to Build-Depends.
  - Use avcodec_decode_audio2() in source/blender/src/hddaudio.c

[ Alessio Treglia ]
* Add missing previous changelog entries.

Show diffs side-by-side

added added

removed removed

Lines of Context:
extern/fftw/genfft/oracle.ml
 
1
(*
 
2
 * Copyright (c) 1997-1999 Massachusetts Institute of Technology
 
3
 * Copyright (c) 2003, 2006 Matteo Frigo
 
4
 * Copyright (c) 2003, 2006 Massachusetts Institute of Technology
 
5
 *
 
6
 * This program is free software; you can redistribute it and/or modify
 
7
 * it under the terms of the GNU General Public License as published by
 
8
 * the Free Software Foundation; either version 2 of the License, or
 
9
 * (at your option) any later version.
 
10
 *
 
11
 * This program is distributed in the hope that it will be useful,
 
12
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 
13
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
14
 * GNU General Public License for more details.
 
15
 *
 
16
 * You should have received a copy of the GNU General Public License
 
17
 * along with this program; if not, write to the Free Software
 
18
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 
19
 *
 
20
 *)
 
21
(* $Id: oracle.ml,v 1.9 2006-02-13 01:12:10 athena Exp $ *)
 
22
 
 
23
(*
 
24
 * the oracle decrees whether the sign of an expression should
 
25
 * be changed.
 
26
 *
 
27
 * Say the expression (A - B) appears somewhere.  Elsewhere in the
 
28
 * expression dag the expression (B - A) may appear.
 
29
 * The oracle determines which of the two forms is canonical.
 
30
 *
 
31
 * Algorithm: evaluate the expression at a random input, and
 
32
 * keep the expression with the positive sign.
 
33
 *)
 
34
 
 
35
let make_memoizer hash equal =
 
36
  let table = ref Assoctable.empty 
 
37
  in 
 
38
  (fun f k ->
 
39
    match Assoctable.lookup hash equal k !table with
 
40
      Some value -> value
 
41
    | None ->
 
42
        let value = f k in
 
43
        begin   
 
44
          table := Assoctable.insert hash k value !table;
 
45
          value
 
46
        end)
 
47
 
 
48
let almost_equal x y = 
 
49
  let epsilon = 1.0E-8 in
 
50
  (abs_float (x -. y) < epsilon) ||
 
51
  (abs_float (x -. y) < epsilon *. (abs_float x +. abs_float y)) 
 
52
 
 
53
let absid = make_memoizer
 
54
    (fun x -> Expr.hash_float (abs_float x))
 
55
    (fun a b -> almost_equal a b || almost_equal (-. a) b)
 
56
    (fun x -> x)
 
57
 
 
58
let make_random_oracle () = make_memoizer 
 
59
    Variable.hash 
 
60
    Variable.same
 
61
    (fun _ -> (float (Random.bits())) /. 1073741824.0)
 
62
 
 
63
let the_random_oracle = make_random_oracle ()
 
64
 
 
65
let sum_list l = List.fold_right (+.) l 0.0
 
66
 
 
67
let eval_aux random_oracle =
 
68
  let memoizing = make_memoizer Expr.hash (==) in
 
69
  let rec eval x = 
 
70
    memoizing
 
71
      (function
 
72
        | Expr.Num x -> Number.to_float x
 
73
        | Expr.NaN x -> Expr.transcendent_to_float x
 
74
        | Expr.Load v -> random_oracle v
 
75
        | Expr.Store (v, x) -> eval x
 
76
        | Expr.Plus l -> sum_list (List.map eval l)
 
77
        | Expr.Times (a, b) -> (eval a) *. (eval b)
 
78
        | Expr.CTimes (a, b) -> 
 
79
            1.098612288668109691395245236 +. 
 
80
               1.609437912434100374600759333 *. (eval a) *. (eval b)
 
81
        | Expr.CTimesJ (a, b) -> 
 
82
            0.9102392266268373936142401657 +. 
 
83
              0.6213349345596118107071993881 *. (eval a) *. (eval b)
 
84
        | Expr.Uminus x -> -. (eval x))
 
85
      x
 
86
  in eval
 
87
 
 
88
let eval = eval_aux the_random_oracle
 
89
 
 
90
let should_flip_sign node = 
 
91
  let v = eval node in
 
92
  let v' = absid v in
 
93
  not (almost_equal v v')
 
94
 
 
95
(*
 
96
 * determine with high probability if two expressions are equal.
 
97
 *
 
98
 * The test is randomized: if the two expressions have the
 
99
 * same value for NTESTS random inputs, then they are proclaimed
 
100
 * equal.  (Note that two distinct linear functions L1(x0, x1, ..., xn)
 
101
 * and L2(x0, x1, ..., xn) have the same value with probability
 
102
 * 0 for random x's, and thus this test is way more paranoid than
 
103
 * necessary.)
 
104
 *)
 
105
let likely_equal a b =
 
106
  let tolerance = 1.0e-8
 
107
  and ntests = 20
 
108
  in
 
109
  let rec loop n =
 
110
    if n = 0 then 
 
111
      true
 
112
    else
 
113
      let r = make_random_oracle () in
 
114
      let va = eval_aux r a
 
115
      and vb = eval_aux r b
 
116
      in
 
117
      if (abs_float (va -. vb)) > 
 
118
           tolerance *. (abs_float va +. abs_float vb +. 0.0001)
 
119
      then
 
120
        false
 
121
      else
 
122
        loop (n - 1)
 
123
  in
 
124
  match (a, b) with
 
125
 
 
126
    (* 
 
127
     * Because of the way eval is constructed, we have
 
128
     *     eval (Store (v, x)) == eval x
 
129
     * However, we never consider the two expressions equal
 
130
     *)
 
131
  | (Expr.Store _, _) -> false
 
132
  | (_, Expr.Store _) -> false
 
133
 
 
134
    (*
 
135
     * Expressions of the form ``Uminus (Store _)''
 
136
     * are artifacts of algsimp
 
137
     *)
 
138
  | ((Expr.Uminus (Expr.Store _)), _) -> false
 
139
  | (_, Expr.Uminus (Expr.Store _)) -> false
 
140
 
 
141
  | _ -> loop ntests
 
142
 
 
143
let hash x =
 
144
  let f = eval x in
 
145
  truncate (f *. 65536.0)