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