cannam@167: (* cannam@167: * Copyright (c) 1997-1999 Massachusetts Institute of Technology cannam@167: * Copyright (c) 2003, 2007-14 Matteo Frigo cannam@167: * Copyright (c) 2003, 2007-14 Massachusetts Institute of Technology cannam@167: * cannam@167: * This program is free software; you can redistribute it and/or modify cannam@167: * it under the terms of the GNU General Public License as published by cannam@167: * the Free Software Foundation; either version 2 of the License, or cannam@167: * (at your option) any later version. cannam@167: * cannam@167: * This program is distributed in the hope that it will be useful, cannam@167: * but WITHOUT ANY WARRANTY; without even the implied warranty of cannam@167: * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the cannam@167: * GNU General Public License for more details. cannam@167: * cannam@167: * You should have received a copy of the GNU General Public License cannam@167: * along with this program; if not, write to the Free Software cannam@167: * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA cannam@167: * cannam@167: *) cannam@167: cannam@167: (* Here, we define the data type encapsulating a symbolic arithmetic cannam@167: expression, and provide some routines for manipulating it. *) cannam@167: cannam@167: (* I will regret this hack : *) cannam@167: (* NEWS: I did *) cannam@167: type transcendent = I | MULTI_A | MULTI_B | CONJ cannam@167: cannam@167: type expr = cannam@167: | Num of Number.number cannam@167: | NaN of transcendent cannam@167: | Plus of expr list cannam@167: | Times of expr * expr cannam@167: | CTimes of expr * expr cannam@167: | CTimesJ of expr * expr (* CTimesJ (a, b) = conj(a) * b *) cannam@167: | Uminus of expr cannam@167: | Load of Variable.variable cannam@167: | Store of Variable.variable * expr cannam@167: cannam@167: type assignment = Assign of Variable.variable * expr cannam@167: cannam@167: (* various hash functions *) cannam@167: let hash_float x = cannam@167: let (mantissa, exponent) = frexp x cannam@167: in truncate (float_of_int(exponent) *. 1234.567 +. mantissa *. 10000.0) cannam@167: cannam@167: let sum_list l = List.fold_right (+) l 0 cannam@167: cannam@167: let transcendent_to_float = function cannam@167: | I -> 2.718281828459045235360287471 (* any transcendent number will do *) cannam@167: | MULTI_A -> 0.6931471805599453094172321214 cannam@167: | MULTI_B -> -0.3665129205816643270124391582 cannam@167: | CONJ -> 0.6019072301972345747375400015 cannam@167: cannam@167: let rec hash = function cannam@167: | Num x -> hash_float (Number.to_float x) cannam@167: | NaN x -> hash_float (transcendent_to_float x) cannam@167: | Load v -> 1 + 1237 * Variable.hash v cannam@167: | Store (v, x) -> 2 * Variable.hash v - 2345 * hash x cannam@167: | Plus l -> 5 + 23451 * sum_list (List.map Hashtbl.hash l) cannam@167: | Times (a, b) -> 41 + 31415 * (Hashtbl.hash a + Hashtbl.hash b) cannam@167: | CTimes (a, b) -> 49 + 3245 * (Hashtbl.hash a + Hashtbl.hash b) cannam@167: | CTimesJ (a, b) -> 31 + 3471 * (Hashtbl.hash a + Hashtbl.hash b) cannam@167: | Uminus x -> 42 + 12345 * (hash x) cannam@167: cannam@167: (* find all variables *) cannam@167: let rec find_vars x = cannam@167: match x with cannam@167: | Load y -> [y] cannam@167: | Plus l -> List.flatten (List.map find_vars l) cannam@167: | Times (a, b) -> (find_vars a) @ (find_vars b) cannam@167: | CTimes (a, b) -> (find_vars a) @ (find_vars b) cannam@167: | CTimesJ (a, b) -> (find_vars a) @ (find_vars b) cannam@167: | Uminus a -> find_vars a cannam@167: | _ -> [] cannam@167: cannam@167: cannam@167: (* TRUE if expression is a constant *) cannam@167: let is_constant = function cannam@167: | Num _ -> true cannam@167: | NaN _ -> true cannam@167: | Load v -> Variable.is_constant v cannam@167: | _ -> false cannam@167: cannam@167: let is_known_constant = function cannam@167: | Num _ -> true cannam@167: | NaN _ -> true cannam@167: | _ -> false cannam@167: cannam@167: (* expr to string, used for debugging *) cannam@167: let rec foldr_string_concat l = cannam@167: match l with cannam@167: [] -> "" cannam@167: | [a] -> a cannam@167: | a :: b -> a ^ " " ^ (foldr_string_concat b) cannam@167: cannam@167: let string_of_transcendent = function cannam@167: | I -> "I" cannam@167: | MULTI_A -> "MULTI_A" cannam@167: | MULTI_B -> "MULTI_B" cannam@167: | CONJ -> "CONJ" cannam@167: cannam@167: let rec to_string = function cannam@167: | Load v -> Variable.unparse v cannam@167: | Num n -> string_of_float (Number.to_float n) cannam@167: | NaN n -> string_of_transcendent n cannam@167: | Plus x -> "(+ " ^ (foldr_string_concat (List.map to_string x)) ^ ")" cannam@167: | Times (a, b) -> "(* " ^ (to_string a) ^ " " ^ (to_string b) ^ ")" cannam@167: | CTimes (a, b) -> "(c* " ^ (to_string a) ^ " " ^ (to_string b) ^ ")" cannam@167: | CTimesJ (a, b) -> "(cj* " ^ (to_string a) ^ " " ^ (to_string b) ^ ")" cannam@167: | Uminus a -> "(- " ^ (to_string a) ^ ")" cannam@167: | Store (v, a) -> "(:= " ^ (Variable.unparse v) ^ " " ^ cannam@167: (to_string a) ^ ")" cannam@167: cannam@167: let rec to_string_a d x = cannam@167: if (d = 0) then "..." else match x with cannam@167: | Load v -> Variable.unparse v cannam@167: | Num n -> Number.to_konst n cannam@167: | NaN n -> string_of_transcendent n cannam@167: | Plus x -> "(+ " ^ (foldr_string_concat (List.map (to_string_a (d - 1)) x)) ^ ")" cannam@167: | Times (a, b) -> "(* " ^ (to_string_a (d - 1) a) ^ " " ^ (to_string_a (d - 1) b) ^ ")" cannam@167: | CTimes (a, b) -> "(c* " ^ (to_string_a (d - 1) a) ^ " " ^ (to_string_a (d - 1) b) ^ ")" cannam@167: | CTimesJ (a, b) -> "(cj* " ^ (to_string_a (d - 1) a) ^ " " ^ (to_string_a (d - 1) b) ^ ")" cannam@167: | Uminus a -> "(- " ^ (to_string_a (d-1) a) ^ ")" cannam@167: | Store (v, a) -> "(:= " ^ (Variable.unparse v) ^ " " ^ cannam@167: (to_string_a (d-1) a) ^ ")" cannam@167: cannam@167: let to_string = to_string_a 10 cannam@167: cannam@167: let assignment_to_string = function cannam@167: | Assign (v, a) -> "(:= " ^ (Variable.unparse v) ^ " " ^ (to_string a) ^ ")" cannam@167: cannam@167: let dump print = List.iter (fun x -> print ((assignment_to_string x) ^ "\n")) cannam@167: cannam@167: (* find all constants in a given expression *) cannam@167: let rec expr_to_constants = function cannam@167: | Num n -> [n] cannam@167: | Plus a -> List.flatten (List.map expr_to_constants a) cannam@167: | Times (a, b) -> (expr_to_constants a) @ (expr_to_constants b) cannam@167: | CTimes (a, b) -> (expr_to_constants a) @ (expr_to_constants b) cannam@167: | CTimesJ (a, b) -> (expr_to_constants a) @ (expr_to_constants b) cannam@167: | Uminus a -> expr_to_constants a cannam@167: | _ -> [] cannam@167: cannam@167: cannam@167: let add_float_key_value list_so_far k = cannam@167: if List.exists (fun k2 -> Number.equal k k2) list_so_far then cannam@167: list_so_far cannam@167: else cannam@167: k :: list_so_far cannam@167: cannam@167: let unique_constants = List.fold_left add_float_key_value []