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